summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorshayne_fletcher <>2020-08-01 14:23:00 (GMT)
committerhdiff <hdiff@hdiff.luite.com>2020-08-01 14:23:00 (GMT)
commite0f7db35f6999cfaece4c12f10769726d221029c (patch)
treec67d6f44e6f143cee820412f2cb3509fee3a1244
parent1d316837dd345274b4ccf138d780b5541f0cb044 (diff)
version 0.202008010.20200801
-rw-r--r--compiler/GHC.hs (renamed from compiler/main/GHC.hs)491
-rw-r--r--compiler/GHC/Builtin/Names/TH.hs (renamed from compiler/prelude/THNames.hs)360
-rw-r--r--compiler/GHC/Builtin/RebindableNames.hs6
-rw-r--r--compiler/GHC/Builtin/Types/Literals.hs (renamed from compiler/typecheck/TcTypeNats.hs)55
-rw-r--r--compiler/GHC/Builtin/Utils.hs (renamed from compiler/prelude/PrelInfo.hs)106
-rw-r--r--compiler/GHC/ByteCode/Asm.hs (renamed from compiler/ghci/ByteCodeAsm.hs)162
-rw-r--r--compiler/GHC/ByteCode/InfoTable.hs (renamed from compiler/ghci/ByteCodeItbls.hs)54
-rw-r--r--compiler/GHC/ByteCode/Instr.hs (renamed from compiler/ghci/ByteCodeInstr.hs)37
-rw-r--r--compiler/GHC/ByteCode/Linker.hs (renamed from compiler/ghci/ByteCodeLink.hs)45
-rw-r--r--compiler/GHC/Cmm/CallConv.hs (renamed from compiler/cmm/CmmCallConv.hs)174
-rw-r--r--compiler/GHC/Cmm/CommonBlockElim.hs (renamed from compiler/cmm/CmmCommonBlockElim.hs)33
-rw-r--r--compiler/GHC/Cmm/ContFlowOpt.hs (renamed from compiler/cmm/CmmContFlowOpt.hs)34
-rw-r--r--compiler/GHC/Cmm/Dataflow.hs (renamed from compiler/cmm/Hoopl/Dataflow.hs)24
-rw-r--r--compiler/GHC/Cmm/DebugBlock.hs (renamed from compiler/cmm/Debug.hs)99
-rw-r--r--compiler/GHC/Cmm/Graph.hs (renamed from compiler/cmm/MkGraph.hs)163
-rw-r--r--compiler/GHC/Cmm/Info.hs (renamed from compiler/cmm/CmmInfo.hs)387
-rw-r--r--compiler/GHC/Cmm/Info/Build.hs1200
-rw-r--r--compiler/GHC/Cmm/LayoutStack.hs (renamed from compiler/cmm/CmmLayoutStack.hs)227
-rw-r--r--compiler/GHC/Cmm/Lexer.x (renamed from compiler/cmm/CmmLex.x)42
-rw-r--r--compiler/GHC/Cmm/Lint.hs (renamed from compiler/cmm/CmmLint.hs)79
-rw-r--r--compiler/GHC/Cmm/Liveness.hs (renamed from compiler/cmm/CmmLive.hs)24
-rw-r--r--compiler/GHC/Cmm/Monad.hs (renamed from compiler/cmm/CmmMonad.hs)50
-rw-r--r--compiler/GHC/Cmm/Opt.hs (renamed from compiler/cmm/CmmOpt.hs)111
-rw-r--r--compiler/GHC/Cmm/Parser.y (renamed from compiler/cmm/CmmParse.y)429
-rw-r--r--compiler/GHC/Cmm/Pipeline.hs (renamed from compiler/cmm/CmmPipeline.hs)115
-rw-r--r--compiler/GHC/Cmm/Ppr.hs (renamed from compiler/cmm/PprCmm.hs)77
-rw-r--r--compiler/GHC/Cmm/Ppr/Decl.hs (renamed from compiler/cmm/PprCmmDecl.hs)49
-rw-r--r--compiler/GHC/Cmm/Ppr/Expr.hs (renamed from compiler/cmm/PprCmmExpr.hs)116
-rw-r--r--compiler/GHC/Cmm/ProcPoint.hs (renamed from compiler/cmm/CmmProcPoint.hs)54
-rw-r--r--compiler/GHC/Cmm/Sink.hs (renamed from compiler/cmm/CmmSink.hs)94
-rw-r--r--compiler/GHC/Cmm/Switch/Implement.hs118
-rw-r--r--compiler/GHC/Cmm/Utils.hs (renamed from compiler/cmm/CmmUtils.hs)353
-rw-r--r--compiler/GHC/CmmToAsm.hs (renamed from compiler/nativeGen/AsmCodeGen.hs)504
-rw-r--r--compiler/GHC/CmmToAsm/BlockLayout.hs939
-rw-r--r--compiler/GHC/CmmToAsm/CFG.hs1349
-rw-r--r--compiler/GHC/CmmToAsm/CFG/Dominators.hs597
-rw-r--r--compiler/GHC/CmmToAsm/CPrim.hs (renamed from compiler/nativeGen/CPrim.hs)30
-rw-r--r--compiler/GHC/CmmToAsm/Dwarf.hs (renamed from compiler/nativeGen/Dwarf.hs)77
-rw-r--r--compiler/GHC/CmmToAsm/Dwarf/Constants.hs (renamed from compiler/nativeGen/Dwarf/Constants.hs)45
-rw-r--r--compiler/GHC/CmmToAsm/Dwarf/Types.hs (renamed from compiler/nativeGen/Dwarf/Types.hs)205
-rw-r--r--compiler/GHC/CmmToAsm/Format.hs (renamed from compiler/nativeGen/Format.hs)16
-rw-r--r--compiler/GHC/CmmToAsm/Instr.hs (renamed from compiler/nativeGen/Instruction.hs)34
-rw-r--r--compiler/GHC/CmmToAsm/Monad.hs (renamed from compiler/nativeGen/NCGMonad.hs)149
-rw-r--r--compiler/GHC/CmmToAsm/PIC.hs (renamed from compiler/nativeGen/PIC.hs)514
-rw-r--r--compiler/GHC/CmmToAsm/PPC/CodeGen.hs (renamed from compiler/nativeGen/PPC/CodeGen.hs)445
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Cond.hs (renamed from compiler/nativeGen/PPC/Cond.hs)22
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Instr.hs (renamed from compiler/nativeGen/PPC/Instr.hs)138
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Ppr.hs1123
-rw-r--r--compiler/GHC/CmmToAsm/PPC/RegInfo.hs (renamed from compiler/nativeGen/PPC/RegInfo.hs)23
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Regs.hs (renamed from compiler/nativeGen/PPC/Regs.hs)47
-rw-r--r--compiler/GHC/CmmToAsm/Ppr.hs (renamed from compiler/nativeGen/PprBase.hs)149
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph.hs (renamed from compiler/nativeGen/RegAlloc/Graph/Main.hs)108
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Base.hs (renamed from compiler/nativeGen/RegAlloc/Graph/ArchBase.hs)14
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs (renamed from compiler/nativeGen/RegAlloc/Graph/Coalesce.hs)26
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs (renamed from compiler/nativeGen/RegAlloc/Graph/Spill.hs)68
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs (renamed from compiler/nativeGen/RegAlloc/Graph/SpillClean.hs)78
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs (renamed from compiler/nativeGen/RegAlloc/Graph/SpillCost.hs)149
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs (renamed from compiler/nativeGen/RegAlloc/Graph/Stats.hs)77
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs (renamed from compiler/nativeGen/RegAlloc/Graph/TrivColorable.hs)59
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Graph/X86.hs (renamed from compiler/nativeGen/RegAlloc/Graph/ArchX86.hs)8
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear.hs (renamed from compiler/nativeGen/RegAlloc/Linear/Main.hs)246
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/Base.hs (renamed from compiler/nativeGen/RegAlloc/Linear/Base.hs)35
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs (renamed from compiler/nativeGen/RegAlloc/Linear/FreeRegs.hs)61
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs (renamed from compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs)55
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/PPC.hs (renamed from compiler/nativeGen/RegAlloc/Linear/PPC/FreeRegs.hs)20
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/SPARC.hs (renamed from compiler/nativeGen/RegAlloc/Linear/SPARC/FreeRegs.hs)25
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/StackMap.hs (renamed from compiler/nativeGen/RegAlloc/Linear/StackMap.hs)16
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/State.hs (renamed from compiler/nativeGen/RegAlloc/Linear/State.hs)63
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/Stats.hs (renamed from compiler/nativeGen/RegAlloc/Linear/Stats.hs)23
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/X86.hs (renamed from compiler/nativeGen/RegAlloc/Linear/X86/FreeRegs.hs)19
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Linear/X86_64.hs (renamed from compiler/nativeGen/RegAlloc/Linear/X86_64/FreeRegs.hs)19
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Liveness.hs (renamed from compiler/nativeGen/RegAlloc/Liveness.hs)134
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Target.hs (renamed from compiler/nativeGen/TargetReg.hs)31
-rw-r--r--compiler/GHC/CmmToAsm/Reg/Utils.hs59
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/AddrMode.hs (renamed from compiler/nativeGen/SPARC/AddrMode.hs)10
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/Base.hs (renamed from compiler/nativeGen/SPARC/Base.hs)15
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen.hs (renamed from compiler/nativeGen/SPARC/CodeGen.hs)145
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Amode.hs (renamed from compiler/nativeGen/SPARC/CodeGen/Amode.hs)30
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Base.hs (renamed from compiler/nativeGen/SPARC/CodeGen/Base.hs)37
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/CondCode.hs (renamed from compiler/nativeGen/SPARC/CodeGen/CondCode.hs)34
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Expand.hs (renamed from compiler/nativeGen/SPARC/CodeGen/Expand.hs)31
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs (renamed from compiler/nativeGen/SPARC/CodeGen/Gen32.hs)62
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen32.hs-boot16
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Gen64.hs (renamed from compiler/nativeGen/SPARC/CodeGen/Gen64.hs)45
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/CodeGen/Sanity.hs (renamed from compiler/nativeGen/SPARC/CodeGen/Sanity.hs)14
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/Cond.hs27
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/Imm.hs (renamed from compiler/nativeGen/SPARC/Imm.hs)10
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/Instr.hs (renamed from compiler/nativeGen/SPARC/Instr.hs)68
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/Ppr.hs (renamed from compiler/nativeGen/SPARC/Ppr.hs)171
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/Regs.hs (renamed from compiler/nativeGen/SPARC/Regs.hs)20
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/ShortcutJump.hs (renamed from compiler/nativeGen/SPARC/ShortcutJump.hs)24
-rw-r--r--compiler/GHC/CmmToAsm/SPARC/Stack.hs (renamed from compiler/nativeGen/SPARC/Stack.hs)30
-rw-r--r--compiler/GHC/CmmToAsm/X86/CodeGen.hs (renamed from compiler/nativeGen/X86/CodeGen.hs)1495
-rw-r--r--compiler/GHC/CmmToAsm/X86/Cond.hs (renamed from compiler/nativeGen/X86/Cond.hs)22
-rw-r--r--compiler/GHC/CmmToAsm/X86/Instr.hs (renamed from compiler/nativeGen/X86/Instr.hs)286
-rw-r--r--compiler/GHC/CmmToAsm/X86/Ppr.hs1091
-rw-r--r--compiler/GHC/CmmToAsm/X86/RegInfo.hs73
-rw-r--r--compiler/GHC/CmmToAsm/X86/Regs.hs (renamed from compiler/nativeGen/X86/Regs.hs)131
-rw-r--r--compiler/GHC/CmmToC.hs (renamed from compiler/cmm/PprC.hs)654
-rw-r--r--compiler/GHC/CmmToLlvm.hs (renamed from compiler/llvmGen/LlvmCodeGen.hs)161
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs (renamed from compiler/llvmGen/LlvmCodeGen/Base.hs)352
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs (renamed from compiler/llvmGen/LlvmCodeGen/CodeGen.hs)402
-rw-r--r--compiler/GHC/CmmToLlvm/Data.hs (renamed from compiler/llvmGen/LlvmCodeGen/Data.hs)89
-rw-r--r--compiler/GHC/CmmToLlvm/Mangler.hs (renamed from compiler/llvmGen/LlvmMangler.hs)14
-rw-r--r--compiler/GHC/CmmToLlvm/Ppr.hs (renamed from compiler/llvmGen/LlvmCodeGen/Ppr.hs)49
-rw-r--r--compiler/GHC/CmmToLlvm/Regs.hs (renamed from compiler/llvmGen/LlvmCodeGen/Regs.hs)48
-rw-r--r--compiler/GHC/Core/Opt/CSE.hs (renamed from compiler/simplCore/CSE.hs)218
-rw-r--r--compiler/GHC/Core/Opt/CallArity.hs (renamed from compiler/simplCore/CallArity.hs)36
-rw-r--r--compiler/GHC/Core/Opt/CprAnal.hs713
-rw-r--r--compiler/GHC/Core/Opt/DmdAnal.hs (renamed from compiler/stranal/DmdAnal.hs)1212
-rw-r--r--compiler/GHC/Core/Opt/Driver.hs (renamed from compiler/simplCore/SimplCore.hs)243
-rw-r--r--compiler/GHC/Core/Opt/Exitify.hs (renamed from compiler/simplCore/Exitify.hs)46
-rw-r--r--compiler/GHC/Core/Opt/FloatIn.hs (renamed from compiler/simplCore/FloatIn.hs)172
-rw-r--r--compiler/GHC/Core/Opt/FloatOut.hs (renamed from compiler/simplCore/FloatOut.hs)69
-rw-r--r--compiler/GHC/Core/Opt/LiberateCase.hs (renamed from compiler/simplCore/LiberateCase.hs)24
-rw-r--r--compiler/GHC/Core/Opt/SetLevels.hs (renamed from compiler/simplCore/SetLevels.hs)258
-rw-r--r--compiler/GHC/Core/Opt/Simplify.hs (renamed from compiler/simplCore/Simplify.hs)1290
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Env.hs (renamed from compiler/simplCore/SimplEnv.hs)249
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Monad.hs (renamed from compiler/simplCore/SimplMonad.hs)90
-rw-r--r--compiler/GHC/Core/Opt/Simplify/Utils.hs (renamed from compiler/simplCore/SimplUtils.hs)700
-rw-r--r--compiler/GHC/Core/Opt/SpecConstr.hs (renamed from compiler/specialise/SpecConstr.hs)274
-rw-r--r--compiler/GHC/Core/Opt/Specialise.hs (renamed from compiler/specialise/Specialise.hs)1471
-rw-r--r--compiler/GHC/Core/Opt/StaticArgs.hs (renamed from compiler/simplCore/SAT.hs)49
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap.hs (renamed from compiler/stranal/WorkWrap.hs)257
-rw-r--r--compiler/GHC/Core/Opt/WorkWrap/Utils.hs (renamed from compiler/stranal/WwLib.hs)391
-rw-r--r--compiler/GHC/Core/Ppr/TyThing.hs (renamed from compiler/main/PprTyThing.hs)54
-rw-r--r--compiler/GHC/Core/Rules.hs1274
-rw-r--r--compiler/GHC/Core/Tidy.hs289
-rw-r--r--compiler/GHC/CoreToByteCode.hs (renamed from compiler/ghci/ByteCodeGen.hs)566
-rw-r--r--compiler/GHC/CoreToStg.hs (renamed from compiler/stgSyn/CoreToStg.hs)257
-rw-r--r--compiler/GHC/CoreToStg/Prep.hs (renamed from compiler/coreSyn/CorePrep.hs)834
-rw-r--r--compiler/GHC/Data/Bitmap.hs (renamed from compiler/cmm/Bitmap.hs)80
-rw-r--r--compiler/GHC/Data/Graph/Base.hs (renamed from compiler/utils/GraphBase.hs)14
-rw-r--r--compiler/GHC/Data/Graph/Color.hs (renamed from compiler/utils/GraphColor.hs)55
-rw-r--r--compiler/GHC/Data/Graph/Ops.hs (renamed from compiler/utils/GraphOps.hs)102
-rw-r--r--compiler/GHC/Data/Graph/Ppr.hs (renamed from compiler/utils/GraphPpr.hs)22
-rw-r--r--compiler/GHC/Data/Graph/UnVar.hs (renamed from compiler/utils/UnVarGraph.hs)16
-rw-r--r--compiler/GHC/Driver/Backpack.hs (renamed from compiler/backpack/DriverBkp.hs)350
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs (renamed from compiler/main/CodeOutput.hs)224
-rw-r--r--compiler/GHC/Driver/Finder.hs (renamed from compiler/main/Finder.hs)162
-rw-r--r--compiler/GHC/Driver/Main.hs (renamed from compiler/main/HscMain.hs)891
-rw-r--r--compiler/GHC/Driver/Make.hs (renamed from compiler/main/GhcMake.hs)728
-rw-r--r--compiler/GHC/Driver/MakeFile.hs (renamed from compiler/main/DriverMkDepend.hs)70
-rw-r--r--compiler/GHC/Driver/Pipeline.hs (renamed from compiler/main/DriverPipeline.hs)830
-rw-r--r--compiler/GHC/Hs/Stats.hs (renamed from compiler/main/HscStats.hs)42
-rw-r--r--compiler/GHC/HsToCore.hs (renamed from compiler/deSugar/Desugar.hs)341
-rw-r--r--compiler/GHC/HsToCore/Arrows.hs (renamed from compiler/deSugar/DsArrows.hs)304
-rw-r--r--compiler/GHC/HsToCore/Binds.hs (renamed from compiler/deSugar/DsBinds.hs)255
-rw-r--r--compiler/GHC/HsToCore/Binds.hs-boot6
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs (renamed from compiler/deSugar/Coverage.hs)441
-rw-r--r--compiler/GHC/HsToCore/Docs.hs (renamed from compiler/deSugar/ExtractDocs.hs)245
-rw-r--r--compiler/GHC/HsToCore/Expr.hs (renamed from compiler/deSugar/DsExpr.hs)625
-rw-r--r--compiler/GHC/HsToCore/Expr.hs-boot12
-rw-r--r--compiler/GHC/HsToCore/Foreign/Call.hs (renamed from compiler/deSugar/DsCCall.hs)137
-rw-r--r--compiler/GHC/HsToCore/Foreign/Decl.hs (renamed from compiler/deSugar/DsForeign.hs)212
-rw-r--r--compiler/GHC/HsToCore/GuardedRHSs.hs (renamed from compiler/deSugar/DsGRHSs.hs)96
-rw-r--r--compiler/GHC/HsToCore/ListComp.hs (renamed from compiler/deSugar/DsListComp.hs)145
-rw-r--r--compiler/GHC/HsToCore/Match.hs (renamed from compiler/deSugar/Match.hs)447
-rw-r--r--compiler/GHC/HsToCore/Match.hs-boot36
-rw-r--r--compiler/GHC/HsToCore/Match/Constructor.hs (renamed from compiler/deSugar/MatchCon.hs)177
-rw-r--r--compiler/GHC/HsToCore/Match/Literal.hs (renamed from compiler/deSugar/MatchLit.hs)309
-rw-r--r--compiler/GHC/HsToCore/Monad.hs (renamed from compiler/deSugar/DsMonad.hs)260
-rw-r--r--compiler/GHC/HsToCore/PmCheck.hs1311
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Oracle.hs1785
-rw-r--r--compiler/GHC/HsToCore/PmCheck/Ppr.hs222
-rw-r--r--compiler/GHC/HsToCore/Quote.hs (renamed from compiler/deSugar/DsMeta.hs)2024
-rw-r--r--compiler/GHC/HsToCore/Usage.hs (renamed from compiler/deSugar/DsUsage.hs)104
-rw-r--r--compiler/GHC/HsToCore/Utils.hs (renamed from compiler/deSugar/DsUtils.hs)592
-rw-r--r--compiler/GHC/Iface/Binary.hs (renamed from compiler/iface/BinIface.hs)225
-rw-r--r--compiler/GHC/Iface/Env.hs (renamed from compiler/iface/IfaceEnv.hs)50
-rw-r--r--compiler/GHC/Iface/Env.hs-boot9
-rw-r--r--compiler/GHC/Iface/Ext/Ast.hs (renamed from compiler/hieFile/HieAst.hs)1419
-rw-r--r--compiler/GHC/Iface/Ext/Binary.hs (renamed from compiler/hieFile/HieBin.hs)148
-rw-r--r--compiler/GHC/Iface/Ext/Debug.hs159
-rw-r--r--compiler/GHC/Iface/Ext/Types.hs (renamed from compiler/hieFile/HieTypes.hs)307
-rw-r--r--compiler/GHC/Iface/Ext/Utils.hs (renamed from compiler/hieFile/HieUtils.hs)231
-rw-r--r--compiler/GHC/Iface/Load.hs (renamed from compiler/iface/LoadIface.hs)298
-rw-r--r--compiler/GHC/Iface/Load.hs-boot8
-rw-r--r--compiler/GHC/Iface/Make.hs733
-rw-r--r--compiler/GHC/Iface/Recomp.hs (renamed from compiler/iface/MkIface.hs)2089
-rw-r--r--compiler/GHC/Iface/Recomp/Flags.hs (renamed from compiler/iface/FlagChecker.hs)37
-rw-r--r--compiler/GHC/Iface/Rename.hs (renamed from compiler/backpack/RnModIface.hs)108
-rw-r--r--compiler/GHC/Iface/Tidy.hs (renamed from compiler/main/TidyPgm.hs)461
-rw-r--r--compiler/GHC/Iface/Tidy/StaticPtrTable.hs (renamed from compiler/main/StaticPtrTable.hs)60
-rw-r--r--compiler/GHC/Iface/UpdateIdInfos.hs157
-rw-r--r--compiler/GHC/IfaceToCore.hs (renamed from compiler/iface/TcIface.hs)374
-rw-r--r--compiler/GHC/IfaceToCore.hs-boot19
-rw-r--r--compiler/GHC/Llvm.hs (renamed from compiler/llvmGen/Llvm.hs)16
-rw-r--r--compiler/GHC/Llvm/MetaData.hs (renamed from compiler/llvmGen/Llvm/MetaData.hs)36
-rw-r--r--compiler/GHC/Llvm/Ppr.hs606
-rw-r--r--compiler/GHC/Llvm/Syntax.hs (renamed from compiler/llvmGen/Llvm/AbsSyn.hs)10
-rw-r--r--compiler/GHC/Llvm/Types.hs (renamed from compiler/llvmGen/Llvm/Types.hs)240
-rw-r--r--compiler/GHC/Plugins.hs163
-rw-r--r--compiler/GHC/Rename/Bind.hs (renamed from compiler/rename/RnBinds.hs)203
-rw-r--r--compiler/GHC/Rename/Doc.hs (renamed from compiler/rename/RnHsDoc.hs)14
-rw-r--r--compiler/GHC/Rename/Env.hs (renamed from compiler/rename/RnEnv.hs)468
-rw-r--r--compiler/GHC/Rename/Expr.hs (renamed from compiler/rename/RnExpr.hs)671
-rw-r--r--compiler/GHC/Rename/Expr.hs-boot (renamed from compiler/rename/RnExpr.hs-boot)16
-rw-r--r--compiler/GHC/Rename/Fixity.hs (renamed from compiler/rename/RnFixity.hs)58
-rw-r--r--compiler/GHC/Rename/HsType.hs (renamed from compiler/rename/RnTypes.hs)1406
-rw-r--r--compiler/GHC/Rename/Module.hs (renamed from compiler/rename/RnSource.hs)1321
-rw-r--r--compiler/GHC/Rename/Names.hs (renamed from compiler/rename/RnNames.hs)380
-rw-r--r--compiler/GHC/Rename/Pat.hs (renamed from compiler/rename/RnPat.hs)289
-rw-r--r--compiler/GHC/Rename/Splice.hs (renamed from compiler/rename/RnSplice.hs)274
-rw-r--r--compiler/GHC/Rename/Splice.hs-boot (renamed from compiler/rename/RnSplice.hs-boot)10
-rw-r--r--compiler/GHC/Rename/Unbound.hs (renamed from compiler/rename/RnUnbound.hs)78
-rw-r--r--compiler/GHC/Rename/Utils.hs (renamed from compiler/rename/RnUtils.hs)270
-rw-r--r--compiler/GHC/Runtime/Debugger.hs (renamed from compiler/ghci/Debugger.hs)72
-rw-r--r--compiler/GHC/Runtime/Eval.hs (renamed from compiler/main/InteractiveEval.hs)486
-rw-r--r--compiler/GHC/Runtime/Heap/Inspect.hs (renamed from compiler/ghci/RtClosureInspect.hs)259
-rw-r--r--compiler/GHC/Runtime/Interpreter.hs (renamed from compiler/ghci/GHCi.hs)415
-rw-r--r--compiler/GHC/Runtime/Linker.hs (renamed from compiler/ghci/Linker.hs)533
-rw-r--r--compiler/GHC/Runtime/Loader.hs (renamed from compiler/main/DynamicLoading.hs)131
-rw-r--r--compiler/GHC/Settings/IO.hs265
-rw-r--r--compiler/GHC/Stg/CSE.hs (renamed from compiler/simplStg/StgCse.hs)54
-rw-r--r--compiler/GHC/Stg/DepAnal.hs147
-rw-r--r--compiler/GHC/Stg/FVs.hs (renamed from compiler/stgSyn/StgFVs.hs)68
-rw-r--r--compiler/GHC/Stg/Lift.hs (renamed from compiler/simplStg/StgLiftLams/Transformation.hs)151
-rw-r--r--compiler/GHC/Stg/Lift/Analysis.hs (renamed from compiler/simplStg/StgLiftLams/Analysis.hs)91
-rw-r--r--compiler/GHC/Stg/Lift/Monad.hs (renamed from compiler/simplStg/StgLiftLams/LiftM.hs)83
-rw-r--r--compiler/GHC/Stg/Lint.hs (renamed from compiler/stgSyn/StgLint.hs)162
-rw-r--r--compiler/GHC/Stg/Pipeline.hs (renamed from compiler/simplStg/SimplStg.hs)72
-rw-r--r--compiler/GHC/Stg/Stats.hs (renamed from compiler/simplStg/StgStats.hs)12
-rw-r--r--compiler/GHC/Stg/Subst.hs (renamed from compiler/stgSyn/StgSubst.hs)16
-rw-r--r--compiler/GHC/Stg/Unarise.hs (renamed from compiler/simplStg/UnariseStg.hs)106
-rw-r--r--compiler/GHC/StgToCmm.hs (renamed from compiler/codeGen/StgCmm.hs)190
-rw-r--r--compiler/GHC/StgToCmm/ArgRep.hs (renamed from compiler/codeGen/StgCmmArgRep.hs)58
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs (renamed from compiler/codeGen/StgCmmBind.hs)294
-rw-r--r--compiler/GHC/StgToCmm/Bind.hs-boot6
-rw-r--r--compiler/GHC/StgToCmm/CgUtils.hs187
-rw-r--r--compiler/GHC/StgToCmm/Closure.hs (renamed from compiler/codeGen/StgCmmClosure.hs)393
-rw-r--r--compiler/GHC/StgToCmm/DataCon.hs377
-rw-r--r--compiler/GHC/StgToCmm/Env.hs (renamed from compiler/codeGen/StgCmmEnv.hs)97
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs (renamed from compiler/codeGen/StgCmmExpr.hs)285
-rw-r--r--compiler/GHC/StgToCmm/ExtCode.hs (renamed from compiler/codeGen/StgCmmExtCode.hs)68
-rw-r--r--compiler/GHC/StgToCmm/Foreign.hs670
-rw-r--r--compiler/GHC/StgToCmm/Heap.hs (renamed from compiler/codeGen/StgCmmHeap.hs)176
-rw-r--r--compiler/GHC/StgToCmm/Hpc.hs (renamed from compiler/codeGen/StgCmmHpc.hs)39
-rw-r--r--compiler/GHC/StgToCmm/Layout.hs (renamed from compiler/codeGen/StgCmmLayout.hs)166
-rw-r--r--compiler/GHC/StgToCmm/Monad.hs (renamed from compiler/codeGen/StgCmmMonad.hs)146
-rw-r--r--compiler/GHC/StgToCmm/Prim.hs3057
-rw-r--r--compiler/GHC/StgToCmm/Prof.hs (renamed from compiler/codeGen/StgCmmProf.hs)228
-rw-r--r--compiler/GHC/StgToCmm/Ticky.hs (renamed from compiler/codeGen/StgCmmTicky.hs)218
-rw-r--r--compiler/GHC/StgToCmm/Utils.hs (renamed from compiler/codeGen/StgCmmUtils.hs)324
-rw-r--r--compiler/GHC/SysTools.hs (renamed from compiler/main/SysTools.hs)307
-rw-r--r--compiler/GHC/SysTools/Ar.hs (renamed from compiler/main/Ar.hs)10
-rw-r--r--compiler/GHC/SysTools/Elf.hs (renamed from compiler/main/Elf.hs)41
-rw-r--r--compiler/GHC/SysTools/ExtraObj.hs (renamed from compiler/main/SysTools/ExtraObj.hs)63
-rw-r--r--compiler/GHC/SysTools/Info.hs (renamed from compiler/main/SysTools/Info.hs)36
-rw-r--r--compiler/GHC/SysTools/Process.hs (renamed from compiler/main/SysTools/Process.hs)53
-rw-r--r--compiler/GHC/SysTools/Tasks.hs (renamed from compiler/main/SysTools/Tasks.hs)133
-rw-r--r--compiler/GHC/Tc/Deriv.hs (renamed from compiler/typecheck/TcDeriv.hs)1545
-rw-r--r--compiler/GHC/Tc/Deriv/Functor.hs (renamed from compiler/typecheck/TcGenFunctor.hs)505
-rw-r--r--compiler/GHC/Tc/Deriv/Generate.hs (renamed from compiler/typecheck/TcGenDeriv.hs)1376
-rw-r--r--compiler/GHC/Tc/Deriv/Generics.hs (renamed from compiler/typecheck/TcGenGenerics.hs)153
-rw-r--r--compiler/GHC/Tc/Deriv/Infer.hs (renamed from compiler/typecheck/TcDerivInfer.hs)278
-rw-r--r--compiler/GHC/Tc/Deriv/Utils.hs (renamed from compiler/typecheck/TcDerivUtils.hs)393
-rw-r--r--compiler/GHC/Tc/Errors.hs (renamed from compiler/typecheck/TcErrors.hs)1406
-rw-r--r--compiler/GHC/Tc/Errors/Hole.hs (renamed from compiler/typecheck/TcHoleErrors.hs)528
-rw-r--r--compiler/GHC/Tc/Errors/Hole.hs-boot13
-rw-r--r--compiler/GHC/Tc/Gen/Annotation.hs (renamed from compiler/typecheck/TcAnnotations.hs)55
-rw-r--r--compiler/GHC/Tc/Gen/Arrow.hs (renamed from compiler/typecheck/TcArrows.hs)154
-rw-r--r--compiler/GHC/Tc/Gen/Bind.hs (renamed from compiler/typecheck/TcBinds.hs)516
-rw-r--r--compiler/GHC/Tc/Gen/Default.hs (renamed from compiler/typecheck/TcDefaults.hs)44
-rw-r--r--compiler/GHC/Tc/Gen/Export.hs (renamed from compiler/typecheck/TcRnExports.hs)184
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs (renamed from compiler/typecheck/TcExpr.hs)1675
-rw-r--r--compiler/GHC/Tc/Gen/Expr.hs-boot46
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs (renamed from compiler/typecheck/TcForeign.hs)214
-rw-r--r--compiler/GHC/Tc/Gen/HsType.hs3895
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs (renamed from compiler/typecheck/TcMatches.hs)567
-rw-r--r--compiler/GHC/Tc/Gen/Match.hs-boot17
-rw-r--r--compiler/GHC/Tc/Gen/Pat.hs (renamed from compiler/typecheck/TcPat.hs)796
-rw-r--r--compiler/GHC/Tc/Gen/Rule.hs (renamed from compiler/typecheck/TcRules.hs)171
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs (renamed from compiler/typecheck/TcSigs.hs)231
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs (renamed from compiler/typecheck/TcSplice.hs)726
-rw-r--r--compiler/GHC/Tc/Gen/Splice.hs-boot46
-rw-r--r--compiler/GHC/Tc/Instance/Class.hs (renamed from compiler/typecheck/ClsInst.hs)151
-rw-r--r--compiler/GHC/Tc/Instance/Family.hs (renamed from compiler/typecheck/FamInst.hs)577
-rw-r--r--compiler/GHC/Tc/Instance/FunDeps.hs (renamed from compiler/typecheck/FunDeps.hs)87
-rw-r--r--compiler/GHC/Tc/Instance/Typeable.hs (renamed from compiler/typecheck/TcTypeable.hs)200
-rw-r--r--compiler/GHC/Tc/Module.hs (renamed from compiler/typecheck/TcRnDriver.hs)760
-rw-r--r--compiler/GHC/Tc/Module.hs-boot12
-rw-r--r--compiler/GHC/Tc/Plugin.hs (renamed from compiler/typecheck/TcPluginM.hs)82
-rw-r--r--compiler/GHC/Tc/Solver.hs (renamed from compiler/typecheck/TcSimplify.hs)681
-rw-r--r--compiler/GHC/Tc/Solver/Canonical.hs (renamed from compiler/typecheck/TcCanonical.hs)912
-rw-r--r--compiler/GHC/Tc/Solver/Flatten.hs (renamed from compiler/typecheck/TcFlatten.hs)228
-rw-r--r--compiler/GHC/Tc/Solver/Interact.hs (renamed from compiler/typecheck/TcInteract.hs)408
-rw-r--r--compiler/GHC/Tc/Solver/Monad.hs (renamed from compiler/typecheck/TcSMonad.hs)698
-rw-r--r--compiler/GHC/Tc/TyCl.hs (renamed from compiler/typecheck/TcTyClsDecls.hs)2770
-rw-r--r--compiler/GHC/Tc/TyCl/Build.hs (renamed from compiler/iface/BuildTyCl.hs)114
-rw-r--r--compiler/GHC/Tc/TyCl/Class.hs (renamed from compiler/typecheck/TcClassDcl.hs)135
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs (renamed from compiler/typecheck/TcInstDcls.hs)481
-rw-r--r--compiler/GHC/Tc/TyCl/Instance.hs-boot (renamed from compiler/typecheck/TcInstDcls.hs-boot)12
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs (renamed from compiler/typecheck/TcPatSyn.hs)418
-rw-r--r--compiler/GHC/Tc/TyCl/PatSyn.hs-boot (renamed from compiler/typecheck/TcPatSyn.hs-boot)12
-rw-r--r--compiler/GHC/Tc/TyCl/Utils.hs (renamed from compiler/typecheck/TcTyDecls.hs)275
-rw-r--r--compiler/GHC/Tc/Types/EvTerm.hs (renamed from compiler/typecheck/TcEvTerm.hs)49
-rw-r--r--compiler/GHC/Tc/Utils/Backpack.hs (renamed from compiler/typecheck/TcBackpack.hs)259
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs (renamed from compiler/typecheck/TcEnv.hs)297
-rw-r--r--compiler/GHC/Tc/Utils/Env.hs-boot10
-rw-r--r--compiler/GHC/Tc/Utils/Instantiate.hs (renamed from compiler/typecheck/Inst.hs)709
-rw-r--r--compiler/GHC/Tc/Utils/Monad.hs (renamed from compiler/typecheck/TcRnMonad.hs)607
-rw-r--r--compiler/GHC/Tc/Utils/TcMType.hs (renamed from compiler/typecheck/TcMType.hs)1599
-rw-r--r--compiler/GHC/Tc/Utils/Unify.hs (renamed from compiler/typecheck/TcUnify.hs)1557
-rw-r--r--compiler/GHC/Tc/Utils/Unify.hs-boot18
-rw-r--r--compiler/GHC/Tc/Utils/Zonk.hs (renamed from compiler/typecheck/TcHsSyn.hs)711
-rw-r--r--compiler/GHC/Tc/Validity.hs (renamed from compiler/typecheck/TcValidity.hs)779
-rw-r--r--compiler/GHC/ThToHs.hs (renamed from compiler/hsSyn/Convert.hs)979
-rw-r--r--compiler/GHC/Types/Name/Shape.hs (renamed from compiler/backpack/NameShape.hs)49
-rw-r--r--compiler/GHC/Utils/Asm.hs (renamed from compiler/utils/AsmUtils.hs)17
-rw-r--r--compiler/GHC/Utils/Monad/State.hs (renamed from compiler/utils/State.hs)10
-rw-r--r--compiler/GhclibHsVersions.h23
-rw-r--r--compiler/cmm/BlockId.hs46
-rw-r--r--compiler/cmm/BlockId.hs-boot8
-rw-r--r--compiler/cmm/CLabel.hs1436
-rw-r--r--compiler/cmm/Cmm.hs230
-rw-r--r--compiler/cmm/CmmBuildInfoTables.hs896
-rw-r--r--compiler/cmm/CmmExpr.hs604
-rw-r--r--compiler/cmm/CmmImplementSwitchPlans.hs92
-rw-r--r--compiler/cmm/CmmMachOp.hs658
-rw-r--r--compiler/cmm/CmmNode.hs724
-rw-r--r--compiler/cmm/CmmSwitch.hs500
-rw-r--r--compiler/cmm/Hoopl/Block.hs328
-rw-r--r--compiler/cmm/Hoopl/Collections.hs177
-rw-r--r--compiler/cmm/Hoopl/Graph.hs185
-rw-r--r--compiler/cmm/Hoopl/Label.hs142
-rw-r--r--compiler/cmm/SMRep.hs574
-rw-r--r--compiler/codeGen/CgUtils.hs182
-rw-r--r--compiler/codeGen/CodeGen/Platform.hs107
-rw-r--r--compiler/codeGen/CodeGen/Platform/ARM.hs10
-rw-r--r--compiler/codeGen/CodeGen/Platform/ARM64.hs10
-rw-r--r--compiler/codeGen/CodeGen/Platform/NoRegs.hs9
-rw-r--r--compiler/codeGen/CodeGen/Platform/PPC.hs10
-rw-r--r--compiler/codeGen/CodeGen/Platform/SPARC.hs10
-rw-r--r--compiler/codeGen/CodeGen/Platform/X86.hs10
-rw-r--r--compiler/codeGen/CodeGen/Platform/X86_64.hs10
-rw-r--r--compiler/codeGen/StgCmmBind.hs-boot6
-rw-r--r--compiler/codeGen/StgCmmCon.hs285
-rw-r--r--compiler/codeGen/StgCmmForeign.hs534
-rw-r--r--compiler/codeGen/StgCmmPrim.hs2545
-rw-r--r--compiler/coreSyn/CoreLint.hs2758
-rw-r--r--compiler/deSugar/Check.hs2711
-rw-r--r--compiler/deSugar/DsExpr.hs-boot10
-rw-r--r--compiler/deSugar/Match.hs-boot37
-rw-r--r--compiler/deSugar/TmOracle.hs263
-rw-r--r--compiler/hieFile/HieDebug.hs146
-rw-r--r--compiler/iface/IfaceEnv.hs-boot9
-rw-r--r--compiler/iface/LoadIface.hs-boot7
-rw-r--r--compiler/iface/TcIface.hs-boot19
-rw-r--r--compiler/llvmGen/Llvm/PpLlvm.hs499
-rw-r--r--compiler/main/GhcPlugins.hs132
-rw-r--r--compiler/nativeGen/BlockLayout.hs821
-rw-r--r--compiler/nativeGen/CFG.hs686
-rw-r--r--compiler/nativeGen/NCG.h11
-rw-r--r--compiler/nativeGen/PPC/Ppr.hs990
-rw-r--r--compiler/nativeGen/Reg.hs241
-rw-r--r--compiler/nativeGen/RegClass.hs35
-rw-r--r--compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot16
-rw-r--r--compiler/nativeGen/SPARC/Cond.hs54
-rw-r--r--compiler/nativeGen/X86/Ppr.hs1368
-rw-r--r--compiler/nativeGen/X86/RegInfo.hs69
-rw-r--r--compiler/profiling/ProfInit.hs64
-rw-r--r--compiler/simplStg/StgLiftLams.hs102
-rw-r--r--compiler/stgSyn/StgSyn.hs879
-rw-r--r--compiler/typecheck/TcEnv.hs-boot10
-rw-r--r--compiler/typecheck/TcExpr.hs-boot41
-rw-r--r--compiler/typecheck/TcHoleErrors.hs-boot12
-rw-r--r--compiler/typecheck/TcHsType.hs2901
-rw-r--r--compiler/typecheck/TcMatches.hs-boot17
-rw-r--r--compiler/typecheck/TcRnDriver.hs-boot13
-rw-r--r--compiler/typecheck/TcSplice.hs-boot46
-rw-r--r--compiler/typecheck/TcTypeableValidity.hs46
-rw-r--r--compiler/typecheck/TcUnify.hs-boot15
-rw-r--r--compiler/utils/ListT.hs80
-rw-r--r--compiler/utils/Stream.hs106
-rw-r--r--compiler/utils/UniqMap.hs206
-rw-r--r--compiler/utils/md5.h18
-rw-r--r--ghc-lib.cabal1014
-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/Fingerprint.hs48
-rw-r--r--ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs135
-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/Platform/Host.hs12
-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/GHC/Settings/Utils.hs72
-rw-r--r--libraries/ghci/GHCi/CreateBCO.hs7
-rw-r--r--libraries/ghci/GHCi/InfoTable.hsc170
-rw-r--r--libraries/ghci/GHCi/ResolvedBCO.hs4
-rw-r--r--libraries/ghci/GHCi/Run.hs48
-rw-r--r--libraries/ghci/GHCi/TH.hs22
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/CodeDo.hs20
-rw-r--r--libraries/template-haskell/Language/Haskell/TH/Quote.hs2
415 files changed, 69034 insertions, 63149 deletions
diff --git a/compiler/main/GHC.hs b/compiler/GHC.hs
index 1469ca7..60f59b4 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/GHC.hs
@@ -22,18 +22,18 @@ module GHC (
-- * GHC Monad
Ghc, GhcT, GhcMonad(..), HscEnv,
runGhc, runGhcT, initGhcMonad,
- gcatch, gbracket, gfinally,
printException,
handleSourceError,
needsTemplateHaskellOrQQ,
-- * Flags and settings
- DynFlags(..), GeneralFlag(..), Severity(..), HscTarget(..), gopt,
- GhcMode(..), GhcLink(..), defaultObjectTarget,
+ DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,
+ GhcMode(..), GhcLink(..),
parseDynamicFlags,
getSessionDynFlags, setSessionDynFlags,
getProgramDynFlags, setProgramDynFlags, setLogAction,
getInteractiveDynFlags, setInteractiveDynFlags,
+ interpretPackageEnv,
-- * Targets
Target(..), TargetId(..), Phase,
@@ -44,7 +44,7 @@ module GHC (
guessTarget,
-- * Loading\/compiling the program
- depanal,
+ depanal, depanalE,
load, LoadHowMuch(..), InteractiveImport(..),
SuccessFlag(..), succeeded, failed,
defaultWarnErrLogger, WarnErrLogger,
@@ -85,7 +85,7 @@ module GHC (
lookupGlobalName,
findGlobalAnns,
mkPrintUnqualifiedForModule,
- ModIface(..),
+ ModIface, ModIface_(..),
SafeHaskellMode(..),
-- * Querying the environment
@@ -131,7 +131,7 @@ module GHC (
-- ** Compiling expressions
HValue, parseExpr, compileParsedExpr,
- InteractiveEval.compileExpr, dynCompileExpr,
+ GHC.Runtime.Eval.compileExpr, dynCompileExpr,
ForeignHValue,
compileExprRemote, compileParsedExprRemote,
@@ -139,7 +139,7 @@ module GHC (
getDocs, GetDocsFailure(..),
-- ** Other
- runTcInteractive, -- Desired by some clients (Trac #8878)
+ runTcInteractive, -- Desired by some clients (#8878)
isStmt, hasImport, isImport, isDecl,
-- ** The debugger
@@ -153,16 +153,16 @@ module GHC (
modInfoModBreaks,
ModBreaks(..), BreakIndex,
BreakInfo(breakInfo_number, breakInfo_module),
- InteractiveEval.back,
- InteractiveEval.forward,
+ GHC.Runtime.Eval.back,
+ GHC.Runtime.Eval.forward,
-- * Abstract syntax elements
- -- ** Packages
- UnitId,
+ -- ** Units
+ Unit,
-- ** Modules
- Module, mkModule, pprModule, moduleName, moduleUnitId,
+ Module, mkModule, pprModule, moduleName, moduleUnit,
ModuleName, mkModuleName, moduleNameString,
-- ** Names
@@ -178,7 +178,7 @@ module GHC (
isRecordSelector,
isPrimOpId, isFCallId, isClassOpId_maybe,
isDataConWorkId, idDataCon,
- isBottomingId, isDictonaryId,
+ isDeadEndId, isDictonaryId,
recordSelectorTyCon,
-- ** Type constructors
@@ -196,8 +196,8 @@ module GHC (
-- ** Data constructors
DataCon,
- dataConSig, dataConType, dataConTyCon, dataConFieldLabels,
- dataConIsInfix, isVanillaDataCon, dataConUserType,
+ dataConType, dataConTyCon, dataConFieldLabels,
+ dataConIsInfix, isVanillaDataCon, dataConWrapperType,
dataConSrcBangs,
StrictnessMark(..), isMarkedStrict,
@@ -220,12 +220,14 @@ module GHC (
Kind,
PredType,
ThetaType, pprForAll, pprThetaArrowTy,
+ parseInstanceHead,
+ getInstancesForType,
-- ** Entities
TyThing(..),
-- ** Syntax
- module HsSyn, -- ToDo: remove extraneous bits
+ module GHC.Hs, -- ToDo: remove extraneous bits
-- ** Fixities
FixityDirection(..),
@@ -255,12 +257,9 @@ module GHC (
getLoc, unLoc,
getRealSrcSpan, unRealSrcSpan,
- -- ** HasSrcSpan
- HasSrcSpan(..), SrcSpanLess, dL, cL,
-
-- *** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
- leftmost_smallest, leftmost_largest, rightmost,
+ leftmost_smallest, leftmost_largest, rightmost_smallest,
spans, isSubspanOf,
-- * Exceptions
@@ -275,7 +274,7 @@ module GHC (
parser,
-- * API Annotations
- ApiAnns,AnnKeywordId(..),AnnotationComment(..),
+ ApiAnns(..),AnnKeywordId(..),AnnotationComment(..),
getAnnotation, getAndRemoveAnnotation,
getAnnotationComments, getAndRemoveAnnotationComments,
unicodeAnn,
@@ -288,91 +287,103 @@ module GHC (
{-
ToDo:
- * inline bits of HscMain here to simplify layering: hscTcExpr, hscStmt.
+ * inline bits of GHC.Driver.Main here to simplify layering: hscTcExpr, hscStmt.
-}
#include "GhclibHsVersions.h"
-import GhcPrelude hiding (init)
+import GHC.Prelude hiding (init)
-import ByteCodeTypes
-import InteractiveEval
-import InteractiveEvalTypes
-import GHCi
+import GHC.ByteCode.Types
+import GHC.Runtime.Eval
+import GHC.Runtime.Eval.Types
+import GHC.Runtime.Interpreter
+import GHC.Runtime.Interpreter.Types
import GHCi.RemoteTypes
-import PprTyThing ( pprFamInst )
-import HscMain
-import GhcMake
-import DriverPipeline ( compileOne' )
-import GhcMonad
-import TcRnMonad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
-import LoadIface ( loadSysInterface )
-import TcRnTypes
-import Packages
-import NameSet
-import RdrName
-import HsSyn
-import Type hiding( typeKind )
-import TcType hiding( typeKind )
-import Id
-import TysPrim ( alphaTyVars )
-import TyCon
-import Class
-import DataCon
-import Name hiding ( varName )
-import Avail
-import InstEnv
-import FamInstEnv ( FamInst )
-import SrcLoc
-import CoreSyn
-import TidyPgm
-import DriverPhases ( Phase(..), isHaskellSrcFilename )
-import Finder
-import HscTypes
-import CmdLineParser
-import DynFlags hiding (WarnReason(..))
-import SysTools
-import SysTools.BaseDir
-import Annotations
-import Module
-import Panic
-import Platform
-import Bag ( listToBag, unitBag )
-import ErrUtils
-import MonadUtils
-import Util
-import StringBuffer
-import Outputable
-import BasicTypes
-import Maybes ( expectJust )
-import FastString
-import qualified Parser
-import Lexer
-import ApiAnnotation
+import GHC.Core.Ppr.TyThing ( pprFamInst )
+import GHC.Driver.Backend
+import GHC.Driver.Main
+import GHC.Driver.Make
+import GHC.Driver.Hooks
+import GHC.Driver.Pipeline ( compileOne' )
+import GHC.Driver.Monad
+import GHC.Tc.Utils.Monad ( finalSafeMode, fixSafeInstances, initIfaceTcRn )
+import GHC.Iface.Load ( loadSysInterface )
+import GHC.Tc.Types
+import GHC.Core.Predicate
+import GHC.Unit.State
+import GHC.Types.Name.Set
+import GHC.Types.Name.Reader
+import GHC.Hs
+import GHC.Core.Type hiding( typeKind )
+import GHC.Tc.Utils.TcType
+import GHC.Types.Id
+import GHC.Builtin.Types.Prim ( alphaTyVars )
+import GHC.Core.TyCon
+import GHC.Core.TyCo.Ppr ( pprForAll )
+import GHC.Core.Class
+import GHC.Core.DataCon
+import GHC.Core.FVs ( orphNamesOfFamInst )
+import GHC.Core.FamInstEnv ( FamInst, famInstEnvElts )
+import GHC.Core.InstEnv
+import GHC.Types.Name hiding ( varName )
+import GHC.Types.Avail
+import GHC.Types.SrcLoc
+import GHC.Core
+import GHC.Iface.Tidy
+import GHC.Driver.Phases ( Phase(..), isHaskellSrcFilename )
+import GHC.Driver.Finder
+import GHC.Driver.Types
+import GHC.Driver.CmdLine
+import GHC.Driver.Session hiding (WarnReason(..))
+import GHC.Platform.Ways
+import GHC.SysTools
+import GHC.SysTools.BaseDir
+import GHC.Types.Annotations
+import GHC.Unit.Module
+import GHC.Utils.Panic
+import GHC.Platform
+import GHC.Data.Bag ( listToBag )
+import GHC.Utils.Error
+import GHC.Utils.Monad
+import GHC.Utils.Misc
+import GHC.Data.StringBuffer
+import GHC.Utils.Outputable
+import GHC.Types.Basic
+import GHC.Data.FastString
+import qualified GHC.Parser as Parser
+import GHC.Parser.Lexer
+import GHC.Parser.Annotation
import qualified GHC.LanguageExtensions as LangExt
-import NameEnv
-import CoreFVs ( orphNamesOfFamInst )
-import FamInstEnv ( famInstEnvElts )
-import TcRnDriver
-import Inst
-import FamInst
-import FileCleanup
+import GHC.Types.Name.Env
+import GHC.Tc.Module
+import GHC.Tc.Utils.Instantiate
+import GHC.Tc.Instance.Family
+import GHC.SysTools.FileCleanup
import Data.Foldable
import qualified Data.Map.Strict as Map
import Data.Set (Set)
+import qualified Data.Set as S
import qualified Data.Sequence as Seq
-import System.Directory ( doesFileExist )
import Data.Maybe
import Data.Time
import Data.Typeable ( Typeable )
import Data.Word ( Word8 )
import Control.Monad
import System.Exit ( exitWith, ExitCode(..) )
-import Exception
+import GHC.Utils.Exception
import Data.IORef
import System.FilePath
+import Control.Concurrent
+import Control.Applicative ((<|>))
+import Control.Monad.Catch as MC
+
+import GHC.Data.Maybe
+import System.IO.Error ( isDoesNotExistError )
+import System.Environment ( getEnv )
+import System.Directory
-- %************************************************************************
@@ -390,7 +401,7 @@ defaultErrorHandler :: (ExceptionMonad m)
=> FatalMessager -> FlushOut -> m a -> m a
defaultErrorHandler fm (FlushOut flushOut) inner =
-- top-level exception handler: any unrecognised exception is a compiler bug.
- ghandle (\exception -> liftIO $ do
+ MC.handle (\exception -> liftIO $ do
flushOut
case fromException exception of
-- an IO exception probably isn't our fault, so don't panic
@@ -427,7 +438,7 @@ defaultErrorHandler fm (FlushOut flushOut) inner =
{-# DEPRECATED defaultCleanupHandler "Cleanup is now done by runGhc/runGhcT" #-}
defaultCleanupHandler :: (ExceptionMonad m) => DynFlags -> m a -> m a
defaultCleanupHandler _ m = m
- where _warning_suppression = m `gonException` undefined
+ where _warning_suppression = m `MC.onException` undefined
-- %************************************************************************
@@ -473,7 +484,7 @@ runGhcT mb_top_dir ghct = do
withCleanupSession ghct
withCleanupSession :: GhcMonad m => m a -> m a
-withCleanupSession ghc = ghc `gfinally` cleanup
+withCleanupSession ghc = ghc `MC.finally` cleanup
where
cleanup = do
hsc_env <- getSession
@@ -481,7 +492,7 @@ withCleanupSession ghc = ghc `gfinally` cleanup
liftIO $ do
cleanTempFiles dflags
cleanTempDirs dflags
- stopIServ hsc_env -- shut down the IServ
+ stopInterp hsc_env -- shut down the IServ
-- exceptions will be blocked while we clean the temporary files,
-- so there shouldn't be any difficulty if we receive further
-- signals.
@@ -503,7 +514,7 @@ initGhcMonad mb_top_dir
= do { env <- liftIO $
do { top_dir <- findTopDir mb_top_dir
; mySettings <- initSysTools top_dir
- ; myLlvmConfig <- initLlvmConfig top_dir
+ ; myLlvmConfig <- lazyInitLlvmConfig top_dir
; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)
; checkBrokenTablesNextToCode dflags
; setUnsafeGlobalDynFlags dflags
@@ -517,7 +528,7 @@ initGhcMonad mb_top_dir
-- check should be more selective but there is currently no released
-- version where this bug is fixed.
-- See https://sourceware.org/bugzilla/show_bug.cgi?id=16177 and
--- https://ghc.haskell.org/trac/ghc/ticket/4210#comment:29
+-- https://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333
checkBrokenTablesNextToCode :: MonadIO m => DynFlags -> m ()
checkBrokenTablesNextToCode dflags
= do { broken <- checkBrokenTablesNextToCode' dflags
@@ -533,16 +544,17 @@ checkBrokenTablesNextToCode dflags
checkBrokenTablesNextToCode' :: MonadIO m => DynFlags -> m Bool
checkBrokenTablesNextToCode' dflags
- | not (isARM arch) = return False
- | WayDyn `notElem` ways dflags = return False
- | not (tablesNextToCode dflags) = return False
- | otherwise = do
+ | not (isARM arch) = return False
+ | WayDyn `S.notMember` ways dflags = return False
+ | not tablesNextToCode = return False
+ | otherwise = do
linkerInfo <- liftIO $ getLinkerInfo dflags
case linkerInfo of
GnuLD _ -> return True
_ -> return False
where platform = targetPlatform dflags
arch = platformArch platform
+ tablesNextToCode = platformTablesNextToCode platform
-- %************************************************************************
@@ -584,19 +596,59 @@ checkBrokenTablesNextToCode' dflags
-- flags. If you are not doing linking or doing static linking, you
-- can ignore the list of packages returned.
--
-setSessionDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
+setSessionDynFlags :: GhcMonad m => DynFlags -> m ()
setSessionDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
- (dflags'', preload) <- liftIO $ initPackages dflags'
- modifySession $ \h -> h{ hsc_dflags = dflags''
- , hsc_IC = (hsc_IC h){ ic_dflags = dflags'' } }
+ dflags''' <- liftIO $ initUnits dflags'
+
+ -- Interpreter
+ interp <- if gopt Opt_ExternalInterpreter dflags
+ then do
+ let
+ prog = pgm_i dflags ++ flavour
+ profiled = ways dflags `hasWay` WayProf
+ dynamic = ways dflags `hasWay` WayDyn
+ flavour
+ | profiled = "-prof" -- FIXME: can't we have both?
+ | dynamic = "-dyn"
+ | otherwise = ""
+ msg = text "Starting " <> text prog
+ tr <- if verbosity dflags >= 3
+ then return (logInfo dflags $ withPprStyle defaultDumpStyle msg)
+ else return (pure ())
+ let
+ conf = IServConfig
+ { iservConfProgram = prog
+ , iservConfOpts = getOpts dflags opt_i
+ , iservConfProfiled = profiled
+ , iservConfDynamic = dynamic
+ , iservConfHook = createIservProcessHook (hooks dflags)
+ , iservConfTrace = tr
+ }
+ s <- liftIO $ newMVar IServPending
+ return (Just (ExternalInterp conf (IServ s)))
+ else
+#if defined(HAVE_INTERNAL_INTERPRETER)
+ return (Just InternalInterp)
+#else
+ return Nothing
+#endif
+
+ modifySession $ \h -> h{ hsc_dflags = dflags'''
+ , hsc_IC = (hsc_IC h){ ic_dflags = dflags''' }
+ , hsc_interp = hsc_interp h <|> interp
+ -- we only update the interpreter if there wasn't
+ -- already one set up
+ }
invalidateModSummaryCache
- return preload
-- | Sets the program 'DynFlags'. Note: this invalidates the internal
-- cached module graph, causing more work to be done the next time
-- 'load' is called.
-setProgramDynFlags :: GhcMonad m => DynFlags -> m [InstalledUnitId]
+--
+-- Returns a boolean indicating if preload units have changed and need to be
+-- reloaded.
+setProgramDynFlags :: GhcMonad m => DynFlags -> m Bool
setProgramDynFlags dflags = setProgramDynFlags_ True dflags
-- | Set the action taken when the compiler produces a message. This
@@ -608,17 +660,17 @@ setLogAction action = do
void $ setProgramDynFlags_ False $
dflags' { log_action = action }
-setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m [InstalledUnitId]
+setProgramDynFlags_ :: GhcMonad m => Bool -> DynFlags -> m Bool
setProgramDynFlags_ invalidate_needed dflags = do
dflags' <- checkNewDynFlags dflags
dflags_prev <- getProgramDynFlags
- (dflags'', preload) <-
- if (packageFlagsChanged dflags_prev dflags')
- then liftIO $ initPackages dflags'
- else return (dflags', [])
+ let changed = packageFlagsChanged dflags_prev dflags'
+ dflags'' <- if changed
+ then liftIO $ initUnits dflags'
+ else return dflags'
modifySession $ \h -> h{ hsc_dflags = dflags'' }
when invalidate_needed $ invalidateModSummaryCache
- return preload
+ return changed
-- When changing the DynFlags, we want the changes to apply to future
@@ -637,7 +689,7 @@ setProgramDynFlags_ invalidate_needed dflags = do
-- that the next downsweep will think that all the files have changed
-- and preprocess them again. This won't necessarily cause everything
-- to be recompiled, because by the time we check whether we need to
--- recopmile a module, we'll have re-summarised the module and have a
+-- recompile a module, we'll have re-summarised the module and have a
-- correct ModSummary.
--
invalidateModSummaryCache :: GhcMonad m => m ()
@@ -653,7 +705,7 @@ getProgramDynFlags = getSessionDynFlags
-- | Set the 'DynFlags' used to evaluate interactive expressions.
-- Note: this cannot be used for changes to packages. Use
-- 'setSessionDynFlags', or 'setProgramDynFlags' and then copy the
--- 'pkgState' into the interactive @DynFlags@.
+-- 'unitState' into the interactive @DynFlags@.
setInteractiveDynFlags :: GhcMonad m => DynFlags -> m ()
setInteractiveDynFlags dflags = do
dflags' <- checkNewDynFlags dflags
@@ -668,7 +720,11 @@ getInteractiveDynFlags = withSession $ \h -> return (ic_dflags (hsc_IC h))
parseDynamicFlags :: MonadIO m =>
DynFlags -> [Located String]
-> m (DynFlags, [Located String], [Warn])
-parseDynamicFlags = parseDynamicFlagsCmdLine
+parseDynamicFlags dflags cmdline = do
+ (dflags1, leftovers, warns) <- parseDynamicFlagsCmdLine dflags cmdline
+ dflags2 <- liftIO $ interpretPackageEnv dflags1
+ return (dflags2, leftovers, warns)
+
-- | Checks the set of new DynFlags for possibly erroneous option
-- combinations when invoking 'setSessionDynFlags' and friends, and if
@@ -684,14 +740,12 @@ checkNewInteractiveDynFlags :: MonadIO m => DynFlags -> m DynFlags
checkNewInteractiveDynFlags dflags0 = do
-- We currently don't support use of StaticPointers in expressions entered on
-- the REPL. See #12356.
- dflags1 <-
- if xopt LangExt.StaticPointers dflags0
- then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
- [mkPlainWarnMsg dflags0 interactiveSrcSpan
- $ text "StaticPointers is not supported in GHCi interactive expressions."]
- return $ xopt_unset dflags0 LangExt.StaticPointers
- else return dflags0
- return dflags1
+ if xopt LangExt.StaticPointers dflags0
+ then do liftIO $ printOrThrowWarnings dflags0 $ listToBag
+ [mkPlainWarnMsg dflags0 interactiveSrcSpan
+ $ text "StaticPointers is not supported in GHCi interactive expressions."]
+ return $ xopt_unset dflags0 LangExt.StaticPointers
+ else return dflags0
-- %************************************************************************
@@ -812,7 +866,7 @@ data ParsedModule =
, pm_parsed_source :: ParsedSource
, pm_extra_src_files :: [FilePath]
, pm_annotations :: ApiAnns }
- -- See Note [Api annotations] in ApiAnnotation.hs
+ -- See Note [Api annotations] in GHC.Parser.Annotation
instance ParsedMod ParsedModule where
modSummary m = pm_mod_summary m
@@ -858,7 +912,7 @@ instance TypecheckedMod DesugaredModule where
instance DesugaredMod DesugaredModule where
coreModule m = dm_core_module m
-type ParsedSource = Located (HsModule GhcPs)
+type ParsedSource = Located HsModule
type RenamedSource = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
Maybe LHsDocString)
type TypecheckedSource = LHsBinds GhcTc
@@ -888,7 +942,7 @@ getModSummary mod = do
mg <- liftM hsc_mod_graph getSession
let mods_by_name = [ ms | ms <- mgModSummaries mg
, ms_mod_name ms == mod
- , not (isBootSummary ms) ]
+ , isBootSummary ms == NotBoot ]
case mods_by_name of
[] -> do dflags <- getDynFlags
liftIO $ throwIO $ mkApiErr dflags (text "Module not part of module graph")
@@ -906,7 +960,7 @@ parseModule ms = do
hpm <- liftIO $ hscParse hsc_env_tmp ms
return (ParsedModule ms (hpm_module hpm) (hpm_src_files hpm)
(hpm_annotations hpm))
- -- See Note [Api annotations] in ApiAnnotation.hs
+ -- See Note [Api annotations] in GHC.Parser.Annotation
-- | Typecheck and rename a parsed module.
--
@@ -959,7 +1013,7 @@ desugarModule tcm = do
--
-- A module must be loaded before dependent modules can be typechecked. This
-- always includes generating a 'ModIface' and, depending on the
--- 'DynFlags.hscTarget', may also include code generation.
+-- @DynFlags@\'s 'GHC.Driver.Session.backend', may also include code generation.
--
-- This function will always cause recompilation and will always overwrite
-- previous compilation results (potentially files on disk).
@@ -1094,7 +1148,7 @@ compileCore simplify fn = do
getModuleGraph :: GhcMonad m => m ModuleGraph -- ToDo: DiGraph ModSummary
getModuleGraph = liftM hsc_mod_graph getSession
--- | Return @True@ <==> module is loaded.
+-- | Return @True@ \<==> module is loaded.
isLoaded :: GhcMonad m => ModuleName -> m Bool
isLoaded m = withSession $ \hsc_env ->
return $! isJust (lookupHpt (hsc_HPT hsc_env) m)
@@ -1277,7 +1331,7 @@ getNameToInstancesIndex visible_mods mods_to_load = do
; (pkg_fie, home_fie) <- tcGetFamInstEnvs
-- We use Data.Sequence.Seq because we are creating left associated
-- mappends.
- -- cls_index and fam_index below are adapted from TcRnDriver.lookupInsts
+ -- cls_index and fam_index below are adapted from GHC.Tc.Module.lookupInsts
; let cls_index = Map.fromListWith mappend
[ (n, Seq.singleton ispec)
| ispec <- instEnvElts ie_local ++ instEnvElts ie_global
@@ -1298,7 +1352,7 @@ getNameToInstancesIndex visible_mods mods_to_load = do
-- -----------------------------------------------------------------------------
-{- ToDo: Move the primary logic here to compiler/main/Packages.hs
+{- ToDo: Move the primary logic here to "GHC.Unit.State"
-- | Return all /external/ modules available in the package database.
-- Modules from the current session (i.e., from the 'HomePackageTable') are
-- not included. This includes module names which are reexported by packages.
@@ -1307,12 +1361,12 @@ packageDbModules :: GhcMonad m =>
-> m [Module]
packageDbModules only_exposed = do
dflags <- getSessionDynFlags
- let pkgs = eltsUFM (pkgIdMap (pkgState dflags))
+ let pkgs = eltsUFM (unitInfoMap (unitState dflags))
return $
[ mkModule pid modname
| p <- pkgs
, not only_exposed || exposed p
- , let pid = packageConfigId p
+ , let pid = mkUnit p
, modname <- exposedModules p
++ map exportName (reexportedModules p) ]
-}
@@ -1336,7 +1390,7 @@ pprParenSymName a = parenSymOcc (getOccName a) (ppr (getName a))
-- ToDo: check for small transformations that happen to the syntax in
-- the typechecker (eg. -e ==> negate e, perhaps for fromIntegral)
--- ToDo: maybe use TH syntax instead of IfaceSyn? There's already a way
+-- ToDo: maybe use TH syntax instead of Iface syntax? There's already a way
-- to get from TyCons, Ids etc. to TH syntax (reify).
-- :browse will use either lm_toplev or inspect lm_interface, depending
@@ -1360,16 +1414,16 @@ getModuleSourceAndFlags mod = do
-- | Return module source as token stream, including comments.
--
-- The module must be in the module graph and its source must be available.
--- Throws a 'HscTypes.SourceError' on parse error.
+-- Throws a 'GHC.Driver.Types.SourceError' on parse error.
getTokenStream :: GhcMonad m => Module -> m [Located Token]
getTokenStream mod = do
(sourceFile, source, flags) <- getModuleSourceAndFlags mod
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return ts
- PFailed _ span err ->
+ PFailed pst ->
do dflags <- getDynFlags
- liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+ throwErrors (getErrorMessages pst dflags)
-- | Give even more information on the source than 'getTokenStream'
-- This function allows reconstructing the source completely with
@@ -1380,9 +1434,9 @@ getRichTokenStream mod = do
let startLoc = mkRealSrcLoc (mkFastString sourceFile) 1 1
case lexTokenStream source startLoc flags of
POk _ ts -> return $ addSourceToTokens startLoc source ts
- PFailed _ span err ->
+ PFailed pst ->
do dflags <- getDynFlags
- liftIO $ throwIO $ mkSrcErr (unitBag $ mkPlainErrMsg dflags span err)
+ throwErrors (getErrorMessages pst dflags)
-- | Given a source location and a StringBuffer corresponding to this
-- location, return a rich token stream with the source associated to the
@@ -1390,10 +1444,10 @@ getRichTokenStream mod = do
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens _ _ [] = []
-addSourceToTokens loc buf (t@(dL->L span _) : ts)
+addSourceToTokens loc buf (t@(L span _) : ts)
= case span of
UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
- RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
+ RealSrcSpan s _ -> (t,str) : addSourceToTokens newLoc newBuf ts
where
(newLoc, newBuf, str) = go "" loc buf
start = realSrcSpanStart s
@@ -1413,13 +1467,13 @@ showRichTokenStream ts = go startLoc ts ""
where sourceFile = getFile $ map (getLoc . fst) ts
getFile [] = panic "showRichTokenStream: No source file found"
getFile (UnhelpfulSpan _ : xs) = getFile xs
- getFile (RealSrcSpan s : _) = srcSpanFile s
+ getFile (RealSrcSpan s _ : _) = srcSpanFile s
startLoc = mkRealSrcLoc sourceFile 1 1
go _ [] = id
- go loc ((dL->L span _, str):ts)
+ go loc ((L span _, str):ts)
= case span of
UnhelpfulSpan _ -> go loc ts
- RealSrcSpan s
+ RealSrcSpan s _
| locLine == tokLine -> ((replicate (tokCol - locCol) ' ') ++)
. (str ++)
. go tokEnd ts
@@ -1441,10 +1495,10 @@ findModule :: GhcMonad m => ModuleName -> Maybe FastString -> m Module
findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
let
dflags = hsc_dflags hsc_env
- this_pkg = thisPackage dflags
+ this_pkg = homeUnit dflags
--
case maybe_pkg of
- Just pkg | fsToUnitId pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
+ Just pkg | fsToUnit pkg /= this_pkg && pkg /= fsLit "this" -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
Found _ m -> return m
@@ -1456,7 +1510,7 @@ findModule mod_name maybe_pkg = withSession $ \hsc_env -> do
Nothing -> liftIO $ do
res <- findImportedModule hsc_env mod_name maybe_pkg
case res of
- Found loc m | moduleUnitId m /= this_pkg -> return m
+ Found loc m | moduleUnit m /= this_pkg -> return m
| otherwise -> modNotLoadedError dflags m loc
err -> throwOneError $ noModError dflags noSrcSpan mod_name err
@@ -1500,7 +1554,7 @@ isModuleTrusted m = withSession $ \hsc_env ->
liftIO $ hscCheckSafe hsc_env m noSrcSpan
-- | Return if a module is trusted and the pkgs it depends on to be trusted.
-moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set InstalledUnitId)
+moduleTrustReqs :: GhcMonad m => Module -> m (Bool, Set UnitId)
moduleTrustReqs m = withSession $ \hsc_env ->
liftIO $ hscGetSafe hsc_env m noSrcSpan
@@ -1522,15 +1576,15 @@ getGHCiMonad = fmap (ic_monad . hsc_IC) getSession
getHistorySpan :: GhcMonad m => History -> m SrcSpan
getHistorySpan h = withSession $ \hsc_env ->
- return $ InteractiveEval.getHistorySpan hsc_env h
+ return $ GHC.Runtime.Eval.getHistorySpan hsc_env h
obtainTermFromVal :: GhcMonad m => Int -> Bool -> Type -> a -> m Term
obtainTermFromVal bound force ty a = withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTermFromVal hsc_env bound force ty a
+ liftIO $ GHC.Runtime.Eval.obtainTermFromVal hsc_env bound force ty a
obtainTermFromId :: GhcMonad m => Int -> Bool -> Id -> m Term
obtainTermFromId bound force id = withSession $ \hsc_env ->
- liftIO $ InteractiveEval.obtainTermFromId hsc_env bound force id
+ liftIO $ GHC.Runtime.Eval.obtainTermFromId hsc_env bound force id
-- | Returns the 'TyThing' for a 'Name'. The 'Name' may refer to any
@@ -1548,7 +1602,7 @@ lookupName name =
parser :: String -- ^ Haskell module source text (full Unicode is supported)
-> DynFlags -- ^ the flags
-> FilePath -- ^ the filename (for source locations)
- -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))
+ -> (WarningMessages, Either ErrorMessages (Located HsModule))
parser str dflags filename =
let
@@ -1557,10 +1611,147 @@ parser str dflags filename =
in
case unP Parser.parseModule (mkPState dflags buf loc) of
- PFailed warnFn span err ->
- let (warns,_) = warnFn dflags in
- (warns, Left $ unitBag (mkPlainErrMsg dflags span err))
+ PFailed pst ->
+ let (warns,errs) = getMessages pst dflags in
+ (warns, Left errs)
POk pst rdr_module ->
let (warns,_) = getMessages pst dflags in
(warns, Right rdr_module)
+
+-- -----------------------------------------------------------------------------
+-- | Find the package environment (if one exists)
+--
+-- We interpret the package environment as a set of package flags; to be
+-- specific, if we find a package environment file like
+--
+-- > clear-package-db
+-- > global-package-db
+-- > package-db blah/package.conf.d
+-- > package-id id1
+-- > package-id id2
+--
+-- we interpret this as
+--
+-- > [ -hide-all-packages
+-- > , -clear-package-db
+-- > , -global-package-db
+-- > , -package-db blah/package.conf.d
+-- > , -package-id id1
+-- > , -package-id id2
+-- > ]
+--
+-- There's also an older syntax alias for package-id, which is just an
+-- unadorned package id
+--
+-- > id1
+-- > id2
+--
+interpretPackageEnv :: DynFlags -> IO DynFlags
+interpretPackageEnv dflags = do
+ mPkgEnv <- runMaybeT $ msum $ [
+ getCmdLineArg >>= \env -> msum [
+ probeNullEnv env
+ , probeEnvFile env
+ , probeEnvName env
+ , cmdLineError env
+ ]
+ , getEnvVar >>= \env -> msum [
+ probeNullEnv env
+ , probeEnvFile env
+ , probeEnvName env
+ , envError env
+ ]
+ , notIfHideAllPackages >> msum [
+ findLocalEnvFile >>= probeEnvFile
+ , probeEnvName defaultEnvName
+ ]
+ ]
+ case mPkgEnv of
+ Nothing ->
+ -- No environment found. Leave DynFlags unchanged.
+ return dflags
+ Just "-" -> do
+ -- Explicitly disabled environment file. Leave DynFlags unchanged.
+ return dflags
+ Just envfile -> do
+ content <- readFile envfile
+ compilationProgressMsg dflags ("Loaded package environment from " ++ envfile)
+ let (_, dflags') = runCmdLine (runEwM (setFlagsFromEnvFile envfile content)) dflags
+
+ return dflags'
+ where
+ -- Loading environments (by name or by location)
+
+ archOS = platformArchOS (targetPlatform dflags)
+
+ namedEnvPath :: String -> MaybeT IO FilePath
+ namedEnvPath name = do
+ appdir <- versionedAppDir (programName dflags) archOS
+ return $ appdir </> "environments" </> name
+
+ probeEnvName :: String -> MaybeT IO FilePath
+ probeEnvName name = probeEnvFile =<< namedEnvPath name
+
+ probeEnvFile :: FilePath -> MaybeT IO FilePath
+ probeEnvFile path = do
+ guard =<< liftMaybeT (doesFileExist path)
+ return path
+
+ probeNullEnv :: FilePath -> MaybeT IO FilePath
+ probeNullEnv "-" = return "-"
+ probeNullEnv _ = mzero
+
+ -- Various ways to define which environment to use
+
+ getCmdLineArg :: MaybeT IO String
+ getCmdLineArg = MaybeT $ return $ packageEnv dflags
+
+ getEnvVar :: MaybeT IO String
+ getEnvVar = do
+ mvar <- liftMaybeT $ MC.try $ getEnv "GHC_ENVIRONMENT"
+ case mvar of
+ Right var -> return var
+ Left err -> if isDoesNotExistError err then mzero
+ else liftMaybeT $ throwIO err
+
+ notIfHideAllPackages :: MaybeT IO ()
+ notIfHideAllPackages =
+ guard (not (gopt Opt_HideAllPackages dflags))
+
+ defaultEnvName :: String
+ defaultEnvName = "default"
+
+ -- e.g. .ghc.environment.x86_64-linux-7.6.3
+ localEnvFileName :: FilePath
+ localEnvFileName = ".ghc.environment" <.> versionedFilePath archOS
+
+ -- Search for an env file, starting in the current dir and looking upwards.
+ -- Fail if we get to the users home dir or the filesystem root. That is,
+ -- we don't look for an env file in the user's home dir. The user-wide
+ -- env lives in ghc's versionedAppDir/environments/default
+ findLocalEnvFile :: MaybeT IO FilePath
+ findLocalEnvFile = do
+ curdir <- liftMaybeT getCurrentDirectory
+ homedir <- tryMaybeT getHomeDirectory
+ let probe dir | isDrive dir || dir == homedir
+ = mzero
+ probe dir = do
+ let file = dir </> localEnvFileName
+ exists <- liftMaybeT (doesFileExist file)
+ if exists
+ then return file
+ else probe (takeDirectory dir)
+ probe curdir
+
+ -- Error reporting
+
+ cmdLineError :: String -> MaybeT IO a
+ cmdLineError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
+ "Package environment " ++ show env ++ " not found"
+
+ envError :: String -> MaybeT IO a
+ envError env = liftMaybeT . throwGhcExceptionIO . CmdLineError $
+ "Package environment "
+ ++ show env
+ ++ " (specified in GHC_ENVIRONMENT) not found"
diff --git a/compiler/prelude/THNames.hs b/compiler/GHC/Builtin/Names/TH.hs
index 40ef6a4..1903a7d 100644
--- a/compiler/prelude/THNames.hs
+++ b/compiler/GHC/Builtin/Names/TH.hs
@@ -4,17 +4,17 @@
-- %* *
-- %************************************************************************
-module THNames where
+module GHC.Builtin.Names.TH where
-import GhcPrelude ()
+import GHC.Prelude ()
-import PrelNames( mk_known_key_name )
-import Module( Module, mkModuleNameFS, mkModule, thUnitId )
-import Name( Name )
-import OccName( tcName, clsName, dataName, varName )
-import RdrName( RdrName, nameRdrName )
-import Unique
-import FastString
+import GHC.Builtin.Names( mk_known_key_name )
+import GHC.Unit
+import GHC.Types.Name( Name )
+import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName )
+import GHC.Types.Name.Reader( RdrName, nameRdrName )
+import GHC.Types.Unique
+import GHC.Data.FastString
-- To add a name, do three things
--
@@ -24,16 +24,16 @@ import FastString
templateHaskellNames :: [Name]
-- The names that are implicitly mentioned by ``bracket''
--- Should stay in sync with the import list of DsMeta
+-- Should stay in sync with the import list of GHC.HsToCore.Quote
templateHaskellNames = [
- returnQName, bindQName, sequenceQName, newNameName, liftName,
+ returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,
mkNameSName,
+ mkModNameName,
liftStringName,
- unTypeName,
- unTypeQName,
- unsafeTExpCoerceName,
+ unTypeName, unTypeCodeName,
+ unsafeCodeCoerceName,
-- Lit
charLName, stringLName, integerLName, intPrimLName, wordPrimLName,
@@ -68,7 +68,7 @@ templateHaskellNames = [
-- Dec
funDName, valDName, dataDName, newtypeDName, tySynDName,
classDName, instanceWithOverlapDName,
- standaloneDerivWithStrategyDName, sigDName, forImpDName,
+ standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
pragInlDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName,
dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
@@ -96,19 +96,21 @@ templateHaskellNames = [
-- PatSynArgs (for pattern synonyms)
prefixPatSynName, infixPatSynName, recordPatSynName,
-- Type
- forallTName, varTName, conTName, infixTName, appTName, appKindTName,
- equalityTName, tupleTName, unboxedTupleTName, unboxedSumTName,
- arrowTName, listTName, sigTName, litTName,
+ forallTName, forallVisTName, varTName, conTName, infixTName, appTName,
+ appKindTName, equalityTName, tupleTName, unboxedTupleTName,
+ unboxedSumTName, arrowTName, mulArrowTName, listTName, sigTName, litTName,
promotedTName, promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName, implicitParamTName,
-- TyLit
numTyLitName, strTyLitName,
-- TyVarBndr
plainTVName, kindedTVName,
+ plainInvisTVName, kindedInvisTVName,
+ -- Specificity
+ specifiedSpecName, inferredSpecName,
-- Role
nominalRName, representationalRName, phantomRName, inferRName,
-- Kind
- varKName, conKName, tupleKName, arrowKName, listKName, appKName,
starKName, constraintKName,
-- FamilyResultSig
noSigName, kindSigName, tyVarSigName,
@@ -132,8 +134,6 @@ templateHaskellNames = [
-- DerivStrategy
stockStrategyName, anyclassStrategyName,
newtypeStrategyName, viaStrategyName,
- -- TExp
- tExpDataConName,
-- RuleBndr
ruleVarName, typedRuleVarName,
-- FunDep
@@ -146,18 +146,19 @@ templateHaskellNames = [
derivClauseName,
-- The type classes
- liftClassName,
+ liftClassName, quoteClassName,
-- And the tycons
- qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchQTyConName,
- clauseQTyConName, expQTyConName, fieldExpTyConName, predTyConName,
- stmtQTyConName, decQTyConName, conQTyConName, bangTypeQTyConName,
- varBangTypeQTyConName, typeQTyConName, expTyConName, decTyConName,
- typeTyConName, tyVarBndrQTyConName, matchTyConName, clauseTyConName,
- patQTyConName, fieldPatQTyConName, fieldExpQTyConName, funDepTyConName,
- predQTyConName, decsQTyConName, ruleBndrQTyConName, tySynEqnQTyConName,
- roleTyConName, tExpTyConName, injAnnTyConName, kindQTyConName,
- overlapTyConName, derivClauseQTyConName, derivStrategyQTyConName,
+ qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName,
+ expQTyConName, fieldExpTyConName, predTyConName,
+ stmtTyConName, decsTyConName, conTyConName, bangTypeTyConName,
+ varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,
+ typeTyConName, tyVarBndrUnitTyConName, tyVarBndrSpecTyConName, clauseTyConName,
+ patQTyConName, funDepTyConName, decsQTyConName,
+ ruleBndrTyConName, tySynEqnTyConName,
+ roleTyConName, codeTyConName, injAnnTyConName, kindTyConName,
+ overlapTyConName, derivClauseTyConName, derivStrategyTyConName,
+ modNameTyConName,
-- Quasiquoting
quoteDecName, quoteTypeName, quoteExpName, quotePatName]
@@ -168,25 +169,29 @@ thLib = mkTHModule (fsLit "Language.Haskell.TH.Lib.Internal")
qqLib = mkTHModule (fsLit "Language.Haskell.TH.Quote")
mkTHModule :: FastString -> Module
-mkTHModule m = mkModule thUnitId (mkModuleNameFS m)
+mkTHModule m = mkModule thUnit (mkModuleNameFS m)
libFun, libTc, thFun, thTc, thCls, thCon, qqFun :: FastString -> Unique -> Name
-libFun = mk_known_key_name OccName.varName thLib
-libTc = mk_known_key_name OccName.tcName thLib
-thFun = mk_known_key_name OccName.varName thSyn
-thTc = mk_known_key_name OccName.tcName thSyn
-thCls = mk_known_key_name OccName.clsName thSyn
-thCon = mk_known_key_name OccName.dataName thSyn
-qqFun = mk_known_key_name OccName.varName qqLib
+libFun = mk_known_key_name varName thLib
+libTc = mk_known_key_name tcName thLib
+thFun = mk_known_key_name varName thSyn
+thTc = mk_known_key_name tcName thSyn
+thCls = mk_known_key_name clsName thSyn
+thCon = mk_known_key_name dataName thSyn
+qqFun = mk_known_key_name varName qqLib
-------------------- TH.Syntax -----------------------
liftClassName :: Name
liftClassName = thCls (fsLit "Lift") liftClassKey
+quoteClassName :: Name
+quoteClassName = thCls (fsLit "Quote") quoteClassKey
+
qTyConName, nameTyConName, fieldExpTyConName, patTyConName,
fieldPatTyConName, expTyConName, decTyConName, typeTyConName,
matchTyConName, clauseTyConName, funDepTyConName, predTyConName,
- tExpTyConName, injAnnTyConName, overlapTyConName :: Name
+ codeTyConName, injAnnTyConName, overlapTyConName, decsTyConName,
+ modNameTyConName :: Name
qTyConName = thTc (fsLit "Q") qTyConKey
nameTyConName = thTc (fsLit "Name") nameTyConKey
fieldExpTyConName = thTc (fsLit "FieldExp") fieldExpTyConKey
@@ -194,19 +199,21 @@ patTyConName = thTc (fsLit "Pat") patTyConKey
fieldPatTyConName = thTc (fsLit "FieldPat") fieldPatTyConKey
expTyConName = thTc (fsLit "Exp") expTyConKey
decTyConName = thTc (fsLit "Dec") decTyConKey
+decsTyConName = libTc (fsLit "Decs") decsTyConKey
typeTyConName = thTc (fsLit "Type") typeTyConKey
matchTyConName = thTc (fsLit "Match") matchTyConKey
clauseTyConName = thTc (fsLit "Clause") clauseTyConKey
funDepTyConName = thTc (fsLit "FunDep") funDepTyConKey
predTyConName = thTc (fsLit "Pred") predTyConKey
-tExpTyConName = thTc (fsLit "TExp") tExpTyConKey
+codeTyConName = thTc (fsLit "Code") codeTyConKey
injAnnTyConName = thTc (fsLit "InjectivityAnn") injAnnTyConKey
overlapTyConName = thTc (fsLit "Overlap") overlapTyConKey
+modNameTyConName = thTc (fsLit "ModName") modNameTyConKey
returnQName, bindQName, sequenceQName, newNameName, liftName,
mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,
- mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeQName,
- unsafeTExpCoerceName :: Name
+ mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,
+ unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name
returnQName = thFun (fsLit "returnQ") returnQIdKey
bindQName = thFun (fsLit "bindQ") bindQIdKey
sequenceQName = thFun (fsLit "sequenceQ") sequenceQIdKey
@@ -219,9 +226,11 @@ mkNameG_dName = thFun (fsLit "mkNameG_d") mkNameG_dIdKey
mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey
mkNameLName = thFun (fsLit "mkNameL") mkNameLIdKey
mkNameSName = thFun (fsLit "mkNameS") mkNameSIdKey
+mkModNameName = thFun (fsLit "mkModName") mkModNameIdKey
unTypeName = thFun (fsLit "unType") unTypeIdKey
-unTypeQName = thFun (fsLit "unTypeQ") unTypeQIdKey
-unsafeTExpCoerceName = thFun (fsLit "unsafeTExpCoerce") unsafeTExpCoerceIdKey
+unTypeCodeName = thFun (fsLit "unTypeCode") unTypeCodeIdKey
+unsafeCodeCoerceName = thFun (fsLit "unsafeCodeCoerce") unsafeCodeCoerceIdKey
+liftTypedName = thFun (fsLit "liftTyped") liftTypedIdKey
-------------------- TH.Lib -----------------------
@@ -340,7 +349,7 @@ recSName = libFun (fsLit "recS") recSIdKey
-- data Dec = ...
funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,
- instanceWithOverlapDName, sigDName, forImpDName, pragInlDName,
+ instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName,
dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
@@ -356,6 +365,7 @@ classDName = libFun (fsLit "classD")
instanceWithOverlapDName = libFun (fsLit "instanceWithOverlapD") instanceWithOverlapDIdKey
standaloneDerivWithStrategyDName = libFun (fsLit "standaloneDerivWithStrategyD") standaloneDerivWithStrategyDIdKey
sigDName = libFun (fsLit "sigD") sigDIdKey
+kiSigDName = libFun (fsLit "kiSigD") kiSigDIdKey
defaultSigDName = libFun (fsLit "defaultSigD") defaultSigDIdKey
forImpDName = libFun (fsLit "forImpD") forImpDIdKey
pragInlDName = libFun (fsLit "pragInlD") pragInlDIdKey
@@ -429,18 +439,20 @@ infixPatSynName = libFun (fsLit "infixPatSyn") infixPatSynIdKey
recordPatSynName = libFun (fsLit "recordPatSyn") recordPatSynIdKey
-- data Type = ...
-forallTName, varTName, conTName, infixTName, tupleTName, unboxedTupleTName,
- unboxedSumTName, arrowTName, listTName, appTName, appKindTName,
- sigTName, equalityTName, litTName, promotedTName,
+forallTName, forallVisTName, varTName, conTName, infixTName, tupleTName,
+ unboxedTupleTName, unboxedSumTName, arrowTName, mulArrowTName, listTName,
+ appTName, appKindTName, sigTName, equalityTName, litTName, promotedTName,
promotedTupleTName, promotedNilTName, promotedConsTName,
wildCardTName, implicitParamTName :: Name
forallTName = libFun (fsLit "forallT") forallTIdKey
+forallVisTName = libFun (fsLit "forallVisT") forallVisTIdKey
varTName = libFun (fsLit "varT") varTIdKey
conTName = libFun (fsLit "conT") conTIdKey
tupleTName = libFun (fsLit "tupleT") tupleTIdKey
unboxedTupleTName = libFun (fsLit "unboxedTupleT") unboxedTupleTIdKey
unboxedSumTName = libFun (fsLit "unboxedSumT") unboxedSumTIdKey
arrowTName = libFun (fsLit "arrowT") arrowTIdKey
+mulArrowTName = libFun (fsLit "mulArrowT") mulArrowTIdKey
listTName = libFun (fsLit "listT") listTIdKey
appTName = libFun (fsLit "appT") appTIdKey
appKindTName = libFun (fsLit "appKindT") appKindTIdKey
@@ -465,6 +477,15 @@ plainTVName, kindedTVName :: Name
plainTVName = libFun (fsLit "plainTV") plainTVIdKey
kindedTVName = libFun (fsLit "kindedTV") kindedTVIdKey
+plainInvisTVName, kindedInvisTVName :: Name
+plainInvisTVName = libFun (fsLit "plainInvisTV") plainInvisTVIdKey
+kindedInvisTVName = libFun (fsLit "kindedInvisTV") kindedInvisTVIdKey
+
+-- data Specificity = ...
+specifiedSpecName, inferredSpecName :: Name
+specifiedSpecName = libFun (fsLit "specifiedSpec") specifiedSpecKey
+inferredSpecName = libFun (fsLit "inferredSpec") inferredSpecKey
+
-- data Role = ...
nominalRName, representationalRName, phantomRName, inferRName :: Name
nominalRName = libFun (fsLit "nominalR") nominalRIdKey
@@ -473,14 +494,7 @@ phantomRName = libFun (fsLit "phantomR") phantomRIdKey
inferRName = libFun (fsLit "inferR") inferRIdKey
-- data Kind = ...
-varKName, conKName, tupleKName, arrowKName, listKName, appKName,
- starKName, constraintKName :: Name
-varKName = libFun (fsLit "varK") varKIdKey
-conKName = libFun (fsLit "conK") conKIdKey
-tupleKName = libFun (fsLit "tupleK") tupleKIdKey
-arrowKName = libFun (fsLit "arrowK") arrowKIdKey
-listKName = libFun (fsLit "listK") listKIdKey
-appKName = libFun (fsLit "appK") appKIdKey
+starKName, constraintKName :: Name
starKName = libFun (fsLit "starK") starKIdKey
constraintKName = libFun (fsLit "constraintK") constraintKIdKey
@@ -508,10 +522,6 @@ unsafeName = libFun (fsLit "unsafe") unsafeIdKey
safeName = libFun (fsLit "safe") safeIdKey
interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
--- newtype TExp a = ...
-tExpDataConName :: Name
-tExpDataConName = thCon (fsLit "TExp") tExpDataConKey
-
-- data RuleBndr = ...
ruleVarName, typedRuleVarName :: Name
ruleVarName = libFun (fsLit ("ruleVar")) ruleVarIdKey
@@ -543,34 +553,32 @@ anyclassStrategyName = libFun (fsLit "anyclassStrategy") anyclassStrategyIdKey
newtypeStrategyName = libFun (fsLit "newtypeStrategy") newtypeStrategyIdKey
viaStrategyName = libFun (fsLit "viaStrategy") viaStrategyIdKey
-matchQTyConName, clauseQTyConName, expQTyConName, stmtQTyConName,
- decQTyConName, conQTyConName, bangTypeQTyConName,
- varBangTypeQTyConName, typeQTyConName, fieldExpQTyConName,
- patQTyConName, fieldPatQTyConName, predQTyConName, decsQTyConName,
- ruleBndrQTyConName, tySynEqnQTyConName, roleTyConName,
- derivClauseQTyConName, kindQTyConName, tyVarBndrQTyConName,
- derivStrategyQTyConName :: Name
-matchQTyConName = libTc (fsLit "MatchQ") matchQTyConKey
-clauseQTyConName = libTc (fsLit "ClauseQ") clauseQTyConKey
+patQTyConName, expQTyConName, stmtTyConName,
+ conTyConName, bangTypeTyConName,
+ varBangTypeTyConName, typeQTyConName,
+ decsQTyConName, ruleBndrTyConName, tySynEqnTyConName, roleTyConName,
+ derivClauseTyConName, kindTyConName,
+ tyVarBndrUnitTyConName, tyVarBndrSpecTyConName,
+ derivStrategyTyConName :: Name
+-- These are only used for the types of top-level splices
expQTyConName = libTc (fsLit "ExpQ") expQTyConKey
-stmtQTyConName = libTc (fsLit "StmtQ") stmtQTyConKey
-decQTyConName = libTc (fsLit "DecQ") decQTyConKey
decsQTyConName = libTc (fsLit "DecsQ") decsQTyConKey -- Q [Dec]
-conQTyConName = libTc (fsLit "ConQ") conQTyConKey
-bangTypeQTyConName = libTc (fsLit "BangTypeQ") bangTypeQTyConKey
-varBangTypeQTyConName = libTc (fsLit "VarBangTypeQ") varBangTypeQTyConKey
typeQTyConName = libTc (fsLit "TypeQ") typeQTyConKey
-fieldExpQTyConName = libTc (fsLit "FieldExpQ") fieldExpQTyConKey
patQTyConName = libTc (fsLit "PatQ") patQTyConKey
-fieldPatQTyConName = libTc (fsLit "FieldPatQ") fieldPatQTyConKey
-predQTyConName = libTc (fsLit "PredQ") predQTyConKey
-ruleBndrQTyConName = libTc (fsLit "RuleBndrQ") ruleBndrQTyConKey
-tySynEqnQTyConName = libTc (fsLit "TySynEqnQ") tySynEqnQTyConKey
+
+-- These are used in GHC.HsToCore.Quote but always wrapped in a type variable
+stmtTyConName = thTc (fsLit "Stmt") stmtTyConKey
+conTyConName = thTc (fsLit "Con") conTyConKey
+bangTypeTyConName = thTc (fsLit "BangType") bangTypeTyConKey
+varBangTypeTyConName = thTc (fsLit "VarBangType") varBangTypeTyConKey
+ruleBndrTyConName = thTc (fsLit "RuleBndr") ruleBndrTyConKey
+tySynEqnTyConName = thTc (fsLit "TySynEqn") tySynEqnTyConKey
roleTyConName = libTc (fsLit "Role") roleTyConKey
-derivClauseQTyConName = libTc (fsLit "DerivClauseQ") derivClauseQTyConKey
-kindQTyConName = libTc (fsLit "KindQ") kindQTyConKey
-tyVarBndrQTyConName = libTc (fsLit "TyVarBndrQ") tyVarBndrQTyConKey
-derivStrategyQTyConName = libTc (fsLit "DerivStrategyQ") derivStrategyQTyConKey
+derivClauseTyConName = thTc (fsLit "DerivClause") derivClauseTyConKey
+kindTyConName = thTc (fsLit "Kind") kindTyConKey
+tyVarBndrUnitTyConName = libTc (fsLit "TyVarBndrUnit") tyVarBndrUnitTyConKey
+tyVarBndrSpecTyConName = libTc (fsLit "TyVarBndrSpec") tyVarBndrSpecTyConKey
+derivStrategyTyConName = thTc (fsLit "DerivStrategy") derivStrategyTyConKey
-- quasiquoting
quoteExpName, quotePatName, quoteDecName, quoteTypeName :: Name
@@ -613,11 +621,14 @@ incoherentDataConName = thCon (fsLit "Incoherent") incoherentDataConKey
********************************************************************* -}
-- ClassUniques available: 200-299
--- Check in PrelNames if you want to change this
+-- Check in GHC.Builtin.Names if you want to change this
liftClassKey :: Unique
liftClassKey = mkPreludeClassUnique 200
+quoteClassKey :: Unique
+quoteClassKey = mkPreludeClassUnique 201
+
{- *********************************************************************
* *
TyCon keys
@@ -625,53 +636,53 @@ liftClassKey = mkPreludeClassUnique 200
********************************************************************* -}
-- TyConUniques available: 200-299
--- Check in PrelNames if you want to change this
+-- Check in GHC.Builtin.Names if you want to change this
expTyConKey, matchTyConKey, clauseTyConKey, qTyConKey, expQTyConKey,
- decQTyConKey, patTyConKey, matchQTyConKey, clauseQTyConKey,
- stmtQTyConKey, conQTyConKey, typeQTyConKey, typeTyConKey,
- tyVarBndrQTyConKey, decTyConKey, bangTypeQTyConKey, varBangTypeQTyConKey,
+ patTyConKey,
+ stmtTyConKey, conTyConKey, typeQTyConKey, typeTyConKey,
+ tyVarBndrUnitTyConKey, tyVarBndrSpecTyConKey,
+ decTyConKey, bangTypeTyConKey, varBangTypeTyConKey,
fieldExpTyConKey, fieldPatTyConKey, nameTyConKey, patQTyConKey,
- fieldPatQTyConKey, fieldExpQTyConKey, funDepTyConKey, predTyConKey,
- predQTyConKey, decsQTyConKey, ruleBndrQTyConKey, tySynEqnQTyConKey,
- roleTyConKey, tExpTyConKey, injAnnTyConKey, kindQTyConKey,
- overlapTyConKey, derivClauseQTyConKey, derivStrategyQTyConKey :: Unique
+ funDepTyConKey, predTyConKey,
+ predQTyConKey, decsQTyConKey, ruleBndrTyConKey, tySynEqnTyConKey,
+ roleTyConKey, codeTyConKey, injAnnTyConKey, kindTyConKey,
+ overlapTyConKey, derivClauseTyConKey, derivStrategyTyConKey, decsTyConKey,
+ modNameTyConKey :: Unique
expTyConKey = mkPreludeTyConUnique 200
matchTyConKey = mkPreludeTyConUnique 201
clauseTyConKey = mkPreludeTyConUnique 202
qTyConKey = mkPreludeTyConUnique 203
expQTyConKey = mkPreludeTyConUnique 204
-decQTyConKey = mkPreludeTyConUnique 205
patTyConKey = mkPreludeTyConUnique 206
-matchQTyConKey = mkPreludeTyConUnique 207
-clauseQTyConKey = mkPreludeTyConUnique 208
-stmtQTyConKey = mkPreludeTyConUnique 209
-conQTyConKey = mkPreludeTyConUnique 210
+stmtTyConKey = mkPreludeTyConUnique 209
+conTyConKey = mkPreludeTyConUnique 210
typeQTyConKey = mkPreludeTyConUnique 211
typeTyConKey = mkPreludeTyConUnique 212
decTyConKey = mkPreludeTyConUnique 213
-bangTypeQTyConKey = mkPreludeTyConUnique 214
-varBangTypeQTyConKey = mkPreludeTyConUnique 215
+bangTypeTyConKey = mkPreludeTyConUnique 214
+varBangTypeTyConKey = mkPreludeTyConUnique 215
fieldExpTyConKey = mkPreludeTyConUnique 216
fieldPatTyConKey = mkPreludeTyConUnique 217
nameTyConKey = mkPreludeTyConUnique 218
patQTyConKey = mkPreludeTyConUnique 219
-fieldPatQTyConKey = mkPreludeTyConUnique 220
-fieldExpQTyConKey = mkPreludeTyConUnique 221
funDepTyConKey = mkPreludeTyConUnique 222
predTyConKey = mkPreludeTyConUnique 223
predQTyConKey = mkPreludeTyConUnique 224
-tyVarBndrQTyConKey = mkPreludeTyConUnique 225
+tyVarBndrUnitTyConKey = mkPreludeTyConUnique 225
decsQTyConKey = mkPreludeTyConUnique 226
-ruleBndrQTyConKey = mkPreludeTyConUnique 227
-tySynEqnQTyConKey = mkPreludeTyConUnique 228
+ruleBndrTyConKey = mkPreludeTyConUnique 227
+tySynEqnTyConKey = mkPreludeTyConUnique 228
roleTyConKey = mkPreludeTyConUnique 229
-tExpTyConKey = mkPreludeTyConUnique 230
injAnnTyConKey = mkPreludeTyConUnique 231
-kindQTyConKey = mkPreludeTyConUnique 232
+kindTyConKey = mkPreludeTyConUnique 232
overlapTyConKey = mkPreludeTyConUnique 233
-derivClauseQTyConKey = mkPreludeTyConUnique 234
-derivStrategyQTyConKey = mkPreludeTyConUnique 235
+derivClauseTyConKey = mkPreludeTyConUnique 234
+derivStrategyTyConKey = mkPreludeTyConUnique 235
+decsTyConKey = mkPreludeTyConUnique 236
+tyVarBndrSpecTyConKey = mkPreludeTyConUnique 237
+codeTyConKey = mkPreludeTyConUnique 238
+modNameTyConKey = mkPreludeTyConUnique 239
{- *********************************************************************
* *
@@ -680,7 +691,7 @@ derivStrategyQTyConKey = mkPreludeTyConUnique 235
********************************************************************* -}
-- DataConUniques available: 100-150
--- If you want to change this, make sure you check in PrelNames
+-- If you want to change this, make sure you check in GHC.Builtin.Names
-- data Inline = ...
noInlineDataConKey, inlineDataConKey, inlinableDataConKey :: Unique
@@ -699,10 +710,6 @@ allPhasesDataConKey = mkPreludeDataConUnique 205
fromPhaseDataConKey = mkPreludeDataConUnique 206
beforePhaseDataConKey = mkPreludeDataConUnique 207
--- newtype TExp a = ...
-tExpDataConKey :: Unique
-tExpDataConKey = mkPreludeDataConUnique 208
-
-- data Overlap = ..
overlappableDataConKey,
overlappingDataConKey,
@@ -720,12 +727,12 @@ incoherentDataConKey = mkPreludeDataConUnique 212
********************************************************************* -}
-- IdUniques available: 200-499
--- If you want to change this, make sure you check in PrelNames
+-- If you want to change this, make sure you check in GHC.Builtin.Names
returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,
mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,
- mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeQIdKey,
- unsafeTExpCoerceIdKey :: Unique
+ mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,
+ unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique
returnQIdKey = mkPreludeMiscIdUnique 200
bindQIdKey = mkPreludeMiscIdUnique 201
sequenceQIdKey = mkPreludeMiscIdUnique 202
@@ -738,8 +745,10 @@ mkNameG_tcIdKey = mkPreludeMiscIdUnique 208
mkNameLIdKey = mkPreludeMiscIdUnique 209
mkNameSIdKey = mkPreludeMiscIdUnique 210
unTypeIdKey = mkPreludeMiscIdUnique 211
-unTypeQIdKey = mkPreludeMiscIdUnique 212
-unsafeTExpCoerceIdKey = mkPreludeMiscIdUnique 213
+unTypeCodeIdKey = mkPreludeMiscIdUnique 212
+liftTypedIdKey = mkPreludeMiscIdUnique 214
+mkModNameIdKey = mkPreludeMiscIdUnique 215
+unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216
-- data Lit = ...
@@ -865,7 +874,8 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,
newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
- patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey :: Unique
+ patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
+ kiSigDIdKey :: Unique
funDIdKey = mkPreludeMiscIdUnique 320
valDIdKey = mkPreludeMiscIdUnique 321
dataDIdKey = mkPreludeMiscIdUnique 322
@@ -898,6 +908,7 @@ patSynDIdKey = mkPreludeMiscIdUnique 348
patSynSigDIdKey = mkPreludeMiscIdUnique 349
pragCompleteDIdKey = mkPreludeMiscIdUnique 350
implicitParamBindDIdKey = mkPreludeMiscIdUnique 351
+kiSigDIdKey = mkPreludeMiscIdUnique 352
-- type Cxt = ...
cxtIdKey :: Unique
@@ -950,79 +961,77 @@ infixPatSynIdKey = mkPreludeMiscIdUnique 381
recordPatSynIdKey = mkPreludeMiscIdUnique 382
-- data Type = ...
-forallTIdKey, varTIdKey, conTIdKey, tupleTIdKey, unboxedTupleTIdKey,
- unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey, appKindTIdKey,
- sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,
+forallTIdKey, forallVisTIdKey, varTIdKey, conTIdKey, tupleTIdKey,
+ unboxedTupleTIdKey, unboxedSumTIdKey, arrowTIdKey, listTIdKey, appTIdKey,
+ appKindTIdKey, sigTIdKey, equalityTIdKey, litTIdKey, promotedTIdKey,
promotedTupleTIdKey, promotedNilTIdKey, promotedConsTIdKey,
wildCardTIdKey, implicitParamTIdKey, infixTIdKey :: Unique
forallTIdKey = mkPreludeMiscIdUnique 390
-varTIdKey = mkPreludeMiscIdUnique 391
-conTIdKey = mkPreludeMiscIdUnique 392
-tupleTIdKey = mkPreludeMiscIdUnique 393
-unboxedTupleTIdKey = mkPreludeMiscIdUnique 394
-unboxedSumTIdKey = mkPreludeMiscIdUnique 395
-arrowTIdKey = mkPreludeMiscIdUnique 396
-listTIdKey = mkPreludeMiscIdUnique 397
-appTIdKey = mkPreludeMiscIdUnique 398
-appKindTIdKey = mkPreludeMiscIdUnique 399
-sigTIdKey = mkPreludeMiscIdUnique 400
-equalityTIdKey = mkPreludeMiscIdUnique 401
-litTIdKey = mkPreludeMiscIdUnique 402
-promotedTIdKey = mkPreludeMiscIdUnique 403
-promotedTupleTIdKey = mkPreludeMiscIdUnique 404
-promotedNilTIdKey = mkPreludeMiscIdUnique 405
-promotedConsTIdKey = mkPreludeMiscIdUnique 406
-wildCardTIdKey = mkPreludeMiscIdUnique 407
-implicitParamTIdKey = mkPreludeMiscIdUnique 408
-infixTIdKey = mkPreludeMiscIdUnique 409
+forallVisTIdKey = mkPreludeMiscIdUnique 391
+varTIdKey = mkPreludeMiscIdUnique 392
+conTIdKey = mkPreludeMiscIdUnique 393
+tupleTIdKey = mkPreludeMiscIdUnique 394
+unboxedTupleTIdKey = mkPreludeMiscIdUnique 395
+unboxedSumTIdKey = mkPreludeMiscIdUnique 396
+arrowTIdKey = mkPreludeMiscIdUnique 397
+listTIdKey = mkPreludeMiscIdUnique 398
+appTIdKey = mkPreludeMiscIdUnique 399
+appKindTIdKey = mkPreludeMiscIdUnique 400
+sigTIdKey = mkPreludeMiscIdUnique 401
+equalityTIdKey = mkPreludeMiscIdUnique 402
+litTIdKey = mkPreludeMiscIdUnique 403
+promotedTIdKey = mkPreludeMiscIdUnique 404
+promotedTupleTIdKey = mkPreludeMiscIdUnique 405
+promotedNilTIdKey = mkPreludeMiscIdUnique 406
+promotedConsTIdKey = mkPreludeMiscIdUnique 407
+wildCardTIdKey = mkPreludeMiscIdUnique 408
+implicitParamTIdKey = mkPreludeMiscIdUnique 409
+infixTIdKey = mkPreludeMiscIdUnique 410
-- data TyLit = ...
numTyLitIdKey, strTyLitIdKey :: Unique
-numTyLitIdKey = mkPreludeMiscIdUnique 410
-strTyLitIdKey = mkPreludeMiscIdUnique 411
+numTyLitIdKey = mkPreludeMiscIdUnique 411
+strTyLitIdKey = mkPreludeMiscIdUnique 412
-- data TyVarBndr = ...
plainTVIdKey, kindedTVIdKey :: Unique
-plainTVIdKey = mkPreludeMiscIdUnique 412
-kindedTVIdKey = mkPreludeMiscIdUnique 413
+plainTVIdKey = mkPreludeMiscIdUnique 413
+kindedTVIdKey = mkPreludeMiscIdUnique 414
+
+plainInvisTVIdKey, kindedInvisTVIdKey :: Unique
+plainInvisTVIdKey = mkPreludeMiscIdUnique 482
+kindedInvisTVIdKey = mkPreludeMiscIdUnique 483
-- data Role = ...
nominalRIdKey, representationalRIdKey, phantomRIdKey, inferRIdKey :: Unique
-nominalRIdKey = mkPreludeMiscIdUnique 414
-representationalRIdKey = mkPreludeMiscIdUnique 415
-phantomRIdKey = mkPreludeMiscIdUnique 416
-inferRIdKey = mkPreludeMiscIdUnique 417
+nominalRIdKey = mkPreludeMiscIdUnique 415
+representationalRIdKey = mkPreludeMiscIdUnique 416
+phantomRIdKey = mkPreludeMiscIdUnique 417
+inferRIdKey = mkPreludeMiscIdUnique 418
-- data Kind = ...
-varKIdKey, conKIdKey, tupleKIdKey, arrowKIdKey, listKIdKey, appKIdKey,
- starKIdKey, constraintKIdKey :: Unique
-varKIdKey = mkPreludeMiscIdUnique 418
-conKIdKey = mkPreludeMiscIdUnique 419
-tupleKIdKey = mkPreludeMiscIdUnique 420
-arrowKIdKey = mkPreludeMiscIdUnique 421
-listKIdKey = mkPreludeMiscIdUnique 422
-appKIdKey = mkPreludeMiscIdUnique 423
-starKIdKey = mkPreludeMiscIdUnique 424
-constraintKIdKey = mkPreludeMiscIdUnique 425
+starKIdKey, constraintKIdKey :: Unique
+starKIdKey = mkPreludeMiscIdUnique 425
+constraintKIdKey = mkPreludeMiscIdUnique 426
-- data FamilyResultSig = ...
noSigIdKey, kindSigIdKey, tyVarSigIdKey :: Unique
-noSigIdKey = mkPreludeMiscIdUnique 426
-kindSigIdKey = mkPreludeMiscIdUnique 427
-tyVarSigIdKey = mkPreludeMiscIdUnique 428
+noSigIdKey = mkPreludeMiscIdUnique 427
+kindSigIdKey = mkPreludeMiscIdUnique 428
+tyVarSigIdKey = mkPreludeMiscIdUnique 429
-- data InjectivityAnn = ...
injectivityAnnIdKey :: Unique
-injectivityAnnIdKey = mkPreludeMiscIdUnique 429
+injectivityAnnIdKey = mkPreludeMiscIdUnique 430
-- data Callconv = ...
cCallIdKey, stdCallIdKey, cApiCallIdKey, primCallIdKey,
javaScriptCallIdKey :: Unique
-cCallIdKey = mkPreludeMiscIdUnique 430
-stdCallIdKey = mkPreludeMiscIdUnique 431
-cApiCallIdKey = mkPreludeMiscIdUnique 432
-primCallIdKey = mkPreludeMiscIdUnique 433
-javaScriptCallIdKey = mkPreludeMiscIdUnique 434
+cCallIdKey = mkPreludeMiscIdUnique 431
+stdCallIdKey = mkPreludeMiscIdUnique 432
+cApiCallIdKey = mkPreludeMiscIdUnique 433
+primCallIdKey = mkPreludeMiscIdUnique 434
+javaScriptCallIdKey = mkPreludeMiscIdUnique 435
-- data Safety = ...
unsafeIdKey, safeIdKey, interruptibleIdKey :: Unique
@@ -1034,6 +1043,10 @@ interruptibleIdKey = mkPreludeMiscIdUnique 442
funDepIdKey :: Unique
funDepIdKey = mkPreludeMiscIdUnique 445
+-- mulArrow
+mulArrowTIdKey :: Unique
+mulArrowTIdKey = mkPreludeMiscIdUnique 446
+
-- data TySynEqn = ...
tySynEqnIdKey :: Unique
tySynEqnIdKey = mkPreludeMiscIdUnique 460
@@ -1068,6 +1081,11 @@ anyclassStrategyIdKey = mkPreludeDataConUnique 495
newtypeStrategyIdKey = mkPreludeDataConUnique 496
viaStrategyIdKey = mkPreludeDataConUnique 497
+-- data Specificity = ...
+specifiedSpecKey, inferredSpecKey :: Unique
+specifiedSpecKey = mkPreludeMiscIdUnique 498
+inferredSpecKey = mkPreludeMiscIdUnique 499
+
{-
************************************************************************
* *
@@ -1076,8 +1094,10 @@ viaStrategyIdKey = mkPreludeDataConUnique 497
************************************************************************
-}
-lift_RDR, mkNameG_dRDR, mkNameG_vRDR :: RdrName
+lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, unsafeCodeCoerce_RDR :: RdrName
lift_RDR = nameRdrName liftName
+liftTyped_RDR = nameRdrName liftTypedName
+unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName
mkNameG_dRDR = nameRdrName mkNameG_dName
mkNameG_vRDR = nameRdrName mkNameG_vName
diff --git a/compiler/GHC/Builtin/RebindableNames.hs b/compiler/GHC/Builtin/RebindableNames.hs
new file mode 100644
index 0000000..0a07224
--- /dev/null
+++ b/compiler/GHC/Builtin/RebindableNames.hs
@@ -0,0 +1,6 @@
+module GHC.Builtin.RebindableNames where
+
+import GHC.Data.FastString
+
+reboundIfSymbol :: FastString
+reboundIfSymbol = fsLit "ifThenElse"
diff --git a/compiler/typecheck/TcTypeNats.hs b/compiler/GHC/Builtin/Types/Literals.hs
index 24e12cd..ef6fb96 100644
--- a/compiler/typecheck/TcTypeNats.hs
+++ b/compiler/GHC/Builtin/Types/Literals.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE LambdaCase #-}
-module TcTypeNats
+module GHC.Builtin.Types.Literals
( typeNatTyCons
, typeNatCoAxiomRules
, BuiltInSynFamily(..)
@@ -21,20 +21,21 @@ module TcTypeNats
, typeSymbolAppendTyCon
) where
-import GhcPrelude
-
-import Type
-import Pair
-import TcType ( TcType, tcEqType )
-import TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon
- , Injectivity(..) )
-import Coercion ( Role(..) )
-import TcRnTypes ( Xi )
-import CoAxiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )
-import Name ( Name, BuiltInSyntax(..) )
-import TysWiredIn
-import TysPrim ( mkTemplateAnonTyConBinders )
-import PrelNames ( gHC_TYPELITS
+import GHC.Prelude
+
+import GHC.Core.Type
+import GHC.Data.Pair
+import GHC.Tc.Utils.TcType ( TcType, tcEqType )
+import GHC.Core.TyCon ( TyCon, FamTyConFlav(..), mkFamilyTyCon
+ , Injectivity(..) )
+import GHC.Core.Coercion ( Role(..) )
+import GHC.Tc.Types.Constraint ( Xi )
+import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )
+import GHC.Types.Name ( Name, BuiltInSyntax(..) )
+import GHC.Builtin.Types
+import GHC.Builtin.Types.Prim ( mkTemplateAnonTyConBinders )
+import GHC.Builtin.Names
+ ( gHC_TYPELITS
, gHC_TYPENATS
, typeNatAddTyFamNameKey
, typeNatMulTyFamNameKey
@@ -48,9 +49,7 @@ import PrelNames ( gHC_TYPELITS
, typeSymbolCmpTyFamNameKey
, typeSymbolAppendFamNameKey
)
-import FastString ( FastString
- , fsLit, nilFS, nullFS, unpackFS, mkFastString, appendFS
- )
+import GHC.Data.FastString
import qualified Data.Map as Map
import Data.Maybe ( isJust )
import Control.Monad ( guard )
@@ -60,7 +59,7 @@ import Data.List ( isPrefixOf, isSuffixOf )
Note [Type-level literals]
~~~~~~~~~~~~~~~~~~~~~~~~~~
There are currently two forms of type-level literals: natural numbers, and
-symbols (even though this module is named TcTypeNats, it covers both).
+symbols (even though this module is named GHC.Builtin.Types.Literals, it covers both).
Type-level literals are supported by CoAxiomRules (conditional axioms), which
power the built-in type families (see Note [Adding built-in type families]).
@@ -69,7 +68,7 @@ type-level literals.
See also the Wiki page:
- https://ghc.haskell.org/trac/ghc/wiki/TypeNats
+ https://gitlab.haskell.org/ghc/ghc/wikis/type-nats
Note [Adding built-in type families]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -77,20 +76,20 @@ There are a few steps to adding a built-in type family:
* Adding a unique for the type family TyCon
- These go in PrelNames. It will likely be of the form
+ These go in GHC.Builtin.Names. It will likely be of the form
@myTyFamNameKey = mkPreludeTyConUnique xyz@, where @xyz@ is a number that
- has not been chosen before in PrelNames. There are several examples already
- in PrelNames—see, for instance, typeNatAddTyFamNameKey.
+ has not been chosen before in GHC.Builtin.Names. There are several examples already
+ in GHC.Builtin.Names—see, for instance, typeNatAddTyFamNameKey.
* Adding the type family TyCon itself
- This goes in TcTypeNats. There are plenty of examples of how to define
+ This goes in GHC.Builtin.Types.Literals. There are plenty of examples of how to define
these—see, for instance, typeNatAddTyCon.
Once your TyCon has been defined, be sure to:
- - Export it from TcTypeNats. (Not doing so caused #14632.)
- - Include it in the typeNatTyCons list, defined in TcTypeNats.
+ - Export it from GHC.Builtin.Types.Literals. (Not doing so caused #14632.)
+ - Include it in the typeNatTyCons list, defined in GHC.Builtin.Types.Literals.
* Exposing associated type family axioms
@@ -100,7 +99,7 @@ There are a few steps to adding a built-in type family:
axAdd0L and axAdd0R).
After you have defined all of these axioms, be sure to include them in the
- typeNatCoAxiomRules list, defined in TcTypeNats.
+ typeNatCoAxiomRules list, defined in GHC.Builtin.Types.Literals.
(Not doing so caused #14934.)
* Define the type family somewhere
@@ -109,7 +108,7 @@ There are a few steps to adding a built-in type family:
Currently, all of the built-in type families are defined in GHC.TypeLits or
GHC.TypeNats, so those are likely candidates.
- Since the behavior of your built-in type family is specified in TcTypeNats,
+ Since the behavior of your built-in type family is specified in GHC.Builtin.Types.Literals,
you should give an open type family definition with no instances, like so:
type family MyTypeFam (m :: Nat) (n :: Nat) :: Nat
diff --git a/compiler/prelude/PrelInfo.hs b/compiler/GHC/Builtin/Utils.hs
index 1f2d382..8f3f915 100644
--- a/compiler/prelude/PrelInfo.hs
+++ b/compiler/GHC/Builtin/Utils.hs
@@ -5,7 +5,7 @@
{-# LANGUAGE CPP #-}
--- | The @PrelInfo@ interface to the compiler's prelude knowledge.
+-- | The @GHC.Builtin.Utils@ interface to the compiler's prelude knowledge.
--
-- This module serves as the central gathering point for names which the
-- compiler knows something about. This includes functions for,
@@ -17,7 +17,7 @@
-- See Note [Known-key names] and Note [About wired-in things] for information
-- about the two types of prelude things in GHC.
--
-module PrelInfo (
+module GHC.Builtin.Utils (
-- * Known-key names
isKnownKeyName,
lookupKnownKeyName,
@@ -34,6 +34,7 @@ module PrelInfo (
primOpRules, builtinRules,
ghcPrimExports,
+ ghcPrimDeclDocs,
primOpId,
-- * Random other things
@@ -46,36 +47,39 @@ module PrelInfo (
#include "GhclibHsVersions.h"
-import GhcPrelude
-
-import KnownUniques
-import Unique ( isValidKnownKeyUnique )
-
-import ConLike ( ConLike(..) )
-import THNames ( templateHaskellNames )
-import PrelNames
-import PrelRules
-import Avail
-import PrimOp
-import DataCon
-import Id
-import Name
-import NameEnv
-import MkId
-import Outputable
-import TysPrim
-import TysWiredIn
-import HscTypes
-import Class
-import TyCon
-import UniqFM
-import Util
-import TcTypeNats ( typeNatTyCons )
+import GHC.Prelude
+
+import GHC.Builtin.Uniques
+import GHC.Types.Unique ( isValidKnownKeyUnique )
+
+import GHC.Core.ConLike ( ConLike(..) )
+import GHC.Builtin.Names.TH ( templateHaskellNames )
+import GHC.Builtin.Names
+import GHC.Core.Opt.ConstantFold
+import GHC.Types.Avail
+import GHC.Builtin.PrimOps
+import GHC.Core.DataCon
+import GHC.Types.Basic
+import GHC.Types.Id
+import GHC.Types.Name
+import GHC.Types.Name.Env
+import GHC.Types.Id.Make
+import GHC.Utils.Outputable
+import GHC.Builtin.Types.Prim
+import GHC.Builtin.Types
+import GHC.Driver.Types
+import GHC.Core.Class
+import GHC.Core.TyCon
+import GHC.Types.Unique.FM
+import GHC.Utils.Misc
+import GHC.Builtin.Types.Literals ( typeNatTyCons )
+import GHC.Hs.Doc
import Control.Applicative ((<|>))
-import Data.List ( intercalate )
+import Data.List ( intercalate , find )
import Data.Array
import Data.Maybe
+import qualified Data.Map as Map
{-
************************************************************************
@@ -89,25 +93,25 @@ Note [About wired-in things]
* Wired-in things are Ids\/TyCons that are completely known to the compiler.
They are global values in GHC, (e.g. listTyCon :: TyCon).
-* A wired in Name contains the thing itself inside the Name:
+* A wired-in Name contains the thing itself inside the Name:
see Name.wiredInNameTyThing_maybe
(E.g. listTyConName contains listTyCon.
* The name cache is initialised with (the names of) all wired-in things
- (except tuples and sums; see Note [Known-])
+ (except tuples and sums; see Note [Infinite families of known-key names])
* The type environment itself contains no wired in things. The type
checker sees if the Name is wired in before looking up the name in
the type environment.
-* MkIface prunes out wired-in things before putting them in an interface file.
+* GHC.Iface.Make prunes out wired-in things before putting them in an interface file.
So interface files never contain wired-in things.
-}
-- | This list is used to ensure that when you say "Prelude.map" in your source
-- code, or in an interface file, you get a Name with the correct known key (See
--- Note [Known-key names] in PrelNames)
+-- Note [Known-key names] in "GHC.Builtin.Names")
knownKeyNames :: [Name]
knownKeyNames
| debugIsOn
@@ -121,14 +125,17 @@ knownKeyNames
= all_names
where
all_names =
+ -- We exclude most tuples from this list—see
+ -- Note [Infinite families of known-key names] in GHC.Builtin.Names.
+ -- We make an exception for Solo (i.e., the boxed 1-tuple), since it does
+ -- not use special syntax like other tuples.
+ -- See Note [One-tuples] (Wrinkle: Make boxed one-tuple names have known keys)
+ -- in GHC.Builtin.Types.
+ tupleTyConName BoxedTuple 1 : tupleDataConName Boxed 1 :
concat [ wired_tycon_kk_names funTyCon
, concatMap wired_tycon_kk_names primTyCons
-
, concatMap wired_tycon_kk_names wiredInTyCons
- -- Does not include tuples
-
, concatMap wired_tycon_kk_names typeNatTyCons
-
, map idName wiredInIds
, map (idName . primOpId) allThePrimOps
, map (idName . primOpWrapperId) allThePrimOps
@@ -191,21 +198,26 @@ knownKeyNamesOkay all_names
-- known-key thing.
lookupKnownKeyName :: Unique -> Maybe Name
lookupKnownKeyName u =
- knownUniqueName u <|> lookupUFM knownKeysMap u
+ knownUniqueName u <|> lookupUFM_Directly knownKeysMap u
-- | Is a 'Name' known-key?
isKnownKeyName :: Name -> Bool
isKnownKeyName n =
isJust (knownUniqueName $ nameUnique n) || elemUFM n knownKeysMap
-knownKeysMap :: UniqFM Name
-knownKeysMap = listToUFM [ (nameUnique n, n) | n <- knownKeyNames ]
+-- | Maps 'Unique's to known-key names.
+--
+-- The type is @UniqFM Name Name@ to denote that the 'Unique's used
+-- in the domain are 'Unique's associated with 'Name's (as opposed
+-- to some other namespace of 'Unique's).
+knownKeysMap :: UniqFM Name Name
+knownKeysMap = listToIdentityUFM knownKeyNames
-- | Given a 'Unique' lookup any associated arbitrary SDoc's to be displayed by
-- GHCi's ':info' command.
lookupKnownNameInfo :: Name -> SDoc
lookupKnownNameInfo name = case lookupNameEnv knownNamesInfo name of
- -- If we do find a doc, we add comment delimeters to make the output
+ -- If we do find a doc, we add comment delimiters to make the output
-- of ':info' valid Haskell.
Nothing -> empty
Just doc -> vcat [text "{-", doc, text "-}"]
@@ -215,7 +227,8 @@ knownNamesInfo :: NameEnv SDoc
knownNamesInfo = unitNameEnv coercibleTyConName $
vcat [ text "Coercible is a special constraint with custom solving rules."
, text "It is not a class."
- , text "Please see section 9.14.4 of the user's guide for details." ]
+ , text "Please see section `The Coercible constraint`"
+ , text "of the user's guide for details." ]
{-
We let a lot of "non-standard" values be visible, so that we can make
@@ -255,6 +268,17 @@ ghcPrimExports
[ AvailTC n [n] []
| tc <- funTyCon : exposedPrimTyCons, let n = tyConName tc ]
+ghcPrimDeclDocs :: DeclDocMap
+ghcPrimDeclDocs = DeclDocMap $ Map.fromList $ mapMaybe findName primOpDocs
+ where
+ names = map idName ghcPrimIds ++
+ map (idName . primOpId) allThePrimOps ++
+ map tyConName (funTyCon : exposedPrimTyCons)
+ findName (nameStr, doc)
+ | Just name <- find ((nameStr ==) . getOccString) names
+ = Just (name, mkHsDocString doc)
+ | otherwise = Nothing
+
{-
************************************************************************
* *
diff --git a/compiler/ghci/ByteCodeAsm.hs b/compiler/GHC/ByteCode/Asm.hs
index aad483c..252e094 100644
--- a/compiler/ghci/ByteCodeAsm.hs
+++ b/compiler/GHC/ByteCode/Asm.hs
@@ -1,11 +1,11 @@
-{-# LANGUAGE BangPatterns, CPP, MagicHash, RecordWildCards #-}
+{-# LANGUAGE BangPatterns, CPP, DeriveFunctor, MagicHash, RecordWildCards #-}
{-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
--
-- (c) The University of Glasgow 2002-2006
--
--- | ByteCodeLink: Bytecode assembler and linker
-module ByteCodeAsm (
+-- | Bytecode assembler and linker
+module GHC.ByteCode.Asm (
assembleBCOs, assembleOneBCO,
bcoFreeNames,
@@ -15,28 +15,28 @@ module ByteCodeAsm (
#include "GhclibHsVersions.h"
-import GhcPrelude
+import GHC.Prelude
-import ByteCodeInstr
-import ByteCodeItbls
-import ByteCodeTypes
+import GHC.ByteCode.Instr
+import GHC.ByteCode.InfoTable
+import GHC.ByteCode.Types
import GHCi.RemoteTypes
-import GHCi
-
-import HscTypes
-import Name
-import NameSet
-import Literal
-import TyCon
-import FastString
-import StgCmmLayout ( ArgRep(..) )
-import SMRep
-import DynFlags
-import Outputable
-import Platform
-import Util
-import Unique
-import UniqDSet
+import GHC.Runtime.Interpreter
+
+import GHC.Driver.Types
+import GHC.Types.Name
+import GHC.Types.Name.Set
+import GHC.Types.Literal
+import GHC.Core.TyCon
+import GHC.Data.FastString
+import GHC.StgToCmm.Layout ( ArgRep(..) )
+import GHC.Runtime.Heap.Layout
+import GHC.Driver.Session
+import GHC.Utils.Outputable
+import GHC.Platform
+import GHC.Utils.Misc
+import GHC.Types.Unique
+import GHC.Types.Unique.DSet
-- From iserv
import SizedSeq
@@ -55,7 +55,7 @@ import Data.Array.Unsafe( castSTUArray )
import Foreign
import Data.Char ( ord )
-import Data.List
+import Data.List ( genericLength )
import Data.Map (Map)
import Data.Maybe (fromMaybe)
import qualified Data.Map as Map
@@ -96,12 +96,12 @@ assembleBCOs
-> IO CompiledByteCode
assembleBCOs hsc_env proto_bcos tycons top_strs modbreaks = do
itblenv <- mkITbls hsc_env tycons
- bcos <- mapM (assembleBCO (hsc_dflags hsc_env)) proto_bcos
+ bcos <- mapM (assembleBCO (targetPlatform (hsc_dflags hsc_env))) proto_bcos
(bcos',ptrs) <- mallocStrings hsc_env bcos
return CompiledByteCode
{ bc_bcos = bcos'
, bc_itbls = itblenv
- , bc_ffis = concat (map protoBCOFFIs proto_bcos)
+ , bc_ffis = concatMap protoBCOFFIs proto_bcos
, bc_strs = top_strs ++ ptrs
, bc_breaks = modbreaks
}
@@ -151,18 +151,18 @@ mallocStrings hsc_env ulbcos = do
assembleOneBCO :: HscEnv -> ProtoBCO Name -> IO UnlinkedBCO
assembleOneBCO hsc_env pbco = do
- ubco <- assembleBCO (hsc_dflags hsc_env) pbco
+ ubco <- assembleBCO (targetPlatform (hsc_dflags hsc_env)) pbco
([ubco'], _ptrs) <- mallocStrings hsc_env [ubco]
return ubco'
-assembleBCO :: DynFlags -> ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO dflags (ProtoBCO { protoBCOName = nm
+assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
+assembleBCO platform (ProtoBCO { protoBCOName = nm
, protoBCOInstrs = instrs
, protoBCOBitmap = bitmap
, protoBCOBitmapSize = bsize
, protoBCOArity = arity }) = do
-- pass 1: collect up the offsets of the local labels.
- let asm = mapM_ (assembleI dflags) instrs
+ let asm = mapM_ (assembleI platform) instrs
initial_offset = 0
@@ -174,9 +174,9 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- and if the final size is indeed small enough for short jumps, we are
-- done. Otherwise, we repeat the calculation, and we force all jumps in
-- this BCO to be long.
- (n_insns0, lbl_map0) = inspectAsm dflags False initial_offset asm
+ (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm
((n_insns, lbl_map), long_jumps)
- | isLarge n_insns0 = (inspectAsm dflags True initial_offset asm, True)
+ | isLarge n_insns0 = (inspectAsm platform True initial_offset asm, True)
| otherwise = ((n_insns0, lbl_map0), False)
env :: Word16 -> Word
@@ -186,7 +186,7 @@ assembleBCO dflags (ProtoBCO { protoBCOName = nm
-- pass 2: run assembler and generate instructions, literals and pointers
let initial_state = (emptySS, emptySS, emptySS)
- (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm dflags long_jumps env asm
+ (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm
-- precomputed size should be equal to final size
ASSERT(n_insns == sizeSS final_insns) return ()
@@ -228,9 +228,7 @@ data Assembler a
| AllocLabel Word16 (Assembler a)
| Emit Word16 [Operand] (Assembler a)
| NullAsm a
-
-instance Functor Assembler where
- fmap = liftM
+ deriving (Functor)
instance Applicative Assembler where
pure = NullAsm
@@ -267,8 +265,8 @@ largeOp long_jumps op = case op of
LabelOp _ -> long_jumps
-- LargeOp _ -> True
-runAsm :: DynFlags -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
-runAsm dflags long_jumps e = go
+runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
+runAsm platform long_jumps e = go
where
go (NullAsm x) = return x
go (AllocPtr p_io k) = do
@@ -291,8 +289,8 @@ runAsm dflags long_jumps e = go
words = concatMap expand ops
expand (SmallOp w) = [w]
expand (LabelOp w) = expand (Op (e w))
- expand (Op w) = if largeOps then largeArg dflags w else [fromIntegral w]
--- expand (LargeOp w) = largeArg dflags w
+ expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w]
+-- expand (LargeOp w) = largeArg platform w
state $ \(st_i0,st_l0,st_p0) ->
let st_i1 = addListToSS st_i0 (opcode : words)
in ((), (st_i1,st_l0,st_p0))
@@ -307,8 +305,8 @@ data InspectState = InspectState
, lblEnv :: LabelEnvMap
}
-inspectAsm :: DynFlags -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
-inspectAsm dflags long_jumps initial_offset
+inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
+inspectAsm platform long_jumps initial_offset
= go (InspectState initial_offset 0 0 Map.empty)
where
go s (NullAsm _) = (instrCount s, lblEnv s)
@@ -325,8 +323,8 @@ inspectAsm dflags long_jumps initial_offset
largeOps = any (largeOp long_jumps) ops
count (SmallOp _) = 1
count (LabelOp _) = count (Op 0)
- count (Op _) = if largeOps then largeArg16s dflags else 1
--- count (LargeOp _) = largeArg16s dflags
+ count (Op _) = if largeOps then largeArg16s platform else 1
+-- count (LargeOp _) = largeArg16s platform
-- Bring in all the bci_ bytecode constants.
#include "rts/Bytecodes.h"
@@ -334,26 +332,24 @@ inspectAsm dflags long_jumps initial_offset
largeArgInstr :: Word16 -> Word16
largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
-largeArg :: DynFlags -> Word -> [Word16]
-largeArg dflags w
- | wORD_SIZE_IN_BITS dflags == 64
- = [fromIntegral (w `shiftR` 48),
- fromIntegral (w `shiftR` 32),
- fromIntegral (w `shiftR` 16),
- fromIntegral w]
- | wORD_SIZE_IN_BITS dflags == 32
- = [fromIntegral (w `shiftR` 16),
- fromIntegral w]
- | otherwise = error "wORD_SIZE_IN_BITS not 32 or 64?"
-
-largeArg16s :: DynFlags -> Word
-largeArg16s dflags | wORD_SIZE_IN_BITS dflags == 64 = 4
- | otherwise = 2
-
-assembleI :: DynFlags
+largeArg :: Platform -> Word -> [Word16]
+largeArg platform w = case platformWordSize platform of
+ PW8 -> [fromIntegral (w `shiftR` 48),
+ fromIntegral (w `shiftR` 32),
+ fromIntegral (w `shiftR` 16),
+ fromIntegral w]
+ PW4 -> [fromIntegral (w `shiftR` 16),
+ fromIntegral w]
+
+largeArg16s :: Platform -> Word
+largeArg16s platform = case platformWordSize platform of
+ PW8 -> 4
+ PW4 -> 2
+
+assembleI :: Platform
-> BCInstr
-> Assembler ()
-assembleI dflags i = case i of
+assembleI platform i = case i of
STKCHECK n -> emit bci_STKCHECK [Op n]
PUSH_L o1 -> emit bci_PUSH_L [SmallOp o1]
PUSH_LL o1 o2 -> emit bci_PUSH_LL [SmallOp o1, SmallOp o2]
@@ -368,14 +364,14 @@ assembleI dflags i = case i of
emit bci_PUSH_G [Op p]
PUSH_PRIMOP op -> do p <- ptr (BCOPtrPrimOp op)
emit bci_PUSH_G [Op p]
- PUSH_BCO proto -> do let ul_bco = assembleBCO dflags proto
+ PUSH_BCO proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit bci_PUSH_G [Op p]
- PUSH_ALTS proto -> do let ul_bco = assembleBCO dflags proto
+ PUSH_ALTS proto -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit bci_PUSH_ALTS [Op p]
PUSH_ALTS_UNLIFTED proto pk
- -> do let ul_bco = assembleBCO dflags proto
+ -> do let ul_bco = assembleBCO platform proto
p <- ioptr (liftM BCOPtrBCO ul_bco)
emit (push_alts pk) [Op p]
PUSH_PAD8 -> emit bci_PUSH_PAD8 []
@@ -446,7 +442,7 @@ assembleI dflags i = case i of
where
literal (LitLabel fs (Just sz) _)
- | platformOS (targetPlatform dflags) == OSMinGW32
+ | platformOS platform == OSMinGW32
= litlabel (appendFS fs (mkFastString ('@':show sz)))
-- On Windows, stdcall labels have a suffix indicating the no. of
-- arg words, e.g. foo@8. testcase: ffi012(ghci)
@@ -457,13 +453,13 @@ assembleI dflags i = case i of
literal (LitChar c) = int (ord c)
literal (LitString bs) = lit [BCONPtrStr bs]
-- LitString requires a zero-terminator when emitted
- literal (LitNumber nt i _) = case nt of
+ literal (LitNumber nt i) = case nt of
LitNumInt -> int (fromIntegral i)
LitNumWord -> int (fromIntegral i)
LitNumInt64 -> int64 (fromIntegral i)
LitNumWord64 -> int64 (fromIntegral i)
- LitNumInteger -> panic "ByteCodeAsm.literal: LitNumInteger"
- LitNumNatural -> panic "ByteCodeAsm.literal: LitNumNatural"
+ LitNumInteger -> panic "GHC.ByteCode.Asm.literal: LitNumInteger"
+ LitNumNatural -> panic "GHC.ByteCode.Asm.literal: LitNumNatural"
-- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most
-- likely to elicit a crash (rather than corrupt memory) in case absence
-- analysis messed up.
@@ -472,9 +468,9 @@ assembleI dflags i = case i of
litlabel fs = lit [BCONPtrLbl fs]
addr (RemotePtr a) = words [fromIntegral a]
float = words . mkLitF
- double = words . mkLitD dflags
+ double = words . mkLitD platform
int = words . mkLitI
- int64 = words . mkLitI64 dflags
+ int64 = words . mkLitI64 platform
words ws = lit (map BCONPtrWord ws)
word w = words [w]
@@ -508,8 +504,8 @@ return_ubx V64 = error "return_ubx: vector"
-- bit pattern is correct for the host's word size and endianness.
mkLitI :: Int -> [Word]
mkLitF :: Float -> [Word]
-mkLitD :: DynFlags -> Double -> [Word]
-mkLitI64 :: DynFlags -> Int64 -> [Word]
+mkLitD :: Platform -> Double -> [Word]
+mkLitI64 :: Platform -> Int64 -> [Word]
mkLitF f
= runST (do
@@ -520,9 +516,8 @@ mkLitF f
return [w0 :: Word]
)
-mkLitD dflags d
- | wORD_SIZE dflags == 4
- = runST (do
+mkLitD platform d = case platformWordSize platform of
+ PW4 -> runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 d
d_arr <- castSTUArray arr
@@ -530,20 +525,16 @@ mkLitD dflags d
w1 <- readArray d_arr 1
return [w0 :: Word, w1]
)
- | wORD_SIZE dflags == 8
- = runST (do
+ PW8 -> runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 d
d_arr <- castSTUArray arr
w0 <- readArray d_arr 0
return [w0 :: Word]
)
- | otherwise
- = panic "mkLitD: Bad wORD_SIZE"
-mkLitI64 dflags ii
- | wORD_SIZE dflags == 4
- = runST (do
+mkLitI64 platform ii = case platformWordSize platform of
+ PW4 -> runST (do
arr <- newArray_ ((0::Int),1)
writeArray arr 0 ii
d_arr <- castSTUArray arr
@@ -551,16 +542,13 @@ mkLitI64 dflags ii
w1 <- readArray d_arr 1
return [w0 :: Word,w1]
)
- | wORD_SIZE dflags == 8
- = runST (do
+ PW8 -> runST (do
arr <- newArray_ ((0::Int),0)
writeArray arr 0 ii
d_arr <- castSTUArray arr
w0 <- readArray d_arr 0
return [w0 :: Word]
)
- | otherwise
- = panic "mkLitI64: Bad wORD_SIZE"
mkLitI i = [fromIntegral i :: Word]
diff --git a/compiler/ghci/ByteCodeItbls.hs b/compiler/GHC/ByteCode/InfoTable.hs
index 76b120c..86ccefc 100644
--- a/compiler/ghci/ByteCodeItbls.hs
+++ b/compiler/GHC/ByteCode/InfoTable.hs
@@ -4,26 +4,30 @@
-- (c) The University of Glasgow 2002-2006
--
--- | ByteCodeItbls: Generate infotables for interpreter-made bytecodes
-module ByteCodeItbls ( mkITbls ) where
+-- | Generate infotables for interpreter-made bytecodes
+module GHC.ByteCode.InfoTable ( mkITbls ) where
#include "GhclibHsVersions.h"
-import GhcPrelude
+import GHC.Prelude
-import ByteCodeTypes
-import GHCi
-import DynFlags
-import HscTypes
-import Name ( Name, getName )
-import NameEnv
-import DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
-import TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
-import RepType
-import StgCmmLayout ( mkVirtConstrSizes )
-import StgCmmClosure ( tagForCon, NonVoid (..) )
-import Util
-import Panic
+import GHC.Platform
+import GHC.Platform.Profile
+
+import GHC.ByteCode.Types
+import GHC.Runtime.Interpreter
+import GHC.Driver.Session
+import GHC.Driver.Types
+import GHC.Types.Name ( Name, getName )
+import GHC.Types.Name.Env
+import GHC.Core.DataCon ( DataCon, dataConRepArgTys, dataConIdentity )
+import GHC.Core.TyCon ( TyCon, tyConFamilySize, isDataTyCon, tyConDataCons )
+import GHC.Core.Multiplicity ( scaledThing )
+import GHC.Types.RepType
+import GHC.StgToCmm.Layout ( mkVirtConstrSizes )
+import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )
+import GHC.Utils.Misc
+import GHC.Utils.Panic
{-
Manufacturing of info tables for DataCons
@@ -52,25 +56,29 @@ make_constr_itbls :: HscEnv -> [DataCon] -> IO ItblEnv
make_constr_itbls hsc_env cons =
mkItblEnv <$> mapM (uncurry mk_itbl) (zip cons [0..])
where
- dflags = hsc_dflags hsc_env
+ profile = targetProfile (hsc_dflags hsc_env)
mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)
mk_itbl dcon conNo = do
let rep_args = [ NonVoid prim_rep
| arg <- dataConRepArgTys dcon
- , prim_rep <- typePrimRep arg ]
+ , prim_rep <- typePrimRep (scaledThing arg) ]
(tot_wds, ptr_wds) =
- mkVirtConstrSizes dflags rep_args
+ mkVirtConstrSizes profile rep_args
ptrs' = ptr_wds
nptrs' = tot_wds - ptr_wds
nptrs_really
- | ptrs' + nptrs' >= mIN_PAYLOAD_SIZE dflags = nptrs'
- | otherwise = mIN_PAYLOAD_SIZE dflags - ptrs'
+ | ptrs' + nptrs' >= pc_MIN_PAYLOAD_SIZE constants = nptrs'
+ | otherwise = pc_MIN_PAYLOAD_SIZE constants - ptrs'
descr = dataConIdentity dcon
- r <- iservCmd hsc_env (MkConInfoTable ptrs' nptrs_really
- conNo (tagForCon dflags dcon) descr)
+ platform = profilePlatform profile
+ constants = platformConstants platform
+ tables_next_to_code = platformTablesNextToCode platform
+
+ r <- iservCmd hsc_env (MkConInfoTable tables_next_to_code ptrs' nptrs_really
+ conNo (tagForCon platform dcon) descr)
return (getName dcon, ItblPtr r)
diff --git a/compiler/ghci/ByteCodeInstr.hs b/compiler/GHC/ByteCode/Instr.hs
index 2e2a6cf..332614c 100644
--- a/compiler/ghci/ByteCodeInstr.hs
+++ b/compiler/GHC/ByteCode/Instr.hs
@@ -4,32 +4,31 @@
-- (c) The University of Glasgow 2002-2006
--
--- | ByteCodeInstrs: Bytecode instruction definitions
-module ByteCodeInstr (
+-- | Bytecode instruction definitions
+module GHC.ByteCode.Instr (
BCInstr(..), ProtoBCO(..), bciStackUse,
) where
#include "GhclibHsVersions.h"
-#include "../includes/MachDeps.h"
-import GhcPrelude
+import GHC.Prelude
-import ByteCodeTypes
+import GHC.ByteCode.Types
import GHCi.RemoteTypes
import GHCi.FFI (C_ffi_cif)
-import StgCmmLayout ( ArgRep(..) )
-import PprCore
-import Outputable
-import FastString
-import Name
-import Unique
-import Id
-import CoreSyn
-import Literal
-import DataCon
-import VarSet
-import PrimOp
-import SMRep
+import GHC.StgToCmm.Layout ( ArgRep(..) )
+import GHC.Core.Ppr
+import GHC.Utils.Outputable
+import GHC.Data.FastString
+import GHC.Types.Name
+import GHC.Types.Unique
+import GHC.Types.Id
+import GHC.Core
+import GHC.Types.Literal
+import GHC.Core.DataCon
+import GHC.Types.Var.Set
+import GHC.Builtin.PrimOps
+import GHC.Runtime.Heap.Layout
import Data.Word
import GHC.Stack.CCS (CostCentre)
@@ -69,7 +68,7 @@ data BCInstr
| PUSH32 !Word16
-- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the
- -- value will take the whole word on the stack (i.e., the stack will gorw by
+ -- value will take the whole word on the stack (i.e., the stack will grow by
-- a word)
-- This is useful when extracting a packed constructor field for further use.
-- Currently we expect all values on the stack to take full words, except for
diff --git a/compiler/ghci/ByteCodeLink.hs b/compiler/GHC/ByteCode/Linker.hs
index 2c2009c..3a1cece 100644
--- a/compiler/ghci/ByteCodeLink.hs
+++ b/compiler/GHC/ByteCode/Linker.hs
@@ -8,8 +8,8 @@
-- (c) The University of Glasgow 2002-2006
--
--- | ByteCodeLink: Bytecode assembler and linker
-module ByteCodeLink (
+-- | Bytecode assembler and linker
+module GHC.ByteCode.Linker (
ClosureEnv, emptyClosureEnv, extendClosureEnv,
linkBCO, lookupStaticPtr,
lookupIE,
@@ -18,24 +18,24 @@ module ByteCodeLink (
#include "GhclibHsVersions.h"
-import GhcPrelude
+import GHC.Prelude
import GHCi.RemoteTypes
import GHCi.ResolvedBCO
import GHCi.BreakArray
import SizedSeq
-import GHCi
-import ByteCodeTypes
-import HscTypes
-import Name
-import NameEnv
-import PrimOp
-import Module
-import FastString
-import Panic
-import Outputable
-import Util
+import GHC.Runtime.Interpreter
+import GHC.ByteCode.Types
+import GHC.Driver.Types
+import GHC.Types.Name
+import GHC.Types.Name.Env
+import GHC.Builtin.PrimOps
+import GHC.Unit
+import GHC.Data.FastString
+import GHC.Utils.Panic
+import GHC.Utils.Outputable
+import GHC.Utils.Misc
-- Standard libraries
import Data.Array.Unboxed
@@ -90,7 +90,7 @@ lookupStaticPtr hsc_env addr_of_label_string = do
m <- lookupSymbol hsc_env addr_of_label_string
case m of
Just ptr -> return ptr
- Nothing -> linkFail "ByteCodeLink: can't find label"
+ Nothing -> linkFail "GHC.ByteCode.Linker: can't find label"
(unpackFS addr_of_label_string)
lookupIE :: HscEnv -> ItblEnv -> Name -> IO (Ptr ())
@@ -108,7 +108,7 @@ lookupIE hsc_env ie con_nm =
n <- lookupSymbol hsc_env sym_to_find2
case n of
Just addr -> return addr
- Nothing -> linkFail "ByteCodeLink.lookupIE"
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupIE"
(unpackFS sym_to_find1 ++ " or " ++
unpackFS sym_to_find2)
@@ -118,7 +118,7 @@ lookupPrimOp hsc_env primop = do
m <- lookupSymbol hsc_env (mkFastString sym_to_find)
case m of
Just p -> return (toRemotePtr p)
- Nothing -> linkFail "ByteCodeLink.lookupCE(primop)" sym_to_find
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
resolvePtr
:: HscEnv -> ItblEnv -> ClosureEnv -> NameEnv Int -> RemoteRef BreakArray
@@ -135,7 +135,7 @@ resolvePtr hsc_env _ie ce bco_ix _ (BCOPtrName nm)
m <- lookupSymbol hsc_env sym_to_find
case m of
Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
- Nothing -> linkFail "ByteCodeLink.lookupCE" (unpackFS sym_to_find)
+ Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
resolvePtr hsc_env _ _ _ _ (BCOPtrPrimOp op) =
ResolvedBCOStaticPtr <$> lookupPrimOp hsc_env op
resolvePtr hsc_env ie ce bco_ix breakarray (BCOPtrBCO bco) =
@@ -154,8 +154,8 @@ linkFail who what
, "the missing library using the -L/path/to/object/dir and -lmissinglibname"
, "flags, or simply by naming the relevant files on the GHCi command line."
, "Alternatively, this link failure might indicate a bug in GHCi."
- , "If you suspect the latter, please send a bug report to:"
- , " glasgow-haskell-bugs@haskell.org"
+ , "If you suspect the latter, please report this as a GHC bug:"
+ , " https://www.haskell.org/ghc/reportabug"
])
@@ -164,18 +164,19 @@ nameToCLabel n suffix = mkFastString label
where
encodeZ = zString . zEncodeFS
(Module pkgKey modName) = ASSERT( isExternalName n ) nameModule n
- packagePart = encodeZ (unitIdFS pkgKey)
+ packagePart = encodeZ (unitFS pkgKey)
modulePart = encodeZ (moduleNameFS modName)
occPart = encodeZ (occNameFS (nameOccName n))
label = concat
- [ if pkgKey == mainUnitId then "" else packagePart ++ "_"
+ [ if pkgKey == mainUnit then "" else packagePart ++ "_"
, modulePart
, '_':occPart
, '_':suffix
]
+-- See Note [Primop wrappers] in GHC.Builtin.PrimOps
primopToCLabel :: PrimOp -> String -> String
primopToCLabel primop suffix = concat
[ "ghczmprim_GHCziPrimopWrappers_"
diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/GHC/Cmm/CallConv.hs
index f338415..09d1d26 100644
--- a/compiler/cmm/CmmCallConv.hs
+++ b/compiler/GHC/Cmm/CallConv.hs
@@ -1,20 +1,21 @@
-module CmmCallConv (
+module GHC.Cmm.CallConv (
ParamLocation(..),
assignArgumentsPos,
assignStack,
realArgRegsCover
) where
-import GhcPrelude
+import GHC.Prelude
-import CmmExpr
-import SMRep
-import Cmm (Convention(..))
-import PprCmm ()
+import GHC.Cmm.Expr
+import GHC.Runtime.Heap.Layout
+import GHC.Cmm (Convention(..))
+import GHC.Cmm.Ppr () -- For Outputable instances
-import DynFlags
-import Platform
-import Outputable
+import GHC.Driver.Session
+import GHC.Platform
+import GHC.Platform.Profile
+import GHC.Utils.Outputable
-- Calculate the 'GlobalReg' or stack locations for function call
-- parameters as used by the Cmm calling convention.
@@ -31,7 +32,7 @@ instance Outputable ParamLocation where
-- Given a list of arguments, and a function that tells their types,
-- return a list showing where each argument is passed
--
-assignArgumentsPos :: DynFlags
+assignArgumentsPos :: Profile
-> ByteOff -- stack offset to start with
-> Convention
-> (a -> CmmType) -- how to get a type from an arg
@@ -41,15 +42,16 @@ assignArgumentsPos :: DynFlags
, [(a, ParamLocation)] -- args and locations
)
-assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
+assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments)
where
+ platform = profilePlatform profile
regs = case (reps, conv) of
- (_, NativeNodeCall) -> getRegsWithNode dflags
- (_, NativeDirectCall) -> getRegsWithoutNode dflags
- ([_], NativeReturn) -> allRegs dflags
- (_, NativeReturn) -> getRegsWithNode dflags
+ (_, NativeNodeCall) -> getRegsWithNode platform
+ (_, NativeDirectCall) -> getRegsWithoutNode platform
+ ([_], NativeReturn) -> allRegs platform
+ (_, NativeReturn) -> getRegsWithNode platform
-- GC calling convention *must* put values in registers
- (_, GC) -> allRegs dflags
+ (_, GC) -> allRegs platform
(_, Slow) -> nodeOnly
-- The calling conventions first assign arguments to registers,
-- then switch to the stack when we first run out of registers
@@ -57,7 +59,7 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
-- different type). When returning an unboxed tuple, we also
-- separate the stack arguments by pointerhood.
(reg_assts, stk_args) = assign_regs [] reps regs
- (stk_off, stk_assts) = assignStack dflags off arg_ty stk_args
+ (stk_off, stk_assts) = assignStack platform off arg_ty stk_args
assignments = reg_assts ++ stk_assts
assign_regs assts [] _ = (assts, [])
@@ -66,11 +68,11 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
| otherwise = int
where vec = case (w, regs) of
(W128, (vs, fs, ds, ls, s:ss))
- | passVectorInReg W128 dflags -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
+ | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), (vs, fs, ds, ls, ss))
(W256, (vs, fs, ds, ls, s:ss))
- | passVectorInReg W256 dflags -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
+ | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), (vs, fs, ds, ls, ss))
(W512, (vs, fs, ds, ls, s:ss))
- | passVectorInReg W512 dflags -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
+ | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), (vs, fs, ds, ls, ss))
_ -> (assts, (r:rs))
float = case (w, regs) of
(W32, (vs, fs, ds, ls, s:ss))
@@ -81,13 +83,12 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
| passFloatInXmm -> k (RegisterParam (DoubleReg s), (vs, fs, ds, ls, ss))
(W64, (vs, fs, d:ds, ls, ss))
| not passFloatInXmm -> k (RegisterParam d, (vs, fs, ds, ls, ss))
- (W80, _) -> panic "F80 unsupported register type"
_ -> (assts, (r:rs))
int = case (w, regs) of
(W128, _) -> panic "W128 unsupported register type"
- (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth dflags)
+ (_, (v:vs, fs, ds, ls, ss)) | widthInBits w <= widthInBits (wordWidth platform)
-> k (RegisterParam (v gcp), (vs, fs, ds, ls, ss))
- (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth dflags)
+ (_, (vs, fs, ds, l:ls, ss)) | widthInBits w > widthInBits (wordWidth platform)
-> k (RegisterParam l, (vs, fs, ds, ls, ss))
_ -> (assts, (r:rs))
k (asst, regs') = assign_regs ((r, asst) : assts) rs regs'
@@ -95,26 +96,27 @@ assignArgumentsPos dflags off conv arg_ty reps = (stk_off, assignments)
w = typeWidth ty
gcp | isGcPtrType ty = VGcPtr
| otherwise = VNonGcPtr
- passFloatInXmm = passFloatArgsInXmm dflags
+ passFloatInXmm = passFloatArgsInXmm platform
-passFloatArgsInXmm :: DynFlags -> Bool
-passFloatArgsInXmm dflags = case platformArch (targetPlatform dflags) of
+passFloatArgsInXmm :: Platform -> Bool
+passFloatArgsInXmm platform = case platformArch platform of
ArchX86_64 -> True
+ ArchX86 -> False
_ -> False
-- We used to spill vector registers to the stack since the LLVM backend didn't
-- support vector registers in its calling convention. However, this has now
-- been fixed. This function remains only as a convenient way to re-enable
-- spilling when debugging code generation.
-passVectorInReg :: Width -> DynFlags -> Bool
+passVectorInReg :: Width -> Profile -> Bool
passVectorInReg _ _ = True
-assignStack :: DynFlags -> ByteOff -> (a -> CmmType) -> [a]
+assignStack :: Platform -> ByteOff -> (a -> CmmType) -> [a]
-> (
ByteOff -- bytes of stack args
, [(a, ParamLocation)] -- args and locations
)
-assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
+assignStack platform offset arg_ty args = assign_stk offset [] (reverse args)
where
assign_stk offset assts [] = (offset, assts)
assign_stk offset assts (r:rs)
@@ -123,7 +125,7 @@ assignStack dflags offset arg_ty args = assign_stk offset [] (reverse args)
off' = offset + size
-- Stack arguments always take a whole number of words, we never
-- pack them unlike constructor fields.
- size = roundUpToWords dflags (widthInBytes w)
+ size = roundUpToWords platform (widthInBytes w)
-----------------------------------------------------------------------------
-- Local information about the registers available
@@ -141,56 +143,57 @@ type AvailRegs = ( [VGcPtr -> GlobalReg] -- available vanilla regs.
-- We take these register supplies from the *real* registers, i.e. those
-- that are guaranteed to map to machine registers.
-getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
-getRegsWithoutNode dflags =
- ( filter (\r -> r VGcPtr /= node) (realVanillaRegs dflags)
- , realFloatRegs dflags
- , realDoubleRegs dflags
- , realLongRegs dflags
- , realXmmRegNos dflags)
+getRegsWithoutNode, getRegsWithNode :: Platform -> AvailRegs
+getRegsWithoutNode platform =
+ ( filter (\r -> r VGcPtr /= node) (realVanillaRegs platform)
+ , realFloatRegs platform
+ , realDoubleRegs platform
+ , realLongRegs platform
+ , realXmmRegNos platform)
-- getRegsWithNode uses R1/node even if it isn't a register
-getRegsWithNode dflags =
- ( if null (realVanillaRegs dflags)
+getRegsWithNode platform =
+ ( if null (realVanillaRegs platform)
then [VanillaReg 1]
- else realVanillaRegs dflags
- , realFloatRegs dflags
- , realDoubleRegs dflags
- , realLongRegs dflags
- , realXmmRegNos dflags)
-
-allFloatRegs, allDoubleRegs, allLongRegs :: DynFlags -> [GlobalReg]
-allVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
-allXmmRegs :: DynFlags -> [Int]
-
-allVanillaRegs dflags = map VanillaReg $ regList (mAX_Vanilla_REG dflags)
-allFloatRegs dflags = map FloatReg $ regList (mAX_Float_REG dflags)
-allDoubleRegs dflags = map DoubleReg $ regList (mAX_Double_REG dflags)
-allLongRegs dflags = map LongReg $ regList (mAX_Long_REG dflags)
-allXmmRegs dflags = regList (mAX_XMM_REG dflags)
-
-realFloatRegs, realDoubleRegs, realLongRegs :: DynFlags -> [GlobalReg]
-realVanillaRegs :: DynFlags -> [VGcPtr -> GlobalReg]
-realXmmRegNos :: DynFlags -> [Int]
-
-realVanillaRegs dflags = map VanillaReg $ regList (mAX_Real_Vanilla_REG dflags)
-realFloatRegs dflags = map FloatReg $ regList (mAX_Real_Float_REG dflags)
-realDoubleRegs dflags = map DoubleReg $ regList (mAX_Real_Double_REG dflags)
-realLongRegs dflags = map LongReg $ regList (mAX_Real_Long_REG dflags)
-
-realXmmRegNos dflags
- | isSse2Enabled dflags = regList (mAX_Real_XMM_REG dflags)
- | otherwise = []
+ else realVanillaRegs platform
+ , realFloatRegs platform
+ , realDoubleRegs platform
+ , realLongRegs platform
+ , realXmmRegNos platform)
+
+allFloatRegs, allDoubleRegs, allLongRegs :: Platform -> [GlobalReg]
+allVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
+allXmmRegs :: Platform -> [Int]
+
+allVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Vanilla_REG (platformConstants platform))
+allFloatRegs platform = map FloatReg $ regList (pc_MAX_Float_REG (platformConstants platform))
+allDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Double_REG (platformConstants platform))
+allLongRegs platform = map LongReg $ regList (pc_MAX_Long_REG (platformConstants platform))
+allXmmRegs platform = regList (pc_MAX_XMM_REG (platformConstants platform))
+
+realFloatRegs, realDoubleRegs, realLongRegs :: Platform -> [GlobalReg]
+realVanillaRegs :: Platform -> [VGcPtr -> GlobalReg]
+
+realVanillaRegs platform = map VanillaReg $ regList (pc_MAX_Real_Vanilla_REG (platformConstants platform))
+realFloatRegs platform = map FloatReg $ regList (pc_MAX_Real_Float_REG (platformConstants platform))
+realDoubleRegs platform = map DoubleReg $ regList (pc_MAX_Real_Double_REG (platformConstants platform))
+realLongRegs platform = map LongReg $ regList (pc_MAX_Real_Long_REG (platformConstants platform))
+
+realXmmRegNos :: Platform -> [Int]
+realXmmRegNos platform
+ | isSse2Enabled platform = regList (pc_MAX_Real_XMM_REG (platformConstants platform))
+ | otherwise = []
regList :: Int -> [Int]
regList n = [1 .. n]
-allRegs :: DynFlags -> AvailRegs
-allRegs dflags = (allVanillaRegs dflags,
- allFloatRegs dflags,
- allDoubleRegs dflags,
- allLongRegs dflags,
- allXmmRegs dflags)
+allRegs :: Platform -> AvailRegs
+allRegs platform = ( allVanillaRegs platform
+ , allFloatRegs platform
+ , allDoubleRegs platform
+ , allLongRegs platform
+ , allXmmRegs platform
+ )
nodeOnly :: AvailRegs
nodeOnly = ([VanillaReg 1], [], [], [], [])
@@ -200,13 +203,18 @@ nodeOnly = ([VanillaReg 1], [], [], [], [])
-- now just x86-64, where Float and Double registers overlap---passing this set
-- of registers is guaranteed to preserve the contents of all live registers. We
-- only use this functionality in hand-written C-- code in the RTS.
-realArgRegsCover :: DynFlags -> [GlobalReg]
-realArgRegsCover dflags
- | passFloatArgsInXmm dflags = map ($VGcPtr) (realVanillaRegs dflags) ++
- realLongRegs dflags ++
- map XmmReg (realXmmRegNos dflags)
- | otherwise = map ($VGcPtr) (realVanillaRegs dflags) ++
- realFloatRegs dflags ++
- realDoubleRegs dflags ++
- realLongRegs dflags ++
- map XmmReg (realXmmRegNos dflags)
+realArgRegsCover :: Platform -> [GlobalReg]
+realArgRegsCover platform
+ | passFloatArgsInXmm platform
+ = map ($VGcPtr) (realVanillaRegs platform) ++
+ realLongRegs platform ++
+ realDoubleRegs platform -- we only need to save the low Double part of XMM registers.
+ -- Moreover, the NCG can't load/store full XMM
+ -- registers for now...
+
+ | otherwise
+ = map ($VGcPtr) (realVanillaRegs platform) ++
+ realFloatRegs platform ++
+ realDoubleRegs platform ++
+ realLongRegs platform
+ -- we don't save XMM registers if they are not used for parameter passing
diff --git a/compiler/cmm/CmmCommonBlockElim.hs b/compiler/GHC/Cmm/CommonBlockElim.hs
index b43d689..cc6cb2d 100644
--- a/compiler/cmm/CmmCommonBlockElim.hs
+++ b/compiler/GHC/Cmm/CommonBlockElim.hs
@@ -1,33 +1,32 @@
{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
-module CmmCommonBlockElim
+module GHC.Cmm.CommonBlockElim
( elimCommonBlocks
)
where
-import GhcPrelude hiding (iterate, succ, unzip, zip)
+import GHC.Prelude hiding (iterate, succ, unzip, zip)
-import BlockId
-import Cmm
-import CmmUtils
-import CmmSwitch (eqSwitchTargetWith)
-import CmmContFlowOpt
--- import PprCmm ()
+import GHC.Cmm.BlockId
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.Switch (eqSwitchTargetWith)
+import GHC.Cmm.ContFlowOpt
-import Hoopl.Block
-import Hoopl.Graph
-import Hoopl.Label
-import Hoopl.Collections
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Dataflow.Collections
import Data.Bits
import Data.Maybe (mapMaybe)
import qualified Data.List as List
import Data.Word
import qualified Data.Map as M
-import Outputable
-import qualified TrieMap as TM
-import UniqFM
-import Unique
+import GHC.Utils.Outputable
+import qualified GHC.Data.TrieMap as TM
+import GHC.Types.Unique.FM
+import GHC.Types.Unique
import Control.Arrow (first, second)
-- -----------------------------------------------------------------------------
@@ -301,7 +300,7 @@ copyTicks env g
foldr blockCons code (map CmmTick ticks)
-- Group by [Label]
--- See Note [Compressed TrieMap] in coreSyn/TrieMap about the usage of GenMap.
+-- See Note [Compressed TrieMap] in GHC.Core.Map about the usage of GenMap.
groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]
groupByLabel =
go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))
diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/GHC/Cmm/ContFlowOpt.hs
index 92dd7ab..73c13d2 100644
--- a/compiler/cmm/CmmContFlowOpt.hs
+++ b/compiler/GHC/Cmm/ContFlowOpt.hs
@@ -1,7 +1,8 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE BangPatterns #-}
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
-module CmmContFlowOpt
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+module GHC.Cmm.ContFlowOpt
( cmmCfgOpts
, cmmCfgOptsProc
, removeUnreachableBlocksProc
@@ -9,19 +10,19 @@ module CmmContFlowOpt
)
where
-import GhcPrelude hiding (succ, unzip, zip)
+import GHC.Prelude hiding (succ, unzip, zip)
-import Hoopl.Block
-import Hoopl.Collections
-import Hoopl.Graph
-import Hoopl.Label
-import BlockId
-import Cmm
-import CmmUtils
-import CmmSwitch (mapSwitchTargets)
-import Maybes
-import Panic
-import Util
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.BlockId
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList)
+import GHC.Data.Maybe
+import GHC.Utils.Panic
+import GHC.Utils.Misc
import Control.Monad
@@ -295,6 +296,13 @@ blockConcat splitting_procs g@CmmGraph { g_entry = entry_id }
, Just cond' <- maybeInvertCmmExpr cond
= CmmCondBranch cond' f t (invertLikeliness l)
+ -- If all jump destinations of a switch go to the
+ -- same target eliminate the switch.
+ | CmmSwitch _expr targets <- shortcut_last
+ , (t:ts) <- switchTargetsToList targets
+ , all (== t) ts
+ = CmmBranch t
+
| otherwise
= shortcut_last
diff --git a/compiler/cmm/Hoopl/Dataflow.hs b/compiler/GHC/Cmm/Dataflow.hs
index bf12b3f..05a91fe 100644
--- a/compiler/cmm/Hoopl/Dataflow.hs
+++ b/compiler/GHC/Cmm/Dataflow.hs
@@ -1,10 +1,10 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
-{-# OPTIONS_GHC -fprof-auto-top #-}
--
-- Copyright (c) 2010, João Dias, Simon Marlow, Simon Peyton Jones,
@@ -17,7 +17,7 @@
-- specialised to the UniqSM monad.
--
-module Hoopl.Dataflow
+module GHC.Cmm.Dataflow
( C, O, Block
, lastNode, entryLabel
, foldNodesBwdOO
@@ -34,22 +34,23 @@ module Hoopl.Dataflow
)
where
-import GhcPrelude
+import GHC.Prelude
-import Cmm
-import UniqSupply
+import GHC.Cmm
+import GHC.Types.Unique.Supply
import Data.Array
import Data.Maybe
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
+import Data.Kind (Type)
-import Hoopl.Block
-import Hoopl.Graph
-import Hoopl.Collections
-import Hoopl.Label
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Label
-type family Fact x f :: *
+type family Fact (x :: Extensibility) f :: Type
type instance Fact C f = FactBase f
type instance Fact O f = f
@@ -106,6 +107,7 @@ analyzeCmm
-> FactBase f
-> FactBase f
analyzeCmm dir lattice transfer cmmGraph initFact =
+ {-# SCC analyzeCmm #-}
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap =
@@ -167,7 +169,7 @@ rewriteCmm
-> CmmGraph
-> FactBase f
-> UniqSM (CmmGraph, FactBase f)
-rewriteCmm dir lattice rwFun cmmGraph initFact = do
+rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do
let entry = g_entry cmmGraph
hooplGraph = g_graph cmmGraph
blockMap1 =
diff --git a/compiler/cmm/Debug.hs b/compiler/GHC/Cmm/DebugBlock.hs
index da37495..fbd64b5 100644
--- a/compiler/cmm/Debug.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -1,4 +1,7 @@
{-# LANGUAGE GADTs #-}
+{-# LANGUAGE MultiWayIf #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
--
@@ -9,9 +12,9 @@
--
-----------------------------------------------------------------------------
-module Debug (
+module GHC.Cmm.DebugBlock (
- DebugBlock(..), dblIsEntry,
+ DebugBlock(..),
cmmDebugGen,
cmmDebugLabels,
cmmDebugLink,
@@ -22,25 +25,25 @@ module Debug (
UnwindExpr(..), toUnwindExpr
) where
-import GhcPrelude
-
-import BlockId
-import CLabel
-import Cmm
-import CmmUtils
-import CoreSyn
-import FastString ( nilFS, mkFastString )
-import Module
-import Outputable
-import PprCore ()
-import PprCmmExpr ( pprExpr )
-import SrcLoc
-import Util ( seqList )
-
-import Hoopl.Block
-import Hoopl.Collections
-import Hoopl.Graph
-import Hoopl.Label
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Core
+import GHC.Data.FastString ( nilFS, mkFastString )
+import GHC.Unit.Module
+import GHC.Utils.Outputable
+import GHC.Cmm.Ppr.Expr ( pprExpr )
+import GHC.Types.SrcLoc
+import GHC.Utils.Misc ( seqList )
+
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
import Data.Maybe
import Data.List ( minimumBy, nubBy )
@@ -59,8 +62,7 @@ data DebugBlock =
, dblParent :: !(Maybe DebugBlock)
-- ^ The parent of this proc. See Note [Splitting DebugBlocks]
, dblTicks :: ![CmmTickish] -- ^ Ticks defined in this block
- , dblSourceTick
- :: !(Maybe CmmTickish) -- ^ Best source tick covering block
+ , dblSourceTick :: !(Maybe CmmTickish) -- ^ Best source tick covering block
, dblPosition :: !(Maybe Int) -- ^ Output position relative to
-- other blocks. @Nothing@ means
-- the block was optimized out
@@ -68,22 +70,19 @@ data DebugBlock =
, dblBlocks :: ![DebugBlock] -- ^ Nested blocks
}
--- | Is this the entry block?
-dblIsEntry :: DebugBlock -> Bool
-dblIsEntry blk = dblProcedure blk == dblLabel blk
-
instance Outputable DebugBlock where
- ppr blk = (if dblProcedure blk == dblLabel blk
- then text "proc "
- else if dblHasInfoTbl blk
- then text "pp-blk "
- else text "blk ") <>
+ ppr blk = (if | dblProcedure blk == dblLabel blk
+ -> text "proc"
+ | dblHasInfoTbl blk
+ -> text "pp-blk"
+ | otherwise
+ -> text "blk") <+>
ppr (dblLabel blk) <+> parens (ppr (dblCLabel blk)) <+>
(maybe empty ppr (dblSourceTick blk)) <+>
(maybe (text "removed") ((text "pos " <>) . ppr)
(dblPosition blk)) <+>
- (ppr (dblUnwind blk)) <+>
- (if null (dblBlocks blk) then empty else ppr (dblBlocks blk))
+ (ppr (dblUnwind blk)) $+$
+ (if null (dblBlocks blk) then empty else nest 4 (ppr (dblBlocks blk)))
-- | Intermediate data structure holding debug-relevant context information
-- about a block.
@@ -163,7 +162,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
= DebugBlock { dblProcedure = g_entry graph
, dblLabel = label
, dblCLabel = case info of
- Just (Statics infoLbl _) -> infoLbl
+ Just (CmmStaticsRaw infoLbl _) -> infoLbl
Nothing
| g_entry graph == label -> entryLbl
| otherwise -> blockLbl label
@@ -320,7 +319,7 @@ with a typical C-- procedure as would come from the STG-to-Cmm code generator,
},
Let's consider how this procedure will be decorated with unwind information
-(largely by CmmLayoutStack). Naturally, when we enter the procedure `entry` the
+(largely by GHC.Cmm.LayoutStack). Naturally, when we enter the procedure `entry` the
value of Sp is no different from what it was at its call site. Therefore we will
add an `unwind` statement saying this at the beginning of its unwind-annotated
code,
@@ -369,11 +368,11 @@ The remaining blocks are simple,
The flow of unwinding information through the compiler is a bit convoluted:
- * C-- begins life in StgCmm without any unwind information. This is because we
+ * C-- begins life in StgToCmm without any unwind information. This is because we
haven't actually done any register assignment or stack layout yet, so there
is no need for unwind information.
- * CmmLayoutStack figures out how to layout each procedure's stack, and produces
+ * GHC.Cmm.LayoutStack figures out how to layout each procedure's stack, and produces
appropriate unwinding nodes for each adjustment of the STG Sp register.
* The unwind nodes are carried through the sinking pass. Currently this is
@@ -396,7 +395,7 @@ The flow of unwinding information through the compiler is a bit convoluted:
(by the Dwarf module) and emitted in the final object.
See also:
- Note [Unwinding information in the NCG] in AsmCodeGen,
+ Note [Unwinding information in the NCG] in "GHC.CmmToAsm",
Note [Unwind pseudo-instruction in Cmm],
Note [Debugging DWARF unwinding info].
@@ -461,7 +460,7 @@ symbols for gdb if you obtain it through a package manager.
Keep in mind that the current release of GDB has an instruction pointer handling
heuristic that works well for C-like languages, but doesn't always work for
-Haskell. See Note [Info Offset] in Dwarf.Types for more details.
+Haskell. See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types" for more details.
Note [Unwind pseudo-instruction in Cmm]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -527,14 +526,14 @@ instance Outputable UnwindExpr where
-- | Conversion of Cmm expressions to unwind expressions. We check for
-- unsupported operator usages and simplify the expression as far as
-- possible.
-toUnwindExpr :: CmmExpr -> UnwindExpr
-toUnwindExpr (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
-toUnwindExpr (CmmLit (CmmLabel l)) = UwLabel l
-toUnwindExpr (CmmRegOff (CmmGlobal g) i) = UwReg g i
-toUnwindExpr (CmmReg (CmmGlobal g)) = UwReg g 0
-toUnwindExpr (CmmLoad e _) = UwDeref (toUnwindExpr e)
-toUnwindExpr e@(CmmMachOp op [e1, e2]) =
- case (op, toUnwindExpr e1, toUnwindExpr e2) of
+toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
+toUnwindExpr _ (CmmLit (CmmInt i _)) = UwConst (fromIntegral i)
+toUnwindExpr _ (CmmLit (CmmLabel l)) = UwLabel l
+toUnwindExpr _ (CmmRegOff (CmmGlobal g) i) = UwReg g i
+toUnwindExpr _ (CmmReg (CmmGlobal g)) = UwReg g 0
+toUnwindExpr platform (CmmLoad e _) = UwDeref (toUnwindExpr platform e)
+toUnwindExpr platform e@(CmmMachOp op [e1, e2]) =
+ case (op, toUnwindExpr platform e1, toUnwindExpr platform e2) of
(MO_Add{}, UwReg r x, UwConst y) -> UwReg r (x + y)
(MO_Sub{}, UwReg r x, UwConst y) -> UwReg r (x - y)
(MO_Add{}, UwConst x, UwReg r y) -> UwReg r (x + y)
@@ -545,6 +544,6 @@ toUnwindExpr e@(CmmMachOp op [e1, e2]) =
(MO_Sub{}, u1, u2 ) -> UwMinus u1 u2
(MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
_otherwise -> pprPanic "Unsupported operator in unwind expression!"
- (pprExpr e)
-toUnwindExpr e
+ (pprExpr platform e)
+toUnwindExpr _ e
= pprPanic "Unsupported unwind expression!" (ppr e)
diff --git a/compiler/cmm/MkGraph.hs b/compiler/GHC/Cmm/Graph.hs
index 2963951..be7eafb 100644
--- a/compiler/cmm/MkGraph.hs
+++ b/compiler/GHC/Cmm/Graph.hs
@@ -1,6 +1,6 @@
{-# LANGUAGE BangPatterns, GADTs #-}
-module MkGraph
+module GHC.Cmm.Graph
( CmmAGraph, CmmAGraphScoped, CgStmt(..)
, (<*>), catAGraphs
, mkLabel, mkMiddle, mkLast, outOfLine
@@ -21,24 +21,25 @@ module MkGraph
)
where
-import GhcPrelude hiding ( (<*>) ) -- avoid importing (<*>)
+import GHC.Prelude hiding ( (<*>) ) -- avoid importing (<*>)
-import BlockId
-import Cmm
-import CmmCallConv
-import CmmSwitch (SwitchTargets)
+import GHC.Platform.Profile
-import Hoopl.Block
-import Hoopl.Graph
-import Hoopl.Label
-import DynFlags
-import FastString
-import ForeignCall
-import OrdList
-import SMRep (ByteOff)
-import UniqSupply
-import Util
-import Panic
+import GHC.Cmm.BlockId
+import GHC.Cmm
+import GHC.Cmm.CallConv
+import GHC.Cmm.Switch (SwitchTargets)
+
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Data.FastString
+import GHC.Types.ForeignCall
+import GHC.Data.OrdList
+import GHC.Runtime.Heap.Layout (ByteOff)
+import GHC.Types.Unique.Supply
+import GHC.Utils.Misc
+import GHC.Utils.Panic
-----------------------------------------------------------------------------
@@ -196,28 +197,28 @@ mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
mkStore l r = mkMiddle $ CmmStore l r
---------- Control transfer
-mkJump :: DynFlags -> Convention -> CmmExpr
+mkJump :: Profile -> Convention -> CmmExpr
-> [CmmExpr]
-> UpdFrameOffset
-> CmmAGraph
-mkJump dflags conv e actuals updfr_off =
- lastWithArgs dflags Jump Old conv actuals updfr_off $
+mkJump profile conv e actuals updfr_off =
+ lastWithArgs profile Jump Old conv actuals updfr_off $
toCall e Nothing updfr_off 0
-- | A jump where the caller says what the live GlobalRegs are. Used
-- for low-level hand-written Cmm.
-mkRawJump :: DynFlags -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
+mkRawJump :: Profile -> CmmExpr -> UpdFrameOffset -> [GlobalReg]
-> CmmAGraph
-mkRawJump dflags e updfr_off vols =
- lastWithArgs dflags Jump Old NativeNodeCall [] updfr_off $
+mkRawJump profile e updfr_off vols =
+ lastWithArgs profile Jump Old NativeNodeCall [] updfr_off $
\arg_space _ -> toCall e Nothing updfr_off 0 arg_space vols
-mkJumpExtra :: DynFlags -> Convention -> CmmExpr -> [CmmExpr]
+mkJumpExtra :: Profile -> Convention -> CmmExpr -> [CmmExpr]
-> UpdFrameOffset -> [CmmExpr]
-> CmmAGraph
-mkJumpExtra dflags conv e actuals updfr_off extra_stack =
- lastWithArgsAndExtraStack dflags Jump Old conv actuals updfr_off extra_stack $
+mkJumpExtra profile conv e actuals updfr_off extra_stack =
+ lastWithArgsAndExtraStack profile Jump Old conv actuals updfr_off extra_stack $
toCall e Nothing updfr_off 0
mkCbranch :: CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
@@ -227,42 +228,42 @@ mkCbranch pred ifso ifnot likely =
mkSwitch :: CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch e tbl = mkLast $ CmmSwitch e tbl
-mkReturn :: DynFlags -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
+mkReturn :: Profile -> CmmExpr -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph
-mkReturn dflags e actuals updfr_off =
- lastWithArgs dflags Ret Old NativeReturn actuals updfr_off $
+mkReturn profile e actuals updfr_off =
+ lastWithArgs profile Ret Old NativeReturn actuals updfr_off $
toCall e Nothing updfr_off 0
mkBranch :: BlockId -> CmmAGraph
mkBranch bid = mkLast (CmmBranch bid)
-mkFinalCall :: DynFlags
+mkFinalCall :: Profile
-> CmmExpr -> CCallConv -> [CmmExpr] -> UpdFrameOffset
-> CmmAGraph
-mkFinalCall dflags f _ actuals updfr_off =
- lastWithArgs dflags Call Old NativeDirectCall actuals updfr_off $
+mkFinalCall profile f _ actuals updfr_off =
+ lastWithArgs profile Call Old NativeDirectCall actuals updfr_off $
toCall f Nothing updfr_off 0
-mkCallReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
+mkCallReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> [CmmExpr]
-> CmmAGraph
-mkCallReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
- lastWithArgsAndExtraStack dflags Call (Young ret_lbl) callConv actuals
+mkCallReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off extra_stack = do
+ lastWithArgsAndExtraStack profile Call (Young ret_lbl) callConv actuals
updfr_off extra_stack $
toCall f (Just ret_lbl) updfr_off ret_off
-- Like mkCallReturnsTo, but does not push the return address (it is assumed to be
-- already on the stack).
-mkJumpReturnsTo :: DynFlags -> CmmExpr -> Convention -> [CmmExpr]
+mkJumpReturnsTo :: Profile -> CmmExpr -> Convention -> [CmmExpr]
-> BlockId
-> ByteOff
-> UpdFrameOffset
-> CmmAGraph
-mkJumpReturnsTo dflags f callConv actuals ret_lbl ret_off updfr_off = do
- lastWithArgs dflags JumpRet (Young ret_lbl) callConv actuals updfr_off $
+mkJumpReturnsTo profile f callConv actuals ret_lbl ret_off updfr_off = do
+ lastWithArgs profile JumpRet (Young ret_lbl) callConv actuals updfr_off $
toCall f (Just ret_lbl) updfr_off ret_off
mkUnsafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> CmmAGraph
@@ -292,33 +293,34 @@ stackStubExpr w = CmmLit (CmmInt 0 w)
-- variables in their spill slots. Therefore, for copying arguments
-- and results, we provide different functions to pass the arguments
-- in an overflow area and to pass them in spill slots.
-copyInOflow :: DynFlags -> Convention -> Area
+copyInOflow :: Profile -> Convention -> Area
-> [CmmFormal]
-> [CmmFormal]
-> (Int, [GlobalReg], CmmAGraph)
-copyInOflow dflags conv area formals extra_stk
+copyInOflow profile conv area formals extra_stk
= (offset, gregs, catAGraphs $ map mkMiddle nodes)
- where (offset, gregs, nodes) = copyIn dflags conv area formals extra_stk
+ where (offset, gregs, nodes) = copyIn profile conv area formals extra_stk
-- Return the number of bytes used for copying arguments, as well as the
-- instructions to copy the arguments.
-copyIn :: DynFlags -> Convention -> Area
+copyIn :: Profile -> Convention -> Area
-> [CmmFormal]
-> [CmmFormal]
-> (ByteOff, [GlobalReg], [CmmNode O O])
-copyIn dflags conv area formals extra_stk
+copyIn profile conv area formals extra_stk
= (stk_size, [r | (_, RegisterParam r) <- args], map ci (stk_args ++ args))
where
+ platform = profilePlatform profile
-- See Note [Width of parameters]
ci (reg, RegisterParam r@(VanillaReg {})) =
let local = CmmLocal reg
global = CmmReg (CmmGlobal r)
- width = cmmRegWidth dflags local
+ width = cmmRegWidth platform local
expr
- | width == wordWidth dflags = global
- | width < wordWidth dflags =
- CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [global]
+ | width == wordWidth platform = global
+ | width < wordWidth platform =
+ CmmMachOp (MO_XX_Conv (wordWidth platform) width) [global]
| otherwise = panic "Parameter width greater than word width"
in CmmAssign local expr
@@ -329,23 +331,23 @@ copyIn dflags conv area formals extra_stk
ci (reg, StackParam off)
| isBitsType $ localRegType reg
- , typeWidth (localRegType reg) < wordWidth dflags =
+ , typeWidth (localRegType reg) < wordWidth platform =
let
- stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth dflags))
+ stack_slot = (CmmLoad (CmmStackSlot area off) (cmmBits $ wordWidth platform))
local = CmmLocal reg
- width = cmmRegWidth dflags local
- expr = CmmMachOp (MO_XX_Conv (wordWidth dflags) width) [stack_slot]
- in CmmAssign local expr
-
+ width = cmmRegWidth platform local
+ expr = CmmMachOp (MO_XX_Conv (wordWidth platform) width) [stack_slot]
+ in CmmAssign local expr
+
| otherwise =
CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty)
where ty = localRegType reg
- init_offset = widthInBytes (wordWidth dflags) -- infotable
+ init_offset = widthInBytes (wordWidth platform) -- infotable
- (stk_off, stk_args) = assignStack dflags init_offset localRegType extra_stk
+ (stk_off, stk_args) = assignStack platform init_offset localRegType extra_stk
- (stk_size, args) = assignArgumentsPos dflags stk_off conv
+ (stk_size, args) = assignArgumentsPos profile stk_off conv
localRegType formals
-- Factoring out the common parts of the copyout functions yielded something
@@ -353,7 +355,7 @@ copyIn dflags conv area formals extra_stk
data Transfer = Call | JumpRet | Jump | Ret deriving Eq
-copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
+copyOutOflow :: Profile -> Convention -> Transfer -> Area -> [CmmExpr]
-> UpdFrameOffset
-> [CmmExpr] -- extra stack args
-> (Int, [GlobalReg], CmmAGraph)
@@ -367,18 +369,19 @@ copyOutOflow :: DynFlags -> Convention -> Transfer -> Area -> [CmmExpr]
-- the info table for return and adjust the offsets of the other
-- parameters. If this is a call instruction, we adjust the offsets
-- of the other parameters.
-copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
+copyOutOflow profile conv transfer area actuals updfr_off extra_stack_stuff
= (stk_size, regs, graph)
where
+ platform = profilePlatform profile
(regs, graph) = foldr co ([], mkNop) (setRA ++ args ++ stack_params)
-- See Note [Width of parameters]
co (v, RegisterParam r@(VanillaReg {})) (rs, ms) =
- let width = cmmExprWidth dflags v
+ let width = cmmExprWidth platform v
value
- | width == wordWidth dflags = v
- | width < wordWidth dflags =
- CmmMachOp (MO_XX_Conv width (wordWidth dflags)) [v]
+ | width == wordWidth platform = v
+ | width < wordWidth platform =
+ CmmMachOp (MO_XX_Conv width (wordWidth platform)) [v]
| otherwise = panic "Parameter width greater than word width"
in (r:rs, mkAssign (CmmGlobal r) value <*> ms)
@@ -391,11 +394,11 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
co (v, StackParam off) (rs, ms)
= (rs, mkStore (CmmStackSlot area off) (value v) <*> ms)
- width v = cmmExprWidth dflags v
+ width v = cmmExprWidth platform v
value v
- | isBitsType $ cmmExprType dflags v
- , width v < wordWidth dflags =
- CmmMachOp (MO_XX_Conv (width v) (wordWidth dflags)) [v]
+ | isBitsType $ cmmExprType platform v
+ , width v < wordWidth platform =
+ CmmMachOp (MO_XX_Conv (width v) (wordWidth platform)) [v]
| otherwise = v
(setRA, init_offset) =
@@ -405,20 +408,20 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
case transfer of
Call ->
([(CmmLit (CmmBlock id), StackParam init_offset)],
- widthInBytes (wordWidth dflags))
+ widthInBytes (wordWidth platform))
JumpRet ->
([],
- widthInBytes (wordWidth dflags))
+ widthInBytes (wordWidth platform))
_other ->
([], 0)
Old -> ([], updfr_off)
(extra_stack_off, stack_params) =
- assignStack dflags init_offset (cmmExprType dflags) extra_stack_stuff
+ assignStack platform init_offset (cmmExprType platform) extra_stack_stuff
args :: [(CmmExpr, ParamLocation)] -- The argument and where to put it
- (stk_size, args) = assignArgumentsPos dflags extra_stack_off conv
- (cmmExprType dflags) actuals
+ (stk_size, args) = assignArgumentsPos profile extra_stack_off conv
+ (cmmExprType platform) actuals
-- Note [Width of parameters]
@@ -448,29 +451,29 @@ copyOutOflow dflags conv transfer area actuals updfr_off extra_stack_stuff
-- https://github.com/ghc-proposals/ghc-proposals/pull/74
-mkCallEntry :: DynFlags -> Convention -> [CmmFormal] -> [CmmFormal]
+mkCallEntry :: Profile -> Convention -> [CmmFormal] -> [CmmFormal]
-> (Int, [GlobalReg], CmmAGraph)
-mkCallEntry dflags conv formals extra_stk
- = copyInOflow dflags conv Old formals extra_stk
+mkCallEntry profile conv formals extra_stk
+ = copyInOflow profile conv Old formals extra_stk
-lastWithArgs :: DynFlags -> Transfer -> Area -> Convention -> [CmmExpr]
+lastWithArgs :: Profile -> Transfer -> Area -> Convention -> [CmmExpr]
-> UpdFrameOffset
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
-lastWithArgs dflags transfer area conv actuals updfr_off last =
- lastWithArgsAndExtraStack dflags transfer area conv actuals
+lastWithArgs profile transfer area conv actuals updfr_off last =
+ lastWithArgsAndExtraStack profile transfer area conv actuals
updfr_off noExtraStack last
-lastWithArgsAndExtraStack :: DynFlags
+lastWithArgsAndExtraStack :: Profile
-> Transfer -> Area -> Convention -> [CmmExpr]
-> UpdFrameOffset -> [CmmExpr]
-> (ByteOff -> [GlobalReg] -> CmmAGraph)
-> CmmAGraph
-lastWithArgsAndExtraStack dflags transfer area conv actuals updfr_off
+lastWithArgsAndExtraStack profile transfer area conv actuals updfr_off
extra_stack last =
copies <*> last outArgs regs
where
- (outArgs, regs, copies) = copyOutOflow dflags conv transfer area actuals
+ (outArgs, regs, copies) = copyOutOflow profile conv transfer area actuals
updfr_off extra_stack
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/GHC/Cmm/Info.hs
index 6b8ee07..d67e905 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/GHC/Cmm/Info.hs
@@ -1,11 +1,11 @@
{-# LANGUAGE CPP #-}
-module CmmInfo (
+module GHC.Cmm.Info (
mkEmptyContInfoTable,
cmmToRawCmm,
- mkInfoTable,
srtEscape,
-- info table accessors
+ PtrOpts (..),
closureInfoPtr,
entryCode,
getConstrTag,
@@ -34,28 +34,30 @@ module CmmInfo (
#include "GhclibHsVersions.h"
-import GhcPrelude
-
-import Cmm
-import CmmUtils
-import CLabel
-import SMRep
-import Bitmap
-import Stream (Stream)
-import qualified Stream
-import Hoopl.Collections
-
-import Platform
-import Maybes
-import DynFlags
-import Panic
-import UniqSupply
-import MonadUtils
-import Util
-import Outputable
-
+import GHC.Prelude
+
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.CLabel
+import GHC.Runtime.Heap.Layout
+import GHC.Data.Bitmap
+import GHC.Data.Stream (Stream)
+import qualified GHC.Data.Stream as Stream
+import GHC.Cmm.Dataflow.Collections
+
+import GHC.Platform
+import GHC.Platform.Profile
+import GHC.Data.Maybe
+import GHC.Driver.Session
+import GHC.Utils.Error (withTimingSilent)
+import GHC.Utils.Panic
+import GHC.Types.Unique.Supply
+import GHC.Utils.Monad
+import GHC.Utils.Misc
+import GHC.Utils.Outputable
+
+import Data.ByteString (ByteString)
import Data.Bits
-import Data.Word
-- When we split at proc points, we need an empty info table.
mkEmptyContInfoTable :: CLabel -> CmmInfoTable
@@ -66,17 +68,23 @@ mkEmptyContInfoTable info_lbl
, cit_srt = Nothing
, cit_clo = Nothing }
-cmmToRawCmm :: DynFlags -> Stream IO CmmGroup ()
- -> IO (Stream IO RawCmmGroup ())
+cmmToRawCmm :: DynFlags -> Stream IO CmmGroupSRTs a
+ -> IO (Stream IO RawCmmGroup a)
cmmToRawCmm dflags cmms
= do { uniqs <- mkSplitUniqSupply 'i'
- ; let do_one uniqs cmm = do
- case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
- (b,uniqs') -> return (uniqs',b)
- -- NB. strictness fixes a space leak. DO NOT REMOVE.
- ; return (Stream.mapAccumL do_one uniqs cmms >> return ())
+ ; let do_one :: UniqSupply -> [CmmDeclSRTs] -> IO (UniqSupply, [RawCmmDecl])
+ do_one uniqs cmm =
+ -- NB. strictness fixes a space leak. DO NOT REMOVE.
+ withTimingSilent dflags (text "Cmm -> Raw Cmm")
+ forceRes $
+ case initUs uniqs $ concatMapM (mkInfoTable dflags) cmm of
+ (b,uniqs') -> return (uniqs',b)
+ ; return (snd <$> Stream.mapAccumL_ do_one uniqs cmms)
}
+ where forceRes (uniqs, rawcmms) =
+ uniqs `seq` foldr (\decl r -> decl `seq` r) () rawcmms
+
-- Make a concrete info table, represented as a list of CmmStatic
-- (it can't be simply a list of Word, because the SRT field is
-- represented by a label+offset expression).
@@ -110,16 +118,15 @@ cmmToRawCmm dflags cmms
--
-- * The SRT slot is only there if there is SRT info to record
-mkInfoTable :: DynFlags -> CmmDecl -> UniqSM [RawCmmDecl]
-mkInfoTable _ (CmmData sec dat)
- = return [CmmData sec dat]
+mkInfoTable :: DynFlags -> CmmDeclSRTs -> UniqSM [RawCmmDecl]
+mkInfoTable _ (CmmData sec dat) = return [CmmData sec dat]
mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
--
-- in the non-tables-next-to-code case, procs can have at most a
-- single info table associated with the entry label of the proc.
--
- | not (tablesNextToCode dflags)
+ | not (platformTablesNextToCode (targetPlatform dflags))
= case topInfoTable proc of -- must be at most one
-- no info table
Nothing ->
@@ -129,8 +136,8 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
(top_decls, (std_info, extra_bits)) <-
mkInfoTableContents dflags info Nothing
let
- rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
- rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+ rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info
+ rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits
--
-- Separately emit info table (with the function entry
-- point as first entry) and the entry code
@@ -154,15 +161,16 @@ mkInfoTable dflags proc@(CmmProc infos entry_lbl live blocks)
[CmmProc (mapFromList raw_infos) entry_lbl live blocks])
where
+ platform = targetPlatform dflags
do_one_info (lbl,itbl) = do
(top_decls, (std_info, extra_bits)) <-
mkInfoTableContents dflags itbl Nothing
let
info_lbl = cit_lbl itbl
- rel_std_info = map (makeRelativeRefTo dflags info_lbl) std_info
- rel_extra_bits = map (makeRelativeRefTo dflags info_lbl) extra_bits
+ rel_std_info = map (makeRelativeRefTo platform info_lbl) std_info
+ rel_extra_bits = map (makeRelativeRefTo platform info_lbl) extra_bits
--
- return (top_decls, (lbl, Statics info_lbl $ map CmmStaticLit $
+ return (top_decls, (lbl, CmmStaticsRaw info_lbl $ map CmmStaticLit $
reverse rel_extra_bits ++ rel_std_info))
-----------------------------------------------------
@@ -189,8 +197,8 @@ mkInfoTableContents dflags
-- (which in turn came from a handwritten .cmm file)
| StackRep frame <- smrep
- = do { (prof_lits, prof_data) <- mkProfLits dflags prof
- ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
+ = do { (prof_lits, prof_data) <- mkProfLits platform prof
+ ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
; (liveness_lit, liveness_data) <- mkLivenessBits dflags frame
; let
std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit
@@ -201,9 +209,9 @@ mkInfoTableContents dflags
; return (prof_data ++ liveness_data, (std_info, srt_label)) }
| HeapRep _ ptrs nonptrs closure_type <- smrep
- = do { let layout = packIntsCLit dflags ptrs nonptrs
- ; (prof_lits, prof_data) <- mkProfLits dflags prof
- ; let (srt_label, srt_bitmap) = mkSRTLit dflags info_lbl srt
+ = do { let layout = packIntsCLit platform ptrs nonptrs
+ ; (prof_lits, prof_data) <- mkProfLits platform prof
+ ; let (srt_label, srt_bitmap) = mkSRTLit platform info_lbl srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label
; let std_info = mkStdInfoTable dflags prof_lits
@@ -212,6 +220,7 @@ mkInfoTableContents dflags
(mb_layout `orElse` layout)
; return (prof_data ++ ct_data, (std_info, extra_bits)) }
where
+ platform = targetPlatform dflags
mk_pieces :: ClosureTypeInfo -> [CmmLit]
-> UniqSM ( Maybe CmmLit -- Override the SRT field with this
, Maybe CmmLit -- Override the layout field with this
@@ -220,64 +229,64 @@ mkInfoTableContents dflags
mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor
= do { (descr_lit, decl) <- newStringLit con_descr
; return ( Just (CmmInt (fromIntegral con_tag)
- (halfWordWidth dflags))
+ (halfWordWidth platform))
, Nothing, [descr_lit], [decl]) }
mk_pieces Thunk srt_label
= return (Nothing, Nothing, srt_label, [])
mk_pieces (ThunkSelector offset) _no_srt
- = return (Just (CmmInt 0 (halfWordWidth dflags)),
- Just (mkWordCLit dflags (fromIntegral offset)), [], [])
+ = return (Just (CmmInt 0 (halfWordWidth platform)),
+ Just (mkWordCLit platform (fromIntegral offset)), [], [])
-- Layout known (one free var); we use the layout field for offset
mk_pieces (Fun arity (ArgSpec fun_type)) srt_label
- = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label
+ = do { let extra_bits = packIntsCLit platform fun_type arity : srt_label
; return (Nothing, Nothing, extra_bits, []) }
mk_pieces (Fun arity (ArgGen arg_bits)) srt_label
= do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits
; let fun_type | null liveness_data = aRG_GEN
| otherwise = aRG_GEN_BIG
- extra_bits = [ packIntsCLit dflags fun_type arity ]
- ++ (if inlineSRT dflags then [] else [ srt_lit ])
+ extra_bits = [ packIntsCLit platform fun_type arity ]
+ ++ (if inlineSRT platform then [] else [ srt_lit ])
++ [ liveness_lit, slow_entry ]
; return (Nothing, Nothing, extra_bits, liveness_data) }
where
- slow_entry = CmmLabel (toSlowEntryLbl info_lbl)
+ slow_entry = CmmLabel (toSlowEntryLbl platform info_lbl)
srt_lit = case srt_label of
- [] -> mkIntCLit dflags 0
+ [] -> mkIntCLit platform 0
(lit:_rest) -> ASSERT( null _rest ) lit
mk_pieces other _ = pprPanic "mk_pieces" (ppr other)
mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
-packIntsCLit :: DynFlags -> Int -> Int -> CmmLit
-packIntsCLit dflags a b = packHalfWordsCLit dflags
- (toStgHalfWord dflags (fromIntegral a))
- (toStgHalfWord dflags (fromIntegral b))
+packIntsCLit :: Platform -> Int -> Int -> CmmLit
+packIntsCLit platform a b = packHalfWordsCLit platform
+ (toStgHalfWord platform (fromIntegral a))
+ (toStgHalfWord platform (fromIntegral b))
-mkSRTLit :: DynFlags
+mkSRTLit :: Platform
-> CLabel
-> Maybe CLabel
-> ([CmmLit], -- srt_label, if any
CmmLit) -- srt_bitmap
-mkSRTLit dflags info_lbl (Just lbl)
- | inlineSRT dflags
- = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth dflags))
-mkSRTLit dflags _ Nothing = ([], CmmInt 0 (halfWordWidth dflags))
-mkSRTLit dflags _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth dflags))
+mkSRTLit platform info_lbl (Just lbl)
+ | inlineSRT platform
+ = ([], CmmLabelDiffOff lbl info_lbl 0 (halfWordWidth platform))
+mkSRTLit platform _ Nothing = ([], CmmInt 0 (halfWordWidth platform))
+mkSRTLit platform _ (Just lbl) = ([CmmLabel lbl], CmmInt 1 (halfWordWidth platform))
-- | Is the SRT offset field inline in the info table on this platform?
--
-- See the section "Referring to an SRT from the info table" in
--- Note [SRTs] in CmmBuildInfoTables.hs
-inlineSRT :: DynFlags -> Bool
-inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64
- && tablesNextToCode dflags
+-- Note [SRTs] in "GHC.Cmm.Info.Build"
+inlineSRT :: Platform -> Bool
+inlineSRT platform = platformArch platform == ArchX86_64
+ && platformTablesNextToCode platform
-------------------------------------------------------------------------
--
@@ -305,16 +314,14 @@ inlineSRT dflags = platformArch (targetPlatform dflags) == ArchX86_64
-- Note that this is done even when the -fPIC flag is not specified,
-- as we want to keep binary compatibility between PIC and non-PIC.
-makeRelativeRefTo :: DynFlags -> CLabel -> CmmLit -> CmmLit
-
-makeRelativeRefTo dflags info_lbl (CmmLabel lbl)
- | tablesNextToCode dflags
- = CmmLabelDiffOff lbl info_lbl 0 (wordWidth dflags)
-makeRelativeRefTo dflags info_lbl (CmmLabelOff lbl off)
- | tablesNextToCode dflags
- = CmmLabelDiffOff lbl info_lbl off (wordWidth dflags)
-makeRelativeRefTo _ _ lit = lit
-
+makeRelativeRefTo :: Platform -> CLabel -> CmmLit -> CmmLit
+makeRelativeRefTo platform info_lbl lit
+ = if platformTablesNextToCode platform
+ then case lit of
+ CmmLabel lbl -> CmmLabelDiffOff lbl info_lbl 0 (wordWidth platform)
+ CmmLabelOff lbl off -> CmmLabelDiffOff lbl info_lbl off (wordWidth platform)
+ _ -> lit
+ else lit
-------------------------------------------------------------------------
--
@@ -342,29 +349,30 @@ mkLivenessBits :: DynFlags -> Liveness -> UniqSM (CmmLit, [RawCmmDecl])
-- 2. Large bitmap CmmData if needed
mkLivenessBits dflags liveness
- | n_bits > mAX_SMALL_BITMAP_SIZE dflags -- does not fit in one word
+ | n_bits > mAX_SMALL_BITMAP_SIZE platform -- does not fit in one word
= do { uniq <- getUniqueM
; let bitmap_lbl = mkBitmapLabel uniq
; return (CmmLabel bitmap_lbl,
[mkRODataLits bitmap_lbl lits]) }
| otherwise -- Fits in one word
- = return (mkStgWordCLit dflags bitmap_word, [])
+ = return (mkStgWordCLit platform bitmap_word, [])
where
+ platform = targetPlatform dflags
n_bits = length liveness
bitmap :: Bitmap
- bitmap = mkBitmap dflags liveness
+ bitmap = mkBitmap platform liveness
small_bitmap = case bitmap of
- [] -> toStgWord dflags 0
+ [] -> toStgWord platform 0
[b] -> b
_ -> panic "mkLiveness"
- bitmap_word = toStgWord dflags (fromIntegral n_bits)
- .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags)
+ bitmap_word = toStgWord platform (fromIntegral n_bits)
+ .|. (small_bitmap `shiftL` pc_BITMAP_BITS_SHIFT (platformConstants platform))
- lits = mkWordCLit dflags (fromIntegral n_bits)
- : map (mkStgWordCLit dflags) bitmap
+ lits = mkWordCLit platform (fromIntegral n_bits)
+ : map (mkStgWordCLit platform) bitmap
-- The first word is the size. The structure must match
-- StgLargeBitmap in includes/rts/storage/InfoTable.h
@@ -397,11 +405,12 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
++ [layout_lit, tag, srt]
where
+ platform = targetPlatform dflags
prof_info
- | gopt Opt_SccProfilingOn dflags = [type_descr, closure_descr]
+ | sccProfilingEnabled dflags = [type_descr, closure_descr]
| otherwise = []
- tag = CmmInt (fromIntegral cl_type) (halfWordWidth dflags)
+ tag = CmmInt (fromIntegral cl_type) (halfWordWidth platform)
-------------------------------------------------------------------------
--
@@ -409,14 +418,14 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt layout_lit
--
-------------------------------------------------------------------------
-mkProfLits :: DynFlags -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
-mkProfLits dflags NoProfilingInfo = return ((zeroCLit dflags, zeroCLit dflags), [])
+mkProfLits :: Platform -> ProfilingInfo -> UniqSM ((CmmLit,CmmLit), [RawCmmDecl])
+mkProfLits platform NoProfilingInfo = return ((zeroCLit platform, zeroCLit platform), [])
mkProfLits _ (ProfilingInfo td cd)
= do { (td_lit, td_decl) <- newStringLit td
; (cd_lit, cd_decl) <- newStringLit cd
; return ((td_lit,cd_lit), [td_decl,cd_decl]) }
-newStringLit :: [Word8] -> UniqSM (CmmLit, GenCmmDecl CmmStatics info stmt)
+newStringLit :: ByteString -> UniqSM (CmmLit, GenCmmDecl RawCmmStatics info stmt)
newStringLit bytes
= do { uniq <- getUniqueM
; return (mkByteStringCLit (mkStringLitLabel uniq) bytes) }
@@ -425,8 +434,8 @@ newStringLit bytes
-- Misc utils
-- | Value of the srt field of an info table when using an StgLargeSRT
-srtEscape :: DynFlags -> StgHalfWord
-srtEscape dflags = toStgHalfWord dflags (-1)
+srtEscape :: Platform -> StgHalfWord
+srtEscape platform = toStgHalfWord platform (-1)
-------------------------------------------------------------------------
--
@@ -434,104 +443,123 @@ srtEscape dflags = toStgHalfWord dflags (-1)
--
-------------------------------------------------------------------------
+data PtrOpts = PtrOpts
+ { po_profile :: !Profile -- ^ Platform profile
+ , po_align_check :: !Bool -- ^ Insert alignment check (cf @-falignment-sanitisation@)
+ }
+
-- | Wrap a 'CmmExpr' in an alignment check when @-falignment-sanitisation@ is
-- enabled.
-wordAligned :: DynFlags -> CmmExpr -> CmmExpr
-wordAligned dflags e
- | gopt Opt_AlignmentSanitisation dflags
- = CmmMachOp (MO_AlignmentCheck (wORD_SIZE dflags) (wordWidth dflags)) [e]
+wordAligned :: PtrOpts -> CmmExpr -> CmmExpr
+wordAligned opts e
+ | po_align_check opts
+ = CmmMachOp (MO_AlignmentCheck (platformWordSizeInBytes platform) (wordWidth platform)) [e]
| otherwise
= e
-
-closureInfoPtr :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer and returns the info table pointer
-closureInfoPtr dflags e =
- CmmLoad (wordAligned dflags e) (bWord dflags)
-
-entryCode :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info pointer (the first word of a closure)
--- and returns its entry code
-entryCode dflags e
- | tablesNextToCode dflags = e
- | otherwise = CmmLoad e (bWord dflags)
-
-getConstrTag :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer, and return the *zero-indexed*
+ where platform = profilePlatform (po_profile opts)
+
+-- | Takes a closure pointer and returns the info table pointer
+closureInfoPtr :: PtrOpts -> CmmExpr -> CmmExpr
+closureInfoPtr opts e =
+ CmmLoad (wordAligned opts e) (bWord (profilePlatform (po_profile opts)))
+
+-- | Takes an info pointer (the first word of a closure) and returns its entry
+-- code
+entryCode :: Platform -> CmmExpr -> CmmExpr
+entryCode platform e =
+ if platformTablesNextToCode platform
+ then e
+ else CmmLoad e (bWord platform)
+
+-- | Takes a closure pointer, and return the *zero-indexed*
-- constructor tag obtained from the info table
-- This lives in the SRT field of the info table
-- (constructors don't need SRTs).
-getConstrTag dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableConstrTag dflags info_table]
+getConstrTag :: PtrOpts -> CmmExpr -> CmmExpr
+getConstrTag opts closure_ptr
+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableConstrTag profile info_table]
where
- info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+ info_table = infoTable profile (closureInfoPtr opts closure_ptr)
+ platform = profilePlatform profile
+ profile = po_profile opts
-cmmGetClosureType :: DynFlags -> CmmExpr -> CmmExpr
--- Takes a closure pointer, and return the closure type
+-- | Takes a closure pointer, and return the closure type
-- obtained from the info table
-cmmGetClosureType dflags closure_ptr
- = CmmMachOp (MO_UU_Conv (halfWordWidth dflags) (wordWidth dflags)) [infoTableClosureType dflags info_table]
+cmmGetClosureType :: PtrOpts -> CmmExpr -> CmmExpr
+cmmGetClosureType opts closure_ptr
+ = CmmMachOp (MO_UU_Conv (halfWordWidth platform) (wordWidth platform)) [infoTableClosureType profile info_table]
where
- info_table = infoTable dflags (closureInfoPtr dflags closure_ptr)
+ info_table = infoTable profile (closureInfoPtr opts closure_ptr)
+ platform = profilePlatform profile
+ profile = po_profile opts
-infoTable :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info pointer (the first word of a closure)
+-- | Takes an info pointer (the first word of a closure)
-- and returns a pointer to the first word of the standard-form
-- info table, excluding the entry-code word (if present)
-infoTable dflags info_ptr
- | tablesNextToCode dflags = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags)
- | otherwise = cmmOffsetW dflags info_ptr 1 -- Past the entry code pointer
+infoTable :: Profile -> CmmExpr -> CmmExpr
+infoTable profile info_ptr
+ | platformTablesNextToCode platform = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile)
+ | otherwise = cmmOffsetW platform info_ptr 1 -- Past the entry code pointer
+ where platform = profilePlatform profile
-infoTableConstrTag :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the constr tag
+-- | Takes an info table pointer (from infoTable) and returns the constr tag
-- field of the info table (same as the srt_bitmap field)
+infoTableConstrTag :: Profile -> CmmExpr -> CmmExpr
infoTableConstrTag = infoTableSrtBitmap
-infoTableSrtBitmap :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the srt_bitmap
+-- | Takes an info table pointer (from infoTable) and returns the srt_bitmap
-- field of the info table
-infoTableSrtBitmap dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdSrtBitmapOffset dflags)) (bHalfWord dflags)
+infoTableSrtBitmap :: Profile -> CmmExpr -> CmmExpr
+infoTableSrtBitmap profile info_tbl
+ = CmmLoad (cmmOffsetB platform info_tbl (stdSrtBitmapOffset profile)) (bHalfWord platform)
+ where platform = profilePlatform profile
-infoTableClosureType :: DynFlags -> CmmExpr -> CmmExpr
--- Takes an info table pointer (from infoTable) and returns the closure type
+-- | Takes an info table pointer (from infoTable) and returns the closure type
-- field of the info table.
-infoTableClosureType dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdClosureTypeOffset dflags)) (bHalfWord dflags)
-
-infoTablePtrs :: DynFlags -> CmmExpr -> CmmExpr
-infoTablePtrs dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdPtrsOffset dflags)) (bHalfWord dflags)
-
-infoTableNonPtrs :: DynFlags -> CmmExpr -> CmmExpr
-infoTableNonPtrs dflags info_tbl
- = CmmLoad (cmmOffsetB dflags info_tbl (stdNonPtrsOffset dflags)) (bHalfWord dflags)
-
-funInfoTable :: DynFlags -> CmmExpr -> CmmExpr
--- Takes the info pointer of a function,
--- and returns a pointer to the first word of the StgFunInfoExtra struct
--- in the info table.
-funInfoTable dflags info_ptr
- | tablesNextToCode dflags
- = cmmOffsetB dflags info_ptr (- stdInfoTableSizeB dflags - sIZEOF_StgFunInfoExtraRev dflags)
+infoTableClosureType :: Profile -> CmmExpr -> CmmExpr
+infoTableClosureType profile info_tbl
+ = CmmLoad (cmmOffsetB platform info_tbl (stdClosureTypeOffset profile)) (bHalfWord platform)
+ where platform = profilePlatform profile
+
+infoTablePtrs :: Profile -> CmmExpr -> CmmExpr
+infoTablePtrs profile info_tbl
+ = CmmLoad (cmmOffsetB platform info_tbl (stdPtrsOffset profile)) (bHalfWord platform)
+ where platform = profilePlatform profile
+
+infoTableNonPtrs :: Profile -> CmmExpr -> CmmExpr
+infoTableNonPtrs profile info_tbl
+ = CmmLoad (cmmOffsetB platform info_tbl (stdNonPtrsOffset profile)) (bHalfWord platform)
+ where platform = profilePlatform profile
+
+-- | Takes the info pointer of a function, and returns a pointer to the first
+-- word of the StgFunInfoExtra struct in the info table.
+funInfoTable :: Profile -> CmmExpr -> CmmExpr
+funInfoTable profile info_ptr
+ | platformTablesNextToCode platform
+ = cmmOffsetB platform info_ptr (- stdInfoTableSizeB profile - pc_SIZEOF_StgFunInfoExtraRev (platformConstants platform))
| otherwise
- = cmmOffsetW dflags info_ptr (1 + stdInfoTableSizeW dflags)
- -- Past the entry code pointer
+ = cmmOffsetW platform info_ptr (1 + stdInfoTableSizeW profile)
+ -- Past the entry code pointer
+ where
+ platform = profilePlatform profile
--- Takes the info pointer of a function, returns the function's arity
-funInfoArity :: DynFlags -> CmmExpr -> CmmExpr
-funInfoArity dflags iptr
- = cmmToWord dflags (cmmLoadIndex dflags rep fun_info (offset `div` rep_bytes))
+-- | Takes the info pointer of a function, returns the function's arity
+funInfoArity :: Profile -> CmmExpr -> CmmExpr
+funInfoArity profile iptr
+ = cmmToWord platform (cmmLoadIndex platform rep fun_info (offset `div` rep_bytes))
where
- fun_info = funInfoTable dflags iptr
+ platform = profilePlatform profile
+ fun_info = funInfoTable profile iptr
rep = cmmBits (widthFromBytes rep_bytes)
+ tablesNextToCode = platformTablesNextToCode platform
(rep_bytes, offset)
- | tablesNextToCode dflags = ( pc_REP_StgFunInfoExtraRev_arity pc
- , oFFSET_StgFunInfoExtraRev_arity dflags )
- | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc
- , oFFSET_StgFunInfoExtraFwd_arity dflags )
+ | tablesNextToCode = ( pc_REP_StgFunInfoExtraRev_arity pc
+ , pc_OFFSET_StgFunInfoExtraRev_arity pc )
+ | otherwise = ( pc_REP_StgFunInfoExtraFwd_arity pc
+ , pc_OFFSET_StgFunInfoExtraFwd_arity pc )
- pc = sPlatformConstants (settings dflags)
+ pc = platformConstants platform
-----------------------------------------------------------------------------
--
@@ -539,13 +567,13 @@ funInfoArity dflags iptr
--
-----------------------------------------------------------------------------
-stdInfoTableSizeW :: DynFlags -> WordOff
+stdInfoTableSizeW :: Profile -> WordOff
-- The size of a standard info table varies with profiling/ticky etc,
-- so we can't get it from Constants
-- It must vary in sync with mkStdInfoTable
-stdInfoTableSizeW dflags
+stdInfoTableSizeW profile
= fixedInfoTableSizeW
- + if gopt Opt_SccProfilingOn dflags
+ + if profileIsProfiling profile
then profInfoTableSizeW
else 0
@@ -566,21 +594,24 @@ maxRetInfoTableSizeW =
maxStdInfoTableSizeW
+ 1 {- srt label -}
-stdInfoTableSizeB :: DynFlags -> ByteOff
-stdInfoTableSizeB dflags = stdInfoTableSizeW dflags * wORD_SIZE dflags
+stdInfoTableSizeB :: Profile -> ByteOff
+stdInfoTableSizeB profile = stdInfoTableSizeW profile * profileWordSizeInBytes profile
+
+-- | Byte offset of the SRT bitmap half-word which is in the *higher-addressed*
+-- part of the type_lit
+stdSrtBitmapOffset :: Profile -> ByteOff
+stdSrtBitmapOffset profile = stdInfoTableSizeB profile - halfWordSize (profilePlatform profile)
-stdSrtBitmapOffset :: DynFlags -> ByteOff
--- Byte offset of the SRT bitmap half-word which is
--- in the *higher-addressed* part of the type_lit
-stdSrtBitmapOffset dflags = stdInfoTableSizeB dflags - hALF_WORD_SIZE dflags
+-- | Byte offset of the closure type half-word
+stdClosureTypeOffset :: Profile -> ByteOff
+stdClosureTypeOffset profile = stdInfoTableSizeB profile - profileWordSizeInBytes profile
-stdClosureTypeOffset :: DynFlags -> ByteOff
--- Byte offset of the closure type half-word
-stdClosureTypeOffset dflags = stdInfoTableSizeB dflags - wORD_SIZE dflags
+stdPtrsOffset :: Profile -> ByteOff
+stdPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile
-stdPtrsOffset, stdNonPtrsOffset :: DynFlags -> ByteOff
-stdPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags
-stdNonPtrsOffset dflags = stdInfoTableSizeB dflags - 2 * wORD_SIZE dflags + hALF_WORD_SIZE dflags
+stdNonPtrsOffset :: Profile -> ByteOff
+stdNonPtrsOffset profile = stdInfoTableSizeB profile - 2 * profileWordSizeInBytes profile
+ + halfWordSize (profilePlatform profile)
-conInfoTableSizeB :: DynFlags -> Int
-conInfoTableSizeB dflags = stdInfoTableSizeB dflags + wORD_SIZE dflags
+conInfoTableSizeB :: Profile -> Int
+conInfoTableSizeB profile = stdInfoTableSizeB profile + profileWordSizeInBytes profile
diff --git a/compiler/GHC/Cmm/Info/Build.hs b/compiler/GHC/Cmm/Info/Build.hs
new file mode 100644
index 0000000..8e91c26
--- /dev/null
+++ b/compiler/GHC/Cmm/Info/Build.hs
@@ -0,0 +1,1200 @@
+{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,
+ GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,
+ ScopedTypeVariables, OverloadedStrings #-}
+
+module GHC.Cmm.Info.Build
+ ( CAFSet, CAFEnv, cafAnal, cafAnalData
+ , doSRTs, ModuleSRTInfo (..), emptySRT
+ , SRTMap, srtMapNonCAFs
+ ) where
+
+import GHC.Prelude hiding (succ)
+
+import GHC.Platform
+import GHC.Platform.Profile
+
+import GHC.Types.Id
+import GHC.Types.Id.Info
+import GHC.Cmm.BlockId
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow
+import GHC.Unit.Module
+import GHC.Data.Graph.Directed
+import GHC.Cmm.CLabel
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Driver.Session
+import GHC.Data.Maybe
+import GHC.Utils.Outputable
+import GHC.Runtime.Heap.Layout
+import GHC.Types.Unique.Supply
+import GHC.Types.CostCentre
+import GHC.StgToCmm.Heap
+import GHC.CmmToAsm.Monad
+
+import Control.Monad
+import Data.Map.Strict (Map)
+import qualified Data.Map.Strict as Map
+import Data.Set (Set)
+import qualified Data.Set as Set
+import Control.Monad.Trans.State
+import Control.Monad.Trans.Class
+import Data.List (unzip4)
+
+import GHC.Types.Name.Set
+
+{- Note [SRTs]
+
+SRTs are the mechanism by which the garbage collector can determine
+the live CAFs in the program.
+
+Representation
+^^^^^^^^^^^^^^
+
++------+
+| info |
+| | +-----+---+---+---+
+| -------->|SRT_2| | | | | 0 |
+|------| +-----+-|-+-|-+---+
+| | | |
+| code | | |
+| | v v
+
+An SRT is simply an object in the program's data segment. It has the
+same representation as a static constructor. There are 16
+pre-compiled SRT info tables: stg_SRT_1_info, .. stg_SRT_16_info,
+representing SRT objects with 1-16 pointers, respectively.
+
+The entries of an SRT object point to static closures, which are either
+- FUN_STATIC, THUNK_STATIC or CONSTR
+- Another SRT (actually just a CONSTR)
+
+The final field of the SRT is the static link field, used by the
+garbage collector to chain together static closures that it visits and
+to determine whether a static closure has been visited or not. (see
+Note [STATIC_LINK fields])
+
+By traversing the transitive closure of an SRT, the GC will reach all
+of the CAFs that are reachable from the code associated with this SRT.
+
+If we need to create an SRT with more than 16 entries, we build a
+chain of SRT objects with all but the last having 16 entries.
+
++-----+---+- -+---+---+
+|SRT16| | | | | | 0 |
++-----+-|-+- -+-|-+---+
+ | |
+ v v
+ +----+---+---+---+
+ |SRT2| | | | | 0 |
+ +----+-|-+-|-+---+
+ | |
+ | |
+ v v
+
+Referring to an SRT from the info table
+^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^
+
+The following things have SRTs:
+
+- Static functions (FUN)
+- Static thunks (THUNK), ie. CAFs
+- Continuations (RET_SMALL, etc.)
+
+In each case, the info table points to the SRT.
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt == 1 and info->f.srt_offset points to the SRT
+
+e.g. for a FUN with an SRT:
+
+StgFunInfoTable +------+
+ info->f.srt_offset | ------------> offset to SRT object
+StgStdInfoTable +------+
+ info->layout.ptrs | ... |
+ info->layout.nptrs | ... |
+ info->srt | 1 |
+ info->type | ... |
+ |------|
+
+On x86_64, we optimise the info table representation further. The
+offset to the SRT can be stored in 32 bits (all code lives within a
+2GB region in x86_64's small memory model), so we can save a word in
+the info table by storing the srt_offset in the srt field, which is
+half a word.
+
+On x86_64 with TABLES_NEXT_TO_CODE (except on MachO, due to #15169):
+
+- info->srt is zero if there's no SRT, otherwise:
+- info->srt is an offset from the info pointer to the SRT object
+
+StgStdInfoTable +------+
+ info->layout.ptrs | |
+ info->layout.nptrs | |
+ info->srt | ------------> offset to SRT object
+ |------|
+
+
+EXAMPLE
+^^^^^^^
+
+f = \x. ... g ...
+ where
+ g = \y. ... h ... c1 ...
+ h = \z. ... c2 ...
+
+c1 & c2 are CAFs
+
+g and h are local functions, but they have no static closures. When
+we generate code for f, we start with a CmmGroup of four CmmDecls:
+
+ [ f_closure, f_entry, g_entry, h_entry ]
+
+we process each CmmDecl separately in cpsTop, giving us a list of
+CmmDecls. e.g. for f_entry, we might end up with
+
+ [ f_entry, f1_ret, f2_proc ]
+
+where f1_ret is a return point, and f2_proc is a proc-point. We have
+a CAFSet for each of these CmmDecls, let's suppose they are
+
+ [ f_entry{g_info}, f1_ret{g_info}, f2_proc{} ]
+ [ g_entry{h_info, c1_closure} ]
+ [ h_entry{c2_closure} ]
+
+Next, we make an SRT for each of these functions:
+
+ f_srt : [g_info]
+ g_srt : [h_info, c1_closure]
+ h_srt : [c2_closure]
+
+Now, for g_info and h_info, we want to refer to the SRTs for g and h
+respectively, which we'll label g_srt and h_srt:
+
+ f_srt : [g_srt]
+ g_srt : [h_srt, c1_closure]
+ h_srt : [c2_closure]
+
+Now, when an SRT has a single entry, we don't actually generate an SRT
+closure for it, instead we just replace references to it with its
+single element. So, since h_srt == c2_closure, we have
+
+ f_srt : [g_srt]
+ g_srt : [c2_closure, c1_closure]
+ h_srt : [c2_closure]
+
+and the only SRT closure we generate is
+
+ g_srt = SRT_2 [c2_closure, c1_closure]
+
+Algorithm
+^^^^^^^^^
+
+0. let srtMap :: Map CAFLabel (Maybe SRTEntry) = {}
+ Maps closures to their SRT entries (i.e. how they appear in a SRT payload)
+
+1. Start with decls :: [CmmDecl]. This corresponds to an SCC of bindings in STG
+ after code-generation.
+
+2. CPS-convert each CmmDecl (cpsTop), resulting in a list [CmmDecl]. There might
+ be multiple CmmDecls in the result, due to proc-point splitting.
+
+3. In cpsTop, *before* proc-point splitting, when we still have a single
+ CmmDecl, we do cafAnal for procs:
+
+ * cafAnal performs a backwards analysis on the code blocks
+
+ * For each labelled block, the analysis produces a CAFSet (= Set CAFLabel),
+ representing all the CAFLabels reachable from this label.
+
+ * A label is added to the set if it refers to a FUN, THUNK, or RET,
+ and its CafInfo /= NoCafRefs.
+ (NB. all CafInfo for Ids in the current module should be initialised to
+ MayHaveCafRefs)
+
+ * The result is CAFEnv = LabelMap CAFSet
+
+ (Why *before* proc-point splitting? Because the analysis needs to propagate
+ information across branches, and proc-point splitting turns branches into
+ CmmCalls to top-level CmmDecls. The analysis would fail to find all the
+ references to CAFFY labels if we did it after proc-point splitting.)
+
+ For static data, cafAnalData simply returns set of all labels that refer to a
+ FUN, THUNK, and RET whose CafInfos /= NoCafRefs.
+
+4. The result of cpsTop is (CAFEnv, [CmmDecl]) for procs and (CAFSet, CmmDecl)
+ for static data. So after `mapM cpsTop decls` we have
+ [Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl)]
+
+5. For procs concat the decls and union the CAFEnvs to get (CAFEnv, [CmmDecl])
+
+6. For static data generate a Map CLabel CAFSet (maps static data to their CAFSets)
+
+7. Dependency-analyse the decls using CAFEnv and CAFSets, giving us SCC CAFLabel
+
+8. For each SCC in dependency order
+ - Let lbls :: [CAFLabel] be the non-recursive labels in this SCC
+ - Apply CAFEnv to each label and concat the result :: [CAFLabel]
+ - For each CAFLabel in the set apply srtMap (and ignore Nothing) to get
+ srt :: [SRTEntry]
+ - Make a label for this SRT, call it l
+ - If the SRT is not empty (i.e. the group is CAFFY) add FUN_STATICs in the
+ group to the SRT (see Note [Invalid optimisation: shortcutting])
+ - Add to srtMap: lbls -> if null srt then Nothing else Just l
+
+9. At the end, for every top-level binding x, if srtMap x == Nothing, then the
+ binding is non-CAFFY, otherwise it is CAFFY.
+
+Optimisations
+^^^^^^^^^^^^^
+
+To reduce the code size overhead and the cost of traversing SRTs in
+the GC, we want to simplify SRTs where possible. We therefore apply
+the following optimisations. Each has a [keyword]; search for the
+keyword in the code below to see where the optimisation is
+implemented.
+
+1. [Inline] we never create an SRT with a single entry, instead we
+ point to the single entry directly from the info table.
+
+ i.e. instead of
+
+ +------+
+ | info |
+ | | +-----+---+---+
+ | -------->|SRT_1| | | 0 |
+ |------| +-----+-|-+---+
+ | | |
+ | code | |
+ | | v
+ C
+
+ we can point directly to the closure:
+
+ +------+
+ | info |
+ | |
+ | -------->C
+ |------|
+ | |
+ | code |
+ | |
+
+
+ Furthermore, the SRT for any code that refers to this info table
+ can point directly to C.
+
+ The exception to this is when we're doing dynamic linking. In that
+ case, if the closure is not locally defined then we can't point to
+ it directly from the info table, because this is the text section
+ which cannot contain runtime relocations. In this case we skip this
+ optimisation and generate the singleton SRT, because SRTs are in the
+ data section and *can* have relocatable references.
+
+2. [FUN] A static function closure can also be an SRT, we simply put
+ the SRT entries as fields in the static closure. This makes a lot
+ of sense: the static references are just like the free variables of
+ the FUN closure.
+
+ i.e. instead of
+
+ f_closure:
+ +-----+---+
+ | | | 0 |
+ +- |--+---+
+ | +------+
+ | | info | f_srt:
+ | | | +-----+---+---+---+
+ | | -------->|SRT_2| | | | + 0 |
+ `----------->|------| +-----+-|-+-|-+---+
+ | | | |
+ | code | | |
+ | | v v
+
+
+ We can generate:
+
+ f_closure:
+ +-----+---+---+---+
+ | | | | | | | 0 |
+ +- |--+-|-+-|-+---+
+ | | | +------+
+ | v v | info |
+ | | |
+ | | 0 |
+ `----------->|------|
+ | |
+ | code |
+ | |
+
+
+ (note: we can't do this for THUNKs, because the thunk gets
+ overwritten when it is entered, so we wouldn't be able to share
+ this SRT with other info tables that want to refer to it (see
+ [Common] below). FUNs are immutable so don't have this problem.)
+
+3. [Common] Identical SRTs can be commoned up.
+
+4. [Filter] If an SRT A refers to an SRT B and a closure C, and B also
+ refers to C (perhaps transitively), then we can omit the reference
+ to C from A.
+
+
+Note that there are many other optimisations that we could do, but
+aren't implemented. In general, we could omit any reference from an
+SRT if everything reachable from it is also reachable from the other
+fields in the SRT. Our [Filter] optimisation is a special case of
+this.
+
+Another opportunity we don't exploit is this:
+
+A = {X,Y,Z}
+B = {Y,Z}
+C = {X,B}
+
+Here we could use C = {A} and therefore [Inline] C = A.
+-}
+
+-- ---------------------------------------------------------------------
+{- Note [Invalid optimisation: shortcutting]
+
+You might think that if we have something like
+
+A's SRT = {B}
+B's SRT = {X}
+
+that we could replace the reference to B in A's SRT with X.
+
+A's SRT = {X}
+B's SRT = {X}
+
+and thereby perhaps save a little work at runtime, because we don't
+have to visit B.
+
+But this is NOT valid.
+
+Consider these cases:
+
+0. B can't be a constructor, because constructors don't have SRTs
+
+1. B is a CAF. This is the easy one. Obviously we want A's SRT to
+ point to B, so that it keeps B alive.
+
+2. B is a function. This is the tricky one. The reason we can't
+shortcut in this case is that we aren't allowed to resurrect static
+objects.
+
+== How does this cause a problem? ==
+
+The particular case that cropped up when we tried this was #15544.
+- A is a thunk
+- B is a static function
+- X is a CAF
+- suppose we GC when A is alive, and B is not otherwise reachable.
+- B is "collected", meaning that it doesn't make it onto the static
+ objects list during this GC, but nothing bad happens yet.
+- Next, suppose we enter A, and then call B. (remember that A refers to B)
+ At the entry point to B, we GC. This puts B on the stack, as part of the
+ RET_FUN stack frame that gets pushed when we GC at a function entry point.
+- This GC will now reach B
+- But because B was previous "collected", it breaks the assumption
+ that static objects are never resurrected. See Note [STATIC_LINK
+ fields] in rts/sm/Storage.h for why this is bad.
+- In practice, the GC thinks that B has already been visited, and so
+ doesn't visit X, and catastrophe ensues.
+
+== Isn't this caused by the RET_FUN business? ==
+
+Maybe, but could you prove that RET_FUN is the only way that
+resurrection can occur?
+
+So, no shortcutting.
+
+Note [Ticky labels in SRT analysis]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Raw Cmm data (CmmStaticsRaw) can't contain pointers so they're considered
+non-CAFFY in SRT analysis and we update the SRTMap mapping them to `Nothing`
+(meaning they're not CAFFY).
+
+However when building with -ticky we generate ticky CLabels using the function's
+`Name`. For example, if we have a top-level function `sat_s1rQ`, in a ticky
+build we get two IdLabels using the name `sat_s1rQ`:
+
+- For the function itself: IdLabel sat_s1rQ ... Entry
+- For the ticky counter: IdLabel sat_s1rQ ... RednCounts
+
+In these cases we really want to use the function definition for the SRT
+analysis of this Name, because that's what we export for this Name -- ticky
+counters are not exported. So we ignore ticky counters in SRT analysis (which
+are never CAFFY and never exported).
+
+Not doing this caused #17947 where we analysed the function first mapped the
+name to CAFFY. We then saw the ticky constructor, and becuase it has the same
+Name as the function and is not CAFFY we overrode the CafInfo of the name as
+non-CAFFY.
+-}
+
+-- ---------------------------------------------------------------------
+-- Label types
+
+-- Labels that come from cafAnal can be:
+-- - _closure labels for static functions or CAFs
+-- - _info labels for dynamic functions, thunks, or continuations
+-- - _entry labels for functions or thunks
+--
+-- Meanwhile the labels on top-level blocks are _entry labels.
+--
+-- To put everything in the same namespace we convert all labels to
+-- closure labels using toClosureLbl. Note that some of these
+-- labels will not actually exist; that's ok because we're going to
+-- map them to SRTEntry later, which ranges over labels that do exist.
+--
+newtype CAFLabel = CAFLabel CLabel
+ deriving (Eq,Ord,Outputable)
+
+type CAFSet = Set CAFLabel
+type CAFEnv = LabelMap CAFSet
+
+mkCAFLabel :: Platform -> CLabel -> CAFLabel
+mkCAFLabel platform lbl = CAFLabel (toClosureLbl platform lbl)
+
+-- This is a label that we can put in an SRT. It *must* be a closure label,
+-- pointing to either a FUN_STATIC, THUNK_STATIC, or CONSTR.
+newtype SRTEntry = SRTEntry CLabel
+ deriving (Eq, Ord, Outputable)
+
+-- ---------------------------------------------------------------------
+-- CAF analysis
+
+addCafLabel :: Platform -> CLabel -> CAFSet -> CAFSet
+addCafLabel platform l s
+ | Just _ <- hasHaskellName l
+ , let caf_label = mkCAFLabel platform l
+ -- For imported Ids hasCAF will have accurate CafInfo
+ -- Locals are initialized as CAFFY. We turn labels with empty SRTs into
+ -- non-CAFFYs in doSRTs
+ , hasCAF l
+ = Set.insert caf_label s
+ | otherwise
+ = s
+
+cafAnalData
+ :: Platform
+ -> CmmStatics
+ -> CAFSet
+cafAnalData platform st = case st of
+ CmmStaticsRaw _lbl _data -> Set.empty
+ CmmStatics _lbl _itbl _ccs payload ->
+ foldl' analyzeStatic Set.empty payload
+ where
+ analyzeStatic s lit =
+ case lit of
+ CmmLabel c -> addCafLabel platform c s
+ CmmLabelOff c _ -> addCafLabel platform c s
+ CmmLabelDiffOff c1 c2 _ _ -> addCafLabel platform c1 $! addCafLabel platform c2 s
+ _ -> s
+
+-- |
+-- For each code block:
+-- - collect the references reachable from this code block to FUN,
+-- THUNK or RET labels for which hasCAF == True
+--
+-- This gives us a `CAFEnv`: a mapping from code block to sets of labels
+--
+cafAnal
+ :: Platform
+ -> LabelSet -- The blocks representing continuations, ie. those
+ -- that will get RET info tables. These labels will
+ -- get their own SRTs, so we don't aggregate CAFs from
+ -- references to these labels, we just use the label.
+ -> CLabel -- The top label of the proc
+ -> CmmGraph
+ -> CAFEnv
+cafAnal platform contLbls topLbl cmmGraph =
+ analyzeCmmBwd cafLattice
+ (cafTransfers platform contLbls (g_entry cmmGraph) topLbl) cmmGraph mapEmpty
+
+
+cafLattice :: DataflowLattice CAFSet
+cafLattice = DataflowLattice Set.empty add
+ where
+ add (OldFact old) (NewFact new) =
+ let !new' = old `Set.union` new
+ in changedIf (Set.size new' > Set.size old) new'
+
+
+cafTransfers :: Platform -> LabelSet -> Label -> CLabel -> TransferFun CAFSet
+cafTransfers platform contLbls entry topLbl
+ block@(BlockCC eNode middle xNode) fBase =
+ let joined :: CAFSet
+ joined = cafsInNode xNode $! live'
+
+ result :: CAFSet
+ !result = foldNodesBwdOO cafsInNode middle joined
+
+ facts :: [Set CAFLabel]
+ facts = mapMaybe successorFact (successors xNode)
+
+ live' :: CAFSet
+ live' = joinFacts cafLattice facts
+
+ successorFact :: Label -> Maybe (Set CAFLabel)
+ successorFact s
+ -- If this is a loop back to the entry, we can refer to the
+ -- entry label.
+ | s == entry = Just (addCafLabel platform topLbl Set.empty)
+ -- If this is a continuation, we want to refer to the
+ -- SRT for the continuation's info table
+ | s `setMember` contLbls
+ = Just (Set.singleton (mkCAFLabel platform (infoTblLbl s)))
+ -- Otherwise, takes the CAF references from the destination
+ | otherwise
+ = lookupFact s fBase
+
+ cafsInNode :: CmmNode e x -> CAFSet -> CAFSet
+ cafsInNode node set = foldExpDeep addCafExpr node set
+
+ addCafExpr :: CmmExpr -> Set CAFLabel -> Set CAFLabel
+ addCafExpr expr !set =
+ case expr of
+ CmmLit (CmmLabel c) ->
+ addCafLabel platform c set
+ CmmLit (CmmLabelOff c _) ->
+ addCafLabel platform c set
+ CmmLit (CmmLabelDiffOff c1 c2 _ _) ->
+ addCafLabel platform c1 $! addCafLabel platform c2 set
+ _ ->
+ set
+ in
+ srtTrace "cafTransfers" (text "block:" <+> ppr block $$
+ text "contLbls:" <+> ppr contLbls $$
+ text "entry:" <+> ppr entry $$
+ text "topLbl:" <+> ppr topLbl $$
+ text "cafs in exit:" <+> ppr joined $$
+ text "result:" <+> ppr result) $
+ mapSingleton (entryLabel eNode) result
+
+
+-- -----------------------------------------------------------------------------
+-- ModuleSRTInfo
+
+data ModuleSRTInfo = ModuleSRTInfo
+ { thisModule :: Module
+ -- ^ Current module being compiled. Required for calling labelDynamic.
+ , dedupSRTs :: Map (Set SRTEntry) SRTEntry
+ -- ^ previous SRTs we've emitted, so we can de-duplicate.
+ -- Used to implement the [Common] optimisation.
+ , flatSRTs :: Map SRTEntry (Set SRTEntry)
+ -- ^ The reverse mapping, so that we can remove redundant
+ -- entries. e.g. if we have an SRT [a,b,c], and we know that b
+ -- points to [c,d], we can omit c and emit [a,b].
+ -- Used to implement the [Filter] optimisation.
+ , moduleSRTMap :: SRTMap
+ }
+
+instance Outputable ModuleSRTInfo where
+ ppr ModuleSRTInfo{..} =
+ text "ModuleSRTInfo {" $$
+ (nest 4 $ text "dedupSRTs =" <+> ppr dedupSRTs $$
+ text "flatSRTs =" <+> ppr flatSRTs $$
+ text "moduleSRTMap =" <+> ppr moduleSRTMap) $$ char '}'
+
+emptySRT :: Module -> ModuleSRTInfo
+emptySRT mod =
+ ModuleSRTInfo
+ { thisModule = mod
+ , dedupSRTs = Map.empty
+ , flatSRTs = Map.empty
+ , moduleSRTMap = Map.empty
+ }
+
+-- -----------------------------------------------------------------------------
+-- Constructing SRTs
+
+{- Implementation notes
+
+- In each CmmDecl there is a mapping info_tbls from Label -> CmmInfoTable
+
+- The entry in info_tbls corresponding to g_entry is the closure info
+ table, the rest are continuations.
+
+- Each entry in info_tbls possibly needs an SRT. We need to make a
+ label for each of these.
+
+- We get the CAFSet for each entry from the CAFEnv
+
+-}
+
+data SomeLabel
+ = BlockLabel !Label
+ | DeclLabel CLabel
+ deriving (Eq, Ord)
+
+instance Outputable SomeLabel where
+ ppr (BlockLabel l) = text "b:" <+> ppr l
+ ppr (DeclLabel l) = text "s:" <+> ppr l
+
+getBlockLabel :: SomeLabel -> Maybe Label
+getBlockLabel (BlockLabel l) = Just l
+getBlockLabel (DeclLabel _) = Nothing
+
+getBlockLabels :: [SomeLabel] -> [Label]
+getBlockLabels = mapMaybe getBlockLabel
+
+-- | Return a (Label,CLabel) pair for each labelled block of a CmmDecl,
+-- where the label is
+-- - the info label for a continuation or dynamic closure
+-- - the closure label for a top-level function (not a CAF)
+getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFLabel)]
+getLabelledBlocks platform decl = case decl of
+ CmmData _ (CmmStaticsRaw _ _) -> []
+ CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFLabel platform lbl) ]
+ CmmProc top_info _ _ _ -> [ (BlockLabel blockId, caf_lbl)
+ | (blockId, info) <- mapToList (info_tbls top_info)
+ , let rep = cit_rep info
+ , not (isStaticRep rep) || not (isThunkRep rep)
+ , let !caf_lbl = mkCAFLabel platform (cit_lbl info)
+ ]
+
+-- | Put the labelled blocks that we will be annotating with SRTs into
+-- dependency order. This is so that we can process them one at a
+-- time, resolving references to earlier blocks to point to their
+-- SRTs. CAFs themselves are not included here; see getCAFs below.
+depAnalSRTs
+ :: Platform
+ -> CAFEnv
+ -> Map CLabel CAFSet -- CAFEnv for statics
+ -> [CmmDecl]
+ -> [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
+depAnalSRTs platform cafEnv cafEnv_static decls =
+ srtTrace "depAnalSRTs" (text "decls:" <+> ppr decls $$
+ text "nodes:" <+> ppr (map node_payload nodes) $$
+ text "graph:" <+> ppr graph) graph
+ where
+ labelledBlocks :: [(SomeLabel, CAFLabel)]
+ labelledBlocks = concatMap (getLabelledBlocks platform) decls
+ labelToBlock :: Map CAFLabel SomeLabel
+ labelToBlock = foldl' (\m (v,k) -> Map.insert k v m) Map.empty labelledBlocks
+
+ nodes :: [Node SomeLabel (SomeLabel, CAFLabel, Set CAFLabel)]
+ nodes = [ DigraphNode (l,lbl,cafs') l
+ (mapMaybe (flip Map.lookup labelToBlock) (Set.toList cafs'))
+ | (l, lbl) <- labelledBlocks
+ , Just (cafs :: Set CAFLabel) <-
+ [case l of
+ BlockLabel l -> mapLookup l cafEnv
+ DeclLabel cl -> Map.lookup cl cafEnv_static]
+ , let cafs' = Set.delete lbl cafs
+ ]
+
+ graph :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
+ graph = stronglyConnCompFromEdgedVerticesOrd nodes
+
+-- | Get (Label, CAFLabel, Set CAFLabel) for each block that represents a CAF.
+-- These are treated differently from other labelled blocks:
+-- - we never shortcut a reference to a CAF to the contents of its
+-- SRT, since the point of SRTs is to keep CAFs alive.
+-- - CAFs therefore don't take part in the dependency analysis in depAnalSRTs.
+-- instead we generate their SRTs after everything else.
+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Label, CAFLabel, Set CAFLabel)]
+getCAFs platform cafEnv decls =
+ [ (g_entry g, mkCAFLabel platform topLbl, cafs)
+ | CmmProc top_info topLbl _ g <- decls
+ , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+ , let rep = cit_rep info
+ , isStaticRep rep && isThunkRep rep
+ , Just cafs <- [mapLookup (g_entry g) cafEnv]
+ ]
+
+
+-- | Get the list of blocks that correspond to the entry points for
+-- FUN_STATIC closures. These are the blocks for which if we have an
+-- SRT we can merge it with the static closure. [FUN]
+getStaticFuns :: [CmmDecl] -> [(BlockId, CLabel)]
+getStaticFuns decls =
+ [ (g_entry g, lbl)
+ | CmmProc top_info _ _ g <- decls
+ , Just info <- [mapLookup (g_entry g) (info_tbls top_info)]
+ , Just (id, _) <- [cit_clo info]
+ , let rep = cit_rep info
+ , isStaticRep rep && isFunRep rep
+ , let !lbl = mkLocalClosureLabel (idName id) (idCafInfo id)
+ ]
+
+
+-- | Maps labels from 'cafAnal' to the final CLabel that will appear
+-- in the SRT.
+-- - closures with singleton SRTs resolve to their single entry
+-- - closures with larger SRTs map to the label for that SRT
+-- - CAFs must not map to anything!
+-- - if a labels maps to Nothing, we found that this label's SRT
+-- is empty, so we don't need to refer to it from other SRTs.
+type SRTMap = Map CAFLabel (Maybe SRTEntry)
+
+
+-- | Given 'SRTMap' of a module, returns the set of non-CAFFY names in the
+-- module. Any 'Name's not in the set are CAFFY.
+srtMapNonCAFs :: SRTMap -> NonCaffySet
+srtMapNonCAFs srtMap =
+ NonCaffySet $ mkNameSet (mapMaybe get_name (Map.toList srtMap))
+ where
+ get_name (CAFLabel l, Nothing) = hasHaskellName l
+ get_name (_l, Just _srt_entry) = Nothing
+
+-- | resolve a CAFLabel to its SRTEntry using the SRTMap
+resolveCAF :: Platform -> SRTMap -> CAFLabel -> Maybe SRTEntry
+resolveCAF platform srtMap lbl@(CAFLabel l) =
+ srtTrace "resolveCAF" ("l:" <+> ppr l <+> "resolved:" <+> ppr ret) ret
+ where
+ ret = Map.findWithDefault (Just (SRTEntry (toClosureLbl platform l))) lbl srtMap
+
+-- | Attach SRTs to all info tables in the CmmDecls, and add SRT
+-- declarations to the ModuleSRTInfo.
+--
+doSRTs
+ :: DynFlags
+ -> ModuleSRTInfo
+ -> [(CAFEnv, [CmmDecl])]
+ -> [(CAFSet, CmmDecl)]
+ -> IO (ModuleSRTInfo, [CmmDeclSRTs])
+
+doSRTs dflags moduleSRTInfo procs data_ = do
+ us <- mkSplitUniqSupply 'u'
+
+ let profile = targetProfile dflags
+
+ -- Ignore the original grouping of decls, and combine all the
+ -- CAFEnvs into a single CAFEnv.
+ let static_data_env :: Map CLabel CAFSet
+ static_data_env =
+ Map.fromList $
+ flip map data_ $
+ \(set, decl) ->
+ case decl of
+ CmmProc{} ->
+ pprPanic "doSRTs" (text "Proc in static data list:" <+> ppr decl)
+ CmmData _ static ->
+ case static of
+ CmmStatics lbl _ _ _ -> (lbl, set)
+ CmmStaticsRaw lbl _ -> (lbl, set)
+
+ static_data :: Set CLabel
+ static_data = Map.keysSet static_data_env
+
+ (proc_envs, procss) = unzip procs
+ cafEnv = mapUnions proc_envs
+ decls = map snd data_ ++ concat procss
+ staticFuns = mapFromList (getStaticFuns decls)
+
+ platform = targetPlatform dflags
+
+ -- Put the decls in dependency order. Why? So that we can implement
+ -- [Inline] and [Filter]. If we need to refer to an SRT that has
+ -- a single entry, we use the entry itself, which means that we
+ -- don't need to generate the singleton SRT in the first place. But
+ -- to do this we need to process blocks before things that depend on
+ -- them.
+ let
+ sccs :: [SCC (SomeLabel, CAFLabel, Set CAFLabel)]
+ sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls
+
+ cafsWithSRTs :: [(Label, CAFLabel, Set CAFLabel)]
+ cafsWithSRTs = getCAFs platform cafEnv decls
+
+ srtTraceM "doSRTs" (text "data:" <+> ppr data_ $$
+ text "procs:" <+> ppr procs $$
+ text "static_data_env:" <+> ppr static_data_env $$
+ text "sccs:" <+> ppr sccs $$
+ text "cafsWithSRTs:" <+> ppr cafsWithSRTs)
+
+ -- On each strongly-connected group of decls, construct the SRT
+ -- closures and the SRT fields for info tables.
+ let result ::
+ [ ( [CmmDeclSRTs] -- generated SRTs
+ , [(Label, CLabel)] -- SRT fields for info tables
+ , [(Label, [SRTEntry])] -- SRTs to attach to static functions
+ , Bool -- Whether the group has CAF references
+ ) ]
+
+ (result, moduleSRTInfo') =
+ initUs_ us $
+ flip runStateT moduleSRTInfo $ do
+ nonCAFs <- mapM (doSCC dflags staticFuns static_data) sccs
+ cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->
+ oneSRT dflags staticFuns [BlockLabel l] [cafLbl]
+ True{-is a CAF-} cafs static_data
+ return (nonCAFs ++ cAFs)
+
+ (srt_declss, pairs, funSRTs, has_caf_refs) = unzip4 result
+ srt_decls = concat srt_declss
+
+ -- Next, update the info tables with the SRTs
+ let
+ srtFieldMap = mapFromList (concat pairs)
+ funSRTMap = mapFromList (concat funSRTs)
+ has_caf_refs' = or has_caf_refs
+ decls' =
+ concatMap (updInfoSRTs profile srtFieldMap funSRTMap has_caf_refs') decls
+
+ -- Finally update CafInfos for raw static literals (CmmStaticsRaw). Those are
+ -- not analysed in oneSRT so we never add entries for them to the SRTMap.
+ let srtMap_w_raws =
+ foldl' (\(srtMap :: SRTMap) (_, decl) ->
+ case decl of
+ CmmData _ CmmStatics{} ->
+ -- already updated by oneSRT
+ srtMap
+ CmmData _ (CmmStaticsRaw lbl _)
+ | isIdLabel lbl && not (isTickyLabel lbl) ->
+ -- Raw data are not analysed by oneSRT and they can't
+ -- be CAFFY.
+ -- See Note [Ticky labels in SRT analysis] above for
+ -- why we exclude ticky labels here.
+ Map.insert (mkCAFLabel platform lbl) Nothing srtMap
+ | otherwise ->
+ -- Not an IdLabel, ignore
+ srtMap
+ CmmProc{} ->
+ pprPanic "doSRTs" (text "Found Proc in static data list:" <+> ppr decl))
+ (moduleSRTMap moduleSRTInfo') data_
+
+ return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')
+
+
+-- | Build the SRT for a strongly-connected component of blocks
+doSCC
+ :: DynFlags
+ -> LabelMap CLabel -- which blocks are static function entry points
+ -> Set CLabel -- static data
+ -> SCC (SomeLabel, CAFLabel, Set CAFLabel)
+ -> StateT ModuleSRTInfo UniqSM
+ ( [CmmDeclSRTs] -- generated SRTs
+ , [(Label, CLabel)] -- SRT fields for info tables
+ , [(Label, [SRTEntry])] -- SRTs to attach to static functions
+ , Bool -- Whether the group has CAF references
+ )
+
+doSCC dflags staticFuns static_data (AcyclicSCC (l, cafLbl, cafs)) =
+ oneSRT dflags staticFuns [l] [cafLbl] False cafs static_data
+
+doSCC dflags staticFuns static_data (CyclicSCC nodes) = do
+ -- build a single SRT for the whole cycle, see Note [recursive SRTs]
+ let (lbls, caf_lbls, cafsets) = unzip3 nodes
+ cafs = Set.unions cafsets
+ oneSRT dflags staticFuns lbls caf_lbls False cafs static_data
+
+
+{- Note [recursive SRTs]
+
+If the dependency analyser has found us a recursive group of
+declarations, then we build a single SRT for the whole group, on the
+grounds that everything in the group is reachable from everything
+else, so we lose nothing by having a single SRT.
+
+However, there are a couple of wrinkles to be aware of.
+
+* The Set CAFLabel for this SRT will contain labels in the group
+itself. The SRTMap will therefore not contain entries for these labels
+yet, so we can't turn them into SRTEntries using resolveCAF. BUT we
+can just remove recursive references from the Set CAFLabel before
+generating the SRT - the SRT will still contain all the CAFLabels that
+we need to refer to from this group's SRT.
+
+* That is, EXCEPT for static function closures. For the same reason
+described in Note [Invalid optimisation: shortcutting], we cannot omit
+references to static function closures.
+ - But, since we will merge the SRT with one of the static function
+ closures (see [FUN]), we can omit references to *that* static
+ function closure from the SRT.
+-}
+
+-- | Build an SRT for a set of blocks
+oneSRT
+ :: DynFlags
+ -> LabelMap CLabel -- which blocks are static function entry points
+ -> [SomeLabel] -- blocks in this set
+ -> [CAFLabel] -- labels for those blocks
+ -> Bool -- True <=> this SRT is for a CAF
+ -> Set CAFLabel -- SRT for this set
+ -> Set CLabel -- Static data labels in this group
+ -> StateT ModuleSRTInfo UniqSM
+ ( [CmmDeclSRTs] -- SRT objects we built
+ , [(Label, CLabel)] -- SRT fields for these blocks' itbls
+ , [(Label, [SRTEntry])] -- SRTs to attach to static functions
+ , Bool -- Whether the group has CAF references
+ )
+
+oneSRT dflags staticFuns lbls caf_lbls isCAF cafs static_data = do
+ topSRT <- get
+
+ let
+ config = initConfig dflags
+ profile = targetProfile dflags
+ platform = profilePlatform profile
+ srtMap = moduleSRTMap topSRT
+
+ blockids = getBlockLabels lbls
+
+ -- Can we merge this SRT with a FUN_STATIC closure?
+ maybeFunClosure :: Maybe (CLabel, Label)
+ otherFunLabels :: [CLabel]
+ (maybeFunClosure, otherFunLabels) =
+ case [ (l,b) | b <- blockids, Just l <- [mapLookup b staticFuns] ] of
+ [] -> (Nothing, [])
+ ((l,b):xs) -> (Just (l,b), map fst xs)
+
+ -- Remove recursive references from the SRT
+ nonRec :: Set CAFLabel
+ nonRec = cafs `Set.difference` Set.fromList caf_lbls
+
+ -- Resolve references to their SRT entries
+ resolved :: [SRTEntry]
+ resolved = mapMaybe (resolveCAF platform srtMap) (Set.toList nonRec)
+
+ -- The set of all SRTEntries in SRTs that we refer to from here.
+ allBelow =
+ Set.unions [ lbls | caf <- resolved
+ , Just lbls <- [Map.lookup caf (flatSRTs topSRT)] ]
+
+ -- Remove SRTEntries that are also in an SRT that we refer to.
+ -- Implements the [Filter] optimisation.
+ filtered0 = Set.fromList resolved `Set.difference` allBelow
+
+ srtTraceM "oneSRT:"
+ (text "srtMap:" <+> ppr srtMap $$
+ text "nonRec:" <+> ppr nonRec $$
+ text "lbls:" <+> ppr lbls $$
+ text "caf_lbls:" <+> ppr caf_lbls $$
+ text "static_data:" <+> ppr static_data $$
+ text "cafs:" <+> ppr cafs $$
+ text "blockids:" <+> ppr blockids $$
+ text "maybeFunClosure:" <+> ppr maybeFunClosure $$
+ text "otherFunLabels:" <+> ppr otherFunLabels $$
+ text "resolved:" <+> ppr resolved $$
+ text "allBelow:" <+> ppr allBelow $$
+ text "filtered0:" <+> ppr filtered0)
+
+ let
+ isStaticFun = isJust maybeFunClosure
+
+ -- For a label without a closure (e.g. a continuation), we must
+ -- update the SRTMap for the label to point to a closure. It's
+ -- important that we don't do this for static functions or CAFs,
+ -- see Note [Invalid optimisation: shortcutting].
+ updateSRTMap :: Maybe SRTEntry -> StateT ModuleSRTInfo UniqSM ()
+ updateSRTMap srtEntry =
+ srtTrace "updateSRTMap"
+ (ppr srtEntry <+> "isCAF:" <+> ppr isCAF <+>
+ "isStaticFun:" <+> ppr isStaticFun) $
+ when (not isCAF && (not isStaticFun || isNothing srtEntry)) $
+ modify' $ \state ->
+ let !srt_map =
+ foldl' (\srt_map cafLbl@(CAFLabel clbl) ->
+ -- Only map static data to Nothing (== not CAFFY). For CAFFY
+ -- statics we refer to the static itself instead of a SRT.
+ if not (Set.member clbl static_data) || isNothing srtEntry then
+ Map.insert cafLbl srtEntry srt_map
+ else
+ srt_map)
+ (moduleSRTMap state)
+ caf_lbls
+ in
+ state{ moduleSRTMap = srt_map }
+
+ this_mod = thisModule topSRT
+
+ allStaticData =
+ all (\(CAFLabel clbl) -> Set.member clbl static_data) caf_lbls
+
+ if Set.null filtered0 then do
+ srtTraceM "oneSRT: empty" (ppr caf_lbls)
+ updateSRTMap Nothing
+ return ([], [], [], False)
+ else do
+ -- We're going to build an SRT for this group, which should include function
+ -- references in the group. See Note [recursive SRTs].
+ let allBelow_funs =
+ Set.fromList (map (SRTEntry . toClosureLbl platform) otherFunLabels)
+ let filtered = filtered0 `Set.union` allBelow_funs
+ srtTraceM "oneSRT" (text "filtered:" <+> ppr filtered $$
+ text "allBelow_funs:" <+> ppr allBelow_funs)
+ case Set.toList filtered of
+ [] -> pprPanic "oneSRT" empty -- unreachable
+
+ -- [Inline] - when we have only one entry there is no need to
+ -- build an SRT object at all, instead we put the singleton SRT
+ -- entry in the info table.
+ [one@(SRTEntry lbl)]
+ | -- Info tables refer to SRTs by offset (as noted in the section
+ -- "Referring to an SRT from the info table" of Note [SRTs]). However,
+ -- when dynamic linking is used we cannot guarantee that the offset
+ -- between the SRT and the info table will fit in the offset field.
+ -- Consequently we build a singleton SRT in this case.
+ not (labelDynamic config this_mod lbl)
+
+ -- MachO relocations can't express offsets between compilation units at
+ -- all, so we are always forced to build a singleton SRT in this case.
+ && (not (osMachOTarget $ platformOS $ profilePlatform profile)
+ || isLocalCLabel this_mod lbl) -> do
+
+ -- If we have a static function closure, then it becomes the
+ -- SRT object, and everything else points to it. (the only way
+ -- we could have multiple labels here is if this is a
+ -- recursive group, see Note [recursive SRTs])
+ case maybeFunClosure of
+ Just (staticFunLbl,staticFunBlock) ->
+ return ([], withLabels, [], True)
+ where
+ withLabels =
+ [ (b, if b == staticFunBlock then lbl else staticFunLbl)
+ | b <- blockids ]
+ Nothing -> do
+ srtTraceM "oneSRT: one" (text "caf_lbls:" <+> ppr caf_lbls $$
+ text "one:" <+> ppr one)
+ updateSRTMap (Just one)
+ return ([], map (,lbl) blockids, [], True)
+
+ cafList | allStaticData ->
+ return ([], [], [], not (null cafList))
+
+ cafList ->
+ -- Check whether an SRT with the same entries has been emitted already.
+ -- Implements the [Common] optimisation.
+ case Map.lookup filtered (dedupSRTs topSRT) of
+ Just srtEntry@(SRTEntry srtLbl) -> do
+ srtTraceM "oneSRT [Common]" (ppr caf_lbls <+> ppr srtLbl)
+ updateSRTMap (Just srtEntry)
+ return ([], map (,srtLbl) blockids, [], True)
+ Nothing -> do
+ -- No duplicates: we have to build a new SRT object
+ (decls, funSRTs, srtEntry) <-
+ case maybeFunClosure of
+ Just (fun,block) ->
+ return ( [], [(block, cafList)], SRTEntry fun )
+ Nothing -> do
+ (decls, entry) <- lift $ buildSRTChain profile cafList
+ return (decls, [], entry)
+ updateSRTMap (Just srtEntry)
+ let allBelowThis = Set.union allBelow filtered
+ newFlatSRTs = Map.insert srtEntry allBelowThis (flatSRTs topSRT)
+ -- When all definition in this group are static data we don't
+ -- generate any SRTs.
+ newDedupSRTs = Map.insert filtered srtEntry (dedupSRTs topSRT)
+ modify' (\state -> state{ dedupSRTs = newDedupSRTs,
+ flatSRTs = newFlatSRTs })
+ srtTraceM "oneSRT: new" (text "caf_lbls:" <+> ppr caf_lbls $$
+ text "filtered:" <+> ppr filtered $$
+ text "srtEntry:" <+> ppr srtEntry $$
+ text "newDedupSRTs:" <+> ppr newDedupSRTs $$
+ text "newFlatSRTs:" <+> ppr newFlatSRTs)
+ let SRTEntry lbl = srtEntry
+ return (decls, map (,lbl) blockids, funSRTs, True)
+
+
+-- | Build a static SRT object (or a chain of objects) from a list of
+-- SRTEntries.
+buildSRTChain
+ :: Profile
+ -> [SRTEntry]
+ -> UniqSM
+ ( [CmmDeclSRTs] -- The SRT object(s)
+ , SRTEntry -- label to use in the info table
+ )
+buildSRTChain _ [] = panic "buildSRT: empty"
+buildSRTChain profile cafSet =
+ case splitAt mAX_SRT_SIZE cafSet of
+ (these, []) -> do
+ (decl,lbl) <- buildSRT profile these
+ return ([decl], lbl)
+ (these,those) -> do
+ (rest, rest_lbl) <- buildSRTChain profile (head these : those)
+ (decl,lbl) <- buildSRT profile (rest_lbl : tail these)
+ return (decl:rest, lbl)
+ where
+ mAX_SRT_SIZE = 16
+
+
+buildSRT :: Profile -> [SRTEntry] -> UniqSM (CmmDeclSRTs, SRTEntry)
+buildSRT profile refs = do
+ id <- getUniqueM
+ let
+ lbl = mkSRTLabel id
+ platform = profilePlatform profile
+ srt_n_info = mkSRTInfoLabel (length refs)
+ fields =
+ mkStaticClosure profile srt_n_info dontCareCCS
+ [ CmmLabel lbl | SRTEntry lbl <- refs ]
+ [] -- no padding
+ [mkIntCLit platform 0] -- link field
+ [] -- no saved info
+ return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)
+
+-- | Update info tables with references to their SRTs. Also generate
+-- static closures, splicing in SRT fields as necessary.
+updInfoSRTs
+ :: Profile
+ -> LabelMap CLabel -- SRT labels for each block
+ -> LabelMap [SRTEntry] -- SRTs to merge into FUN_STATIC closures
+ -> Bool -- Whether the CmmDecl's group has CAF references
+ -> CmmDecl
+ -> [CmmDeclSRTs]
+
+updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))
+ = [CmmData s (CmmStaticsRaw lbl statics)]
+
+updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))
+ = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]
+ where
+ caf_info = if caffy then MayHaveCafRefs else NoCafRefs
+ field_lits = mkStaticClosureFields profile itbl ccs caf_info payload
+
+updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)
+ | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]
+ | otherwise = [ proc ]
+ where
+ caf_info = if caffy then MayHaveCafRefs else NoCafRefs
+ proc = CmmProc top_info { info_tbls = newTopInfo } top_l live g
+ newTopInfo = mapMapWithKey updInfoTbl (info_tbls top_info)
+ updInfoTbl l info_tbl
+ | l == g_entry g, Just (inf, _) <- maybeStaticClosure = inf
+ | otherwise = info_tbl { cit_srt = mapLookup l srt_env }
+
+ -- Generate static closures [FUN]. Note that this also generates
+ -- static closures for thunks (CAFs), because it's easier to treat
+ -- them uniformly in the code generator.
+ maybeStaticClosure :: Maybe (CmmInfoTable, CmmDeclSRTs)
+ maybeStaticClosure
+ | Just info_tbl@CmmInfoTable{..} <-
+ mapLookup (g_entry g) (info_tbls top_info)
+ , Just (id, ccs) <- cit_clo
+ , isStaticRep cit_rep =
+ let
+ (newInfo, srtEntries) = case mapLookup (g_entry g) funSRTEnv of
+ Nothing ->
+ -- if we don't add SRT entries to this closure, then we
+ -- want to set the srt field in its info table as usual
+ (info_tbl { cit_srt = mapLookup (g_entry g) srt_env }, [])
+ Just srtEntries -> srtTrace "maybeStaticFun" (ppr res)
+ (info_tbl { cit_rep = new_rep }, res)
+ where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]
+ fields = mkStaticClosureFields profile info_tbl ccs caf_info srtEntries
+ new_rep = case cit_rep of
+ HeapRep sta ptrs nptrs ty ->
+ HeapRep sta (ptrs + length srtEntries) nptrs ty
+ _other -> panic "maybeStaticFun"
+ lbl = mkLocalClosureLabel (idName id) caf_info
+ in
+ Just (newInfo, mkDataLits (Section Data lbl) lbl fields)
+ | otherwise = Nothing
+
+
+srtTrace :: String -> SDoc -> b -> b
+-- srtTrace = pprTrace
+srtTrace _ _ b = b
+
+srtTraceM :: Applicative f => String -> SDoc -> f ()
+srtTraceM str doc = srtTrace str doc (pure ())
diff --git a/compiler/cmm/CmmLayoutStack.hs b/compiler/GHC/Cmm/LayoutStack.hs
index 3b3f49e..f1137cf 100644
--- a/compiler/cmm/CmmLayoutStack.hs
+++ b/compiler/GHC/Cmm/LayoutStack.hs
@@ -1,38 +1,40 @@
{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}
-module CmmLayoutStack (
+module GHC.Cmm.LayoutStack (
cmmLayoutStack, setInfoTableStackMap
) where
-import GhcPrelude hiding ((<*>))
-
-import StgCmmUtils ( callerSaveVolatileRegs ) -- XXX layering violation
-import StgCmmForeign ( saveThreadState, loadThreadState ) -- XXX layering violation
-
-import BasicTypes
-import Cmm
-import CmmInfo
-import BlockId
-import CLabel
-import CmmUtils
-import MkGraph
-import ForeignCall
-import CmmLive
-import CmmProcPoint
-import SMRep
-import Hoopl.Block
-import Hoopl.Collections
-import Hoopl.Dataflow
-import Hoopl.Graph
-import Hoopl.Label
-import UniqSupply
-import StgCmmUtils ( newTemp )
-import Maybes
-import UniqFM
-import Util
-
-import DynFlags
-import FastString
-import Outputable hiding ( isEmpty )
+import GHC.Prelude hiding ((<*>))
+
+import GHC.Platform
+import GHC.Platform.Profile
+
+import GHC.StgToCmm.Utils ( callerSaveVolatileRegs, newTemp ) -- XXX layering violation
+import GHC.StgToCmm.Foreign ( saveThreadState, loadThreadState ) -- XXX layering violation
+
+import GHC.Types.Basic
+import GHC.Cmm
+import GHC.Cmm.Info
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm.Utils
+import GHC.Cmm.Graph
+import GHC.Types.ForeignCall
+import GHC.Cmm.Liveness
+import GHC.Cmm.ProcPoint
+import GHC.Runtime.Heap.Layout
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Types.Unique.Supply
+import GHC.Data.Maybe
+import GHC.Types.Unique.FM
+import GHC.Utils.Misc
+
+import GHC.Driver.Session
+import GHC.Data.FastString
+import GHC.Utils.Outputable hiding ( isEmpty )
import qualified Data.Set as Set
import Control.Monad.Fix
import Data.Array as Array
@@ -224,7 +226,7 @@ data StackMap = StackMap
, sm_ret_off :: ByteOff
-- ^ Number of words of stack that we do not describe with an info
-- table, because it contains an update frame.
- , sm_regs :: UniqFM (LocalReg,StackLoc)
+ , sm_regs :: UniqFM LocalReg (LocalReg,StackLoc)
-- ^ regs on the stack
}
@@ -245,6 +247,7 @@ cmmLayoutStack dflags procpoints entry_args
-- by the sinking pass.
let liveness = cmmLocalLiveness dflags graph
blocks = revPostorder graph
+ profile = targetProfile dflags
(final_stackmaps, _final_high_sp, new_blocks) <-
mfix $ \ ~(rec_stackmaps, rec_high_sp, _new_blocks) ->
@@ -253,7 +256,7 @@ cmmLayoutStack dflags procpoints entry_args
blocks_with_reloads <-
insertReloadsAsNeeded dflags procpoints final_stackmaps entry new_blocks
- new_blocks' <- mapM (lowerSafeForeignCall dflags) blocks_with_reloads
+ new_blocks' <- mapM (lowerSafeForeignCall profile) blocks_with_reloads
return (ofBlockList entry new_blocks', final_stackmaps)
-- -----------------------------------------------------------------------------
@@ -357,10 +360,9 @@ isGcJump _something_else = False
-- This doesn't seem right somehow. We need to find out whether this
-- proc will push some update frame material at some point, so that we
--- can avoid using that area of the stack for spilling. The
--- updfr_space field of the CmmProc *should* tell us, but it doesn't
--- (I think maybe it gets filled in later when we do proc-point
--- splitting).
+-- can avoid using that area of the stack for spilling. Ideally we would
+-- capture this information in the CmmProc (e.g. in CmmStackInfo; see #18232
+-- for details on one ill-fated attempt at this).
--
-- So we'll just take the max of all the cml_ret_offs. This could be
-- unnecessarily pessimistic, but probably not in the code we
@@ -460,7 +462,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
return $ lastCall cont_lbl cml_args cml_ret_args cml_ret_off
CmmForeignCall{ succ = cont_lbl, .. } -> do
- return $ lastCall cont_lbl (wORD_SIZE dflags) ret_args ret_off
+ return $ lastCall cont_lbl (platformWordSizeInBytes platform) ret_args ret_off
-- one word of args: the return address
CmmBranch {} -> handleBranches
@@ -468,6 +470,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
CmmSwitch {} -> handleBranches
where
+ platform = targetPlatform dflags
-- Calls and ForeignCalls are handled the same way:
lastCall :: BlockId -> ByteOff -> ByteOff -> ByteOff
-> ( [CmmNode O O]
@@ -496,7 +499,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
= (save_assignments, new_cont_stack)
where
(new_cont_stack, save_assignments)
- = setupStackFrame dflags lbl liveness cml_ret_off cml_ret_args stack0
+ = setupStackFrame platform lbl liveness cml_ret_off cml_ret_args stack0
-- For other last nodes (branches), if any of the targets is a
@@ -519,7 +522,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
out = mapFromList [ (l', cont_stack)
| l' <- successors last ]
return ( assigs
- , spOffsetForCall sp0 cont_stack (wORD_SIZE dflags)
+ , spOffsetForCall sp0 cont_stack (platformWordSizeInBytes platform)
, last
, []
, out)
@@ -553,7 +556,7 @@ handleLastNode dflags procpoints liveness cont_info stackmaps
= do
let cont_args = mapFindWithDefault 0 l cont_info
(stack2, assigs) =
- setupStackFrame dflags l liveness (sm_ret_off stack0)
+ setupStackFrame platform l liveness (sm_ret_off stack0)
cont_args stack0
(tmp_lbl, block) <- makeFixupBlock dflags sp0 l stack2 tscp assigs
return (l, tmp_lbl, stack2, block)
@@ -610,7 +613,7 @@ fixupStack old_stack new_stack = concatMap move new_locs
setupStackFrame
- :: DynFlags
+ :: Platform
-> BlockId -- label of continuation
-> LabelMap CmmLocalLive -- liveness
-> ByteOff -- updfr
@@ -618,7 +621,7 @@ setupStackFrame
-> StackMap -- current StackMap
-> (StackMap, [CmmNode O O])
-setupStackFrame dflags lbl liveness updfr_off ret_args stack0
+setupStackFrame platform lbl liveness updfr_off ret_args stack0
= (cont_stack, assignments)
where
-- get the set of LocalRegs live in the continuation
@@ -634,7 +637,7 @@ setupStackFrame dflags lbl liveness updfr_off ret_args stack0
-- everything up to updfr_off is off-limits
-- stack1 contains updfr_off, plus everything we need to save
- (stack1, assignments) = allocate dflags updfr_off live stack0
+ (stack1, assignments) = allocate platform updfr_off live stack0
-- And the Sp at the continuation is:
-- sm_sp stack1 + ret_args
@@ -715,9 +718,9 @@ futureContinuation middle = foldBlockNodesB f middle Nothing
-- on the stack and return the new StackMap and the assignments to do
-- the saving.
--
-allocate :: DynFlags -> ByteOff -> LocalRegSet -> StackMap
+allocate :: Platform -> ByteOff -> LocalRegSet -> StackMap
-> (StackMap, [CmmNode O O])
-allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
+allocate platform ret_off live stackmap@StackMap{ sm_sp = sp0
, sm_regs = regs0 }
=
-- we only have to save regs that are not already in a slot
@@ -727,38 +730,38 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
-- make a map of the stack
let stack = reverse $ Array.elems $
- accumArray (\_ x -> x) Empty (1, toWords dflags (max sp0 ret_off)) $
+ accumArray (\_ x -> x) Empty (1, toWords platform (max sp0 ret_off)) $
ret_words ++ live_words
where ret_words =
[ (x, Occupied)
- | x <- [ 1 .. toWords dflags ret_off] ]
+ | x <- [ 1 .. toWords platform ret_off] ]
live_words =
- [ (toWords dflags x, Occupied)
+ [ (toWords platform x, Occupied)
| (r,off) <- nonDetEltsUFM regs1,
-- See Note [Unique Determinism and code generation]
- let w = localRegBytes dflags r,
- x <- [ off, off - wORD_SIZE dflags .. off - w + 1] ]
+ let w = localRegBytes platform r,
+ x <- [ off, off - platformWordSizeInBytes platform .. off - w + 1] ]
in
-- Pass over the stack: find slots to save all the new live variables,
-- choosing the oldest slots first (hence a foldr).
let
save slot ([], stack, n, assigs, regs) -- no more regs to save
- = ([], slot:stack, plusW dflags n 1, assigs, regs)
+ = ([], slot:stack, plusW platform n 1, assigs, regs)
save slot (to_save, stack, n, assigs, regs)
= case slot of
- Occupied -> (to_save, Occupied:stack, plusW dflags n 1, assigs, regs)
+ Occupied -> (to_save, Occupied:stack, plusW platform n 1, assigs, regs)
Empty
| Just (stack', r, to_save') <-
select_save to_save (slot:stack)
-> let assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
- n' = plusW dflags n 1
+ n' = plusW platform n 1
in
(to_save', stack', n', assig : assigs, (r,(r,n')):regs)
| otherwise
- -> (to_save, slot:stack, plusW dflags n 1, assigs, regs)
+ -> (to_save, slot:stack, plusW platform n 1, assigs, regs)
-- we should do better here: right now we'll fit the smallest first,
-- but it would make more sense to fit the biggest first.
@@ -771,7 +774,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
= Just (replicate words Occupied ++ rest, r, rs++no_fit)
| otherwise
= go rs (r:no_fit)
- where words = localRegWords dflags r
+ where words = localRegWords platform r
-- fill in empty slots as much as possible
(still_to_save, save_stack, n, save_assigs, save_regs)
@@ -784,14 +787,14 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
push r (n, assigs, regs)
= (n', assig : assigs, (r,(r,n')) : regs)
where
- n' = n + localRegBytes dflags r
+ n' = n + localRegBytes platform r
assig = CmmStore (CmmStackSlot Old n')
(CmmReg (CmmLocal r))
trim_sp
| not (null push_regs) = push_sp
| otherwise
- = plusW dflags n (- length (takeWhile isEmpty save_stack))
+ = plusW platform n (- length (takeWhile isEmpty save_stack))
final_regs = regs1 `addListToUFM` push_regs
`addListToUFM` save_regs
@@ -800,7 +803,7 @@ allocate dflags ret_off live stackmap@StackMap{ sm_sp = sp0
-- XXX should be an assert
if ( n /= max sp0 ret_off ) then pprPanic "allocate" (ppr n <+> ppr sp0 <+> ppr ret_off) else
- if (trim_sp .&. (wORD_SIZE dflags - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
+ if (trim_sp .&. (platformWordSizeInBytes platform - 1)) /= 0 then pprPanic "allocate2" (ppr trim_sp <+> ppr final_regs <+> ppr push_sp) else
( stackmap { sm_regs = final_regs , sm_sp = trim_sp }
, push_assigs ++ save_assigs )
@@ -839,10 +842,11 @@ manifestSp dflags stackmaps stack0 sp0 sp_high
= final_block : fixup_blocks'
where
area_off = getAreaOff stackmaps
+ platform = targetPlatform dflags
adj_pre_sp, adj_post_sp :: CmmNode e x -> CmmNode e x
- adj_pre_sp = mapExpDeep (areaToSp dflags sp0 sp_high area_off)
- adj_post_sp = mapExpDeep (areaToSp dflags (sp0 - sp_off) sp_high area_off)
+ adj_pre_sp = mapExpDeep (areaToSp platform sp0 sp_high area_off)
+ adj_post_sp = mapExpDeep (areaToSp platform (sp0 - sp_off) sp_high area_off)
final_middle = maybeAddSpAdj dflags sp0 sp_off
. blockFromList
@@ -868,9 +872,10 @@ maybeAddSpAdj
maybeAddSpAdj dflags sp0 sp_off block =
add_initial_unwind $ add_adj_unwind $ adj block
where
+ platform = targetPlatform dflags
adj block
| sp_off /= 0
- = block `blockSnoc` CmmAssign spReg (cmmOffset dflags spExpr sp_off)
+ = block `blockSnoc` CmmAssign spReg (cmmOffset platform spExpr sp_off)
| otherwise = block
-- Add unwind pseudo-instruction at the beginning of each block to
-- document Sp level for debugging
@@ -879,7 +884,7 @@ maybeAddSpAdj dflags sp0 sp_off block =
= CmmUnwind [(Sp, Just sp_unwind)] `blockCons` block
| otherwise
= block
- where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags)
+ where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform)
-- Add unwind pseudo-instruction right after the Sp adjustment
-- if there is one.
@@ -889,7 +894,7 @@ maybeAddSpAdj dflags sp0 sp_off block =
= block `blockSnoc` CmmUnwind [(Sp, Just sp_unwind)]
| otherwise
= block
- where sp_unwind = CmmRegOff spReg (sp0 - wORD_SIZE dflags - sp_off)
+ where sp_unwind = CmmRegOff spReg (sp0 - platformWordSizeInBytes platform - sp_off)
{- Note [SP old/young offsets]
@@ -909,23 +914,23 @@ arguments.
to be Sp + Sp(L) - Sp(L')
-}
-areaToSp :: DynFlags -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
+areaToSp :: Platform -> ByteOff -> ByteOff -> (Area -> StackLoc) -> CmmExpr -> CmmExpr
-areaToSp dflags sp_old _sp_hwm area_off (CmmStackSlot area n)
- = cmmOffset dflags spExpr (sp_old - area_off area - n)
+areaToSp platform sp_old _sp_hwm area_off (CmmStackSlot area n)
+ = cmmOffset platform spExpr (sp_old - area_off area - n)
-- Replace (CmmStackSlot area n) with an offset from Sp
-areaToSp dflags _ sp_hwm _ (CmmLit CmmHighStackMark)
- = mkIntExpr dflags sp_hwm
+areaToSp platform _ sp_hwm _ (CmmLit CmmHighStackMark)
+ = mkIntExpr platform sp_hwm
-- Replace CmmHighStackMark with the number of bytes of stack used,
- -- the sp_hwm. See Note [Stack usage] in StgCmmHeap
+ -- the sp_hwm. See Note [Stack usage] in GHC.StgToCmm.Heap
-areaToSp dflags _ _ _ (CmmMachOp (MO_U_Lt _) args)
+areaToSp platform _ _ _ (CmmMachOp (MO_U_Lt _) args)
| falseStackCheck args
- = zeroExpr dflags
-areaToSp dflags _ _ _ (CmmMachOp (MO_U_Ge _) args)
+ = zeroExpr platform
+areaToSp platform _ _ _ (CmmMachOp (MO_U_Ge _) args)
| falseStackCheck args
- = mkIntExpr dflags 1
+ = mkIntExpr platform 1
-- Replace a stack-overflow test that cannot fail with a no-op
-- See Note [Always false stack check]
@@ -1005,8 +1010,8 @@ elimStackStores stackmap stackmaps area_off nodes
-- Update info tables to include stack liveness
-setInfoTableStackMap :: DynFlags -> LabelMap StackMap -> CmmDecl -> CmmDecl
-setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
+setInfoTableStackMap :: Platform -> LabelMap StackMap -> CmmDecl -> CmmDecl
+setInfoTableStackMap platform stackmaps (CmmProc top_info@TopInfo{..} l v g)
= CmmProc top_info{ info_tbls = mapMapWithKey fix_info info_tbls } l v g
where
fix_info lbl info_tbl@CmmInfoTable{ cit_rep = StackRep _ } =
@@ -1017,18 +1022,18 @@ setInfoTableStackMap dflags stackmaps (CmmProc top_info@TopInfo{..} l v g)
get_liveness lbl
= case mapLookup lbl stackmaps of
Nothing -> pprPanic "setInfoTableStackMap" (ppr lbl <+> ppr info_tbls)
- Just sm -> stackMapToLiveness dflags sm
+ Just sm -> stackMapToLiveness platform sm
setInfoTableStackMap _ _ d = d
-stackMapToLiveness :: DynFlags -> StackMap -> Liveness
-stackMapToLiveness dflags StackMap{..} =
+stackMapToLiveness :: Platform -> StackMap -> Liveness
+stackMapToLiveness platform StackMap{..} =
reverse $ Array.elems $
- accumArray (\_ x -> x) True (toWords dflags sm_ret_off + 1,
- toWords dflags (sm_sp - sm_args)) live_words
+ accumArray (\_ x -> x) True (toWords platform sm_ret_off + 1,
+ toWords platform (sm_sp - sm_args)) live_words
where
- live_words = [ (toWords dflags off, False)
+ live_words = [ (toWords platform off, False)
| (r,off) <- nonDetEltsUFM sm_regs
, isGcPtrType (localRegType r) ]
-- See Note [Unique Determinism and code generation]
@@ -1051,6 +1056,7 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
rewriteCC :: RewriteFun CmmLocalLive
rewriteCC (BlockCC e_node middle0 x_node) fact_base0 = do
let entry_label = entryLabel e_node
+ platform = targetPlatform dflags
stackmap = case mapLookup entry_label final_stackmaps of
Just sm -> sm
Nothing -> panic "insertReloadsAsNeeded: rewriteCC: stackmap"
@@ -1067,7 +1073,7 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
-- to a proc point.
(middle1, live_with_reloads)
| entry_label `setMember` procpoints
- = let reloads = insertReloads dflags stackmap live_at_middle0
+ = let reloads = insertReloads platform stackmap live_at_middle0
in (foldr blockCons middle0 reloads, emptyRegSet)
| otherwise
= (middle0, live_at_middle0)
@@ -1077,12 +1083,12 @@ insertReloadsAsNeeded dflags procpoints final_stackmaps entry blocks = do
return (BlockCC e_node middle1 x_node, fact_base2)
-insertReloads :: DynFlags -> StackMap -> CmmLocalLive -> [CmmNode O O]
-insertReloads dflags stackmap live =
+insertReloads :: Platform -> StackMap -> CmmLocalLive -> [CmmNode O O]
+insertReloads platform stackmap live =
[ CmmAssign (CmmLocal reg)
-- This cmmOffset basically corresponds to manifesting
-- @CmmStackSlot Old sp_off@, see Note [SP old/young offsets]
- (CmmLoad (cmmOffset dflags spExpr (sp_off - reg_off))
+ (CmmLoad (cmmOffset platform spExpr (sp_off - reg_off))
(localRegType reg))
| (reg, reg_off) <- stackSlotRegs stackmap
, reg `elemRegSet` live
@@ -1128,20 +1134,21 @@ expecting them (see Note [safe foreign call convention]). Note also
that safe foreign call is replace by an unsafe one in the Cmm graph.
-}
-lowerSafeForeignCall :: DynFlags -> CmmBlock -> UniqSM CmmBlock
-lowerSafeForeignCall dflags block
+lowerSafeForeignCall :: Profile -> CmmBlock -> UniqSM CmmBlock
+lowerSafeForeignCall profile block
| (entry@(CmmEntry _ tscp), middle, CmmForeignCall { .. }) <- blockSplit block
= do
+ let platform = profilePlatform profile
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
- id <- newTemp (bWord dflags)
- new_base <- newTemp (cmmRegType dflags baseReg)
- let (caller_save, caller_load) = callerSaveVolatileRegs dflags
- save_state_code <- saveThreadState dflags
- load_state_code <- loadThreadState dflags
+ id <- newTemp (bWord platform)
+ new_base <- newTemp (cmmRegType platform baseReg)
+ let (caller_save, caller_load) = callerSaveVolatileRegs platform
+ save_state_code <- saveThreadState profile
+ load_state_code <- loadThreadState profile
let suspend = save_state_code <*>
caller_save <*>
- mkMiddle (callSuspendThread dflags id intrbl)
+ mkMiddle (callSuspendThread platform id intrbl)
midCall = mkUnsafeCall tgt res args
resume = mkMiddle (callResumeThread new_base id) <*>
-- Assign the result to BaseReg: we
@@ -1151,7 +1158,7 @@ lowerSafeForeignCall dflags block
load_state_code
(_, regs, copyout) =
- copyOutOflow dflags NativeReturn Jump (Young succ)
+ copyOutOflow profile NativeReturn Jump (Young succ)
(map (CmmReg . CmmLocal) res)
ret_off []
@@ -1160,11 +1167,11 @@ lowerSafeForeignCall dflags block
-- received an exception during the call, then the stack might be
-- different. Hence we continue by jumping to the top stack frame,
-- not by jumping to succ.
- jump = CmmCall { cml_target = entryCode dflags $
- CmmLoad spExpr (bWord dflags)
+ jump = CmmCall { cml_target = entryCode platform $
+ CmmLoad spExpr (bWord platform)
, cml_cont = Just succ
, cml_args_regs = regs
- , cml_args = widthInBytes (wordWidth dflags)
+ , cml_args = widthInBytes (wordWidth platform)
, cml_ret_args = ret_args
, cml_ret_off = ret_off }
@@ -1186,12 +1193,12 @@ lowerSafeForeignCall dflags block
foreignLbl :: FastString -> CmmExpr
foreignLbl name = CmmLit (CmmLabel (mkForeignLabel name Nothing ForeignLabelInExternalPackage IsFunction))
-callSuspendThread :: DynFlags -> LocalReg -> Bool -> CmmNode O O
-callSuspendThread dflags id intrbl =
+callSuspendThread :: Platform -> LocalReg -> Bool -> CmmNode O O
+callSuspendThread platform id intrbl =
CmmUnsafeForeignCall
(ForeignTarget (foreignLbl (fsLit "suspendThread"))
(ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint] CmmMayReturn))
- [id] [baseExpr, mkIntExpr dflags (fromEnum intrbl)]
+ [id] [baseExpr, mkIntExpr platform (fromEnum intrbl)]
callResumeThread :: LocalReg -> LocalReg -> CmmNode O O
callResumeThread new_base id =
@@ -1202,8 +1209,8 @@ callResumeThread new_base id =
-- -----------------------------------------------------------------------------
-plusW :: DynFlags -> ByteOff -> WordOff -> ByteOff
-plusW dflags b w = b + w * wORD_SIZE dflags
+plusW :: Platform -> ByteOff -> WordOff -> ByteOff
+plusW platform b w = b + w * platformWordSizeInBytes platform
data StackSlot = Occupied | Empty
-- Occupied: a return address or part of an update frame
@@ -1221,15 +1228,15 @@ isEmpty :: StackSlot -> Bool
isEmpty Empty = True
isEmpty _ = False
-localRegBytes :: DynFlags -> LocalReg -> ByteOff
-localRegBytes dflags r
- = roundUpToWords dflags (widthInBytes (typeWidth (localRegType r)))
+localRegBytes :: Platform -> LocalReg -> ByteOff
+localRegBytes platform r
+ = roundUpToWords platform (widthInBytes (typeWidth (localRegType r)))
-localRegWords :: DynFlags -> LocalReg -> WordOff
-localRegWords dflags = toWords dflags . localRegBytes dflags
+localRegWords :: Platform -> LocalReg -> WordOff
+localRegWords platform = toWords platform . localRegBytes platform
-toWords :: DynFlags -> ByteOff -> WordOff
-toWords dflags x = x `quot` wORD_SIZE dflags
+toWords :: Platform -> ByteOff -> WordOff
+toWords platform x = x `quot` platformWordSizeInBytes platform
stackSlotRegs :: StackMap -> [(LocalReg, StackLoc)]
diff --git a/compiler/cmm/CmmLex.x b/compiler/GHC/Cmm/Lexer.x
index 468ea00..010001c 100644
--- a/compiler/cmm/CmmLex.x
+++ b/compiler/GHC/Cmm/Lexer.x
@@ -11,22 +11,22 @@
-----------------------------------------------------------------------------
{
-module CmmLex (
+module GHC.Cmm.Lexer (
CmmToken(..), cmmlex,
) where
-import GhcPrelude
+import GHC.Prelude
-import CmmExpr
+import GHC.Cmm.Expr
-import Lexer
-import CmmMonad
-import SrcLoc
-import UniqFM
-import StringBuffer
-import FastString
-import Ctype
-import Util
+import GHC.Parser.Lexer
+import GHC.Cmm.Monad
+import GHC.Types.SrcLoc
+import GHC.Types.Unique.FM
+import GHC.Data.StringBuffer
+import GHC.Data.FastString
+import GHC.Parser.CharClass
+import GHC.Utils.Misc
--import TRACE
import Data.Word
@@ -185,7 +185,7 @@ data CmmToken
-- -----------------------------------------------------------------------------
-- Lexer actions
-type Action = RealSrcSpan -> StringBuffer -> Int -> PD (RealLocated CmmToken)
+type Action = PsSpan -> StringBuffer -> Int -> PD (PsLocated CmmToken)
begin :: Int -> Action
begin code _span _str _len = do liftP (pushLexState code); lexToken
@@ -290,7 +290,7 @@ tok_string str = CmmT_String (read str)
-- Line pragmas
setLine :: Int -> Action
-setLine code span buf len = do
+setLine code (PsSpan span _) buf len = do
let line = parseUnsignedInteger buf len 10 octDecDigit
liftP $ do
setSrcLoc (mkRealSrcLoc (srcSpanFile span) (fromIntegral line - 1) 1)
@@ -300,7 +300,7 @@ setLine code span buf len = do
lexToken
setFile :: Int -> Action
-setFile code span buf len = do
+setFile code (PsSpan span _) buf len = do
let file = lexemeToFastString (stepOn buf) (len-2)
liftP $ do
setSrcLoc (mkRealSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span))
@@ -315,23 +315,23 @@ cmmlex :: (Located CmmToken -> PD a) -> PD a
cmmlex cont = do
(L span tok) <- lexToken
--trace ("token: " ++ show tok) $ do
- cont (L (RealSrcSpan span) tok)
+ cont (L (mkSrcSpanPs span) tok)
-lexToken :: PD (RealLocated CmmToken)
+lexToken :: PD (PsLocated CmmToken)
lexToken = do
inp@(loc1,buf) <- getInput
sc <- liftP getLexState
case alexScan inp sc of
- AlexEOF -> do let span = mkRealSrcSpan loc1 loc1
+ AlexEOF -> do let span = mkPsSpan loc1 loc1
liftP (setLastToken span 0)
return (L span CmmT_EOF)
- AlexError (loc2,_) -> liftP $ failLocMsgP loc1 loc2 "lexical error"
+ AlexError (loc2,_) -> liftP $ failLocMsgP (psRealLoc loc1) (psRealLoc loc2) "lexical error"
AlexSkip inp2 _ -> do
setInput inp2
lexToken
AlexToken inp2@(end,_buf2) len t -> do
setInput inp2
- let span = mkRealSrcSpan loc1 end
+ let span = mkPsSpan loc1 end
span `seq` liftP (setLastToken span len)
t span buf len
@@ -339,7 +339,7 @@ lexToken = do
-- Monad stuff
-- Stuff that Alex needs to know about our input type:
-type AlexInput = (RealSrcLoc,StringBuffer)
+type AlexInput = (PsLoc,StringBuffer)
alexInputPrevChar :: AlexInput -> Char
alexInputPrevChar (_,s) = prevChar s '\n'
@@ -357,7 +357,7 @@ alexGetByte (loc,s)
| otherwise = b `seq` loc' `seq` s' `seq` Just (b, (loc', s'))
where c = currentChar s
b = fromIntegral $ ord $ c
- loc' = advanceSrcLoc loc c
+ loc' = advancePsLoc loc c
s' = stepOn s
getInput :: PD AlexInput
diff --git a/compiler/cmm/CmmLint.hs b/compiler/GHC/Cmm/Lint.hs
index 3224bb8..aa3e3a8 100644
--- a/compiler/cmm/CmmLint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -5,29 +5,31 @@
-- CmmLint: checking the correctness of Cmm statements and expressions
--
-----------------------------------------------------------------------------
+{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE GADTs #-}
-module CmmLint (
+module GHC.Cmm.Lint (
cmmLint, cmmLintGraph
) where
-import GhcPrelude
+import GHC.Prelude
-import Hoopl.Block
-import Hoopl.Collections
-import Hoopl.Graph
-import Hoopl.Label
-import Cmm
-import CmmUtils
-import CmmLive
-import CmmSwitch (switchTargetsToList)
-import PprCmm ()
-import Outputable
-import DynFlags
+import GHC.Platform
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.Liveness
+import GHC.Cmm.Switch (switchTargetsToList)
+import GHC.Cmm.Ppr () -- For Outputable instances
+import GHC.Utils.Outputable
+import GHC.Driver.Session
-import Control.Monad (liftM, ap)
+import Control.Monad (ap)
-- Things to check:
--- - invariant on CmmBlock in CmmExpr (see comment there)
+-- - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)
-- - check for branches to blocks that don't exist
-- - check types
@@ -86,31 +88,31 @@ lintCmmExpr (CmmLoad expr rep) = do
_ <- lintCmmExpr expr
-- Disabled, if we have the inlining phase before the lint phase,
-- we can have funny offsets due to pointer tagging. -- EZY
- -- when (widthInBytes (typeWidth rep) >= wORD_SIZE) $
+ -- when (widthInBytes (typeWidth rep) >= platformWordSizeInBytes platform) $
-- cmmCheckWordAddress expr
return rep
lintCmmExpr expr@(CmmMachOp op args) = do
- dflags <- getDynFlags
+ platform <- getPlatform
tys <- mapM lintCmmExpr args
- if map (typeWidth . cmmExprType dflags) args == machOpArgReps dflags op
+ if map (typeWidth . cmmExprType platform) args == machOpArgReps platform op
then cmmCheckMachOp op args tys
- else cmmLintMachOpErr expr (map (cmmExprType dflags) args) (machOpArgReps dflags op)
+ else cmmLintMachOpErr expr (map (cmmExprType platform) args) (machOpArgReps platform op)
lintCmmExpr (CmmRegOff reg offset)
- = do dflags <- getDynFlags
- let rep = typeWidth (cmmRegType dflags reg)
+ = do platform <- getPlatform
+ let rep = typeWidth (cmmRegType platform reg)
lintCmmExpr (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral offset) rep)])
lintCmmExpr expr =
- do dflags <- getDynFlags
- return (cmmExprType dflags expr)
+ do platform <- getPlatform
+ return (cmmExprType platform expr)
-- Check for some common byte/word mismatches (eg. Sp + 1)
cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType
cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys
= cmmCheckMachOp op [reg, lit] tys
cmmCheckMachOp op _ tys
- = do dflags <- getDynFlags
- return (machOpResultType dflags op tys)
+ = do platform <- getPlatform
+ return (machOpResultType platform op tys)
{-
isOffsetOp :: MachOp -> Bool
@@ -122,10 +124,10 @@ isOffsetOp _ = False
-- check for funny-looking sub-word offsets.
_cmmCheckWordAddress :: CmmExpr -> CmmLint ()
_cmmCheckWordAddress e@(CmmMachOp op [arg, CmmLit (CmmInt i _)])
- | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
= cmmLintDubiousWordOffset e
_cmmCheckWordAddress e@(CmmMachOp op [CmmLit (CmmInt i _), arg])
- | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (wORD_SIZE dflags) /= 0
+ | isOffsetOp op && notNodeReg arg && i `rem` fromIntegral (platformWordSizeInBytes platform) /= 0
= cmmLintDubiousWordOffset e
_cmmCheckWordAddress _
= return ()
@@ -144,9 +146,9 @@ lintCmmMiddle node = case node of
CmmUnwind{} -> return ()
CmmAssign reg expr -> do
- dflags <- getDynFlags
+ platform <- getPlatform
erep <- lintCmmExpr expr
- let reg_ty = cmmRegType dflags reg
+ let reg_ty = cmmRegType platform reg
if (erep `cmmEqType_ignoring_ptrhood` reg_ty)
then return ()
else cmmLintAssignErr (CmmAssign reg expr) erep reg_ty
@@ -166,16 +168,16 @@ lintCmmLast labels node = case node of
CmmBranch id -> checkTarget id
CmmCondBranch e t f _ -> do
- dflags <- getDynFlags
+ platform <- getPlatform
mapM_ checkTarget [t,f]
_ <- lintCmmExpr e
- checkCond dflags e
+ checkCond platform e
CmmSwitch e ids -> do
- dflags <- getDynFlags
+ platform <- getPlatform
mapM_ checkTarget $ switchTargetsToList ids
erep <- lintCmmExpr e
- if (erep `cmmEqType_ignoring_ptrhood` bWord dflags)
+ if (erep `cmmEqType_ignoring_ptrhood` bWord platform)
then return ()
else cmmLintErr (text "switch scrutinee is not a word: " <>
ppr e <> text " :: " <> ppr erep)
@@ -199,9 +201,9 @@ lintTarget (ForeignTarget e _) = lintCmmExpr e >> return ()
lintTarget (PrimTarget {}) = return ()
-checkCond :: DynFlags -> CmmExpr -> CmmLint ()
+checkCond :: Platform -> CmmExpr -> CmmLint ()
checkCond _ (CmmMachOp mop _) | isComparisonMachOp mop = return ()
-checkCond dflags (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth dflags = return () -- constant values
+checkCond platform (CmmLit (CmmInt x t)) | x == 0 || x == 1, t == wordWidth platform = return () -- constant values
checkCond _ expr
= cmmLintErr (hang (text "expression is not a conditional:") 2
(ppr expr))
@@ -212,9 +214,7 @@ checkCond _ expr
-- just a basic error monad:
newtype CmmLint a = CmmLint { unCL :: DynFlags -> Either SDoc a }
-
-instance Functor CmmLint where
- fmap = liftM
+ deriving (Functor)
instance Applicative CmmLint where
pure a = CmmLint (\_ -> Right a)
@@ -229,6 +229,9 @@ instance Monad CmmLint where
instance HasDynFlags CmmLint where
getDynFlags = CmmLint (\dflags -> Right dflags)
+getPlatform :: CmmLint Platform
+getPlatform = targetPlatform <$> getDynFlags
+
cmmLintErr :: SDoc -> CmmLint a
cmmLintErr msg = CmmLint (\_ -> Left msg)
diff --git a/compiler/cmm/CmmLive.hs b/compiler/GHC/Cmm/Liveness.hs
index f340c32..c229e48 100644
--- a/compiler/cmm/CmmLive.hs
+++ b/compiler/GHC/Cmm/Liveness.hs
@@ -3,7 +3,7 @@
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
-module CmmLive
+module GHC.Cmm.Liveness
( CmmLocalLive
, cmmLocalLiveness
, cmmGlobalLiveness
@@ -12,19 +12,19 @@ module CmmLive
)
where
-import GhcPrelude
+import GHC.Prelude
-import DynFlags
-import BlockId
-import Cmm
-import PprCmmExpr ()
-import Hoopl.Block
-import Hoopl.Collections
-import Hoopl.Dataflow
-import Hoopl.Label
+import GHC.Driver.Session
+import GHC.Cmm.BlockId
+import GHC.Cmm
+import GHC.Cmm.Ppr.Expr () -- For Outputable instances
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow
+import GHC.Cmm.Dataflow.Label
-import Maybes
-import Outputable
+import GHC.Data.Maybe
+import GHC.Utils.Outputable
-----------------------------------------------------------------------------
-- Calculating what variables are live on entry to a basic block
diff --git a/compiler/cmm/CmmMonad.hs b/compiler/GHC/Cmm/Monad.hs
index 821c0a6..edb4c5f 100644
--- a/compiler/cmm/CmmMonad.hs
+++ b/compiler/GHC/Cmm/Monad.hs
@@ -1,26 +1,31 @@
-{-# LANGUAGE CPP #-}
-
-----------------------------------------------------------------------------
-- A Parser monad with access to the 'DynFlags'.
--
--- The 'P' monad only has access to the subset of of 'DynFlags'
+-- The 'P' monad only has access to the subset of 'DynFlags'
-- required for parsing Haskell.
-- The parser for C-- requires access to a lot more of the 'DynFlags',
-- so 'PD' provides access to 'DynFlags' via a 'HasDynFlags' instance.
-----------------------------------------------------------------------------
-module CmmMonad (
+module GHC.Cmm.Monad (
PD(..)
, liftP
+ , failMsgPD
+ , getProfile
+ , getPlatform
+ , getPtrOpts
) where
-import GhcPrelude
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.Platform.Profile
+import GHC.Cmm.Info
import Control.Monad
-import qualified Control.Monad.Fail as MonadFail
-import DynFlags
-import Lexer
+import GHC.Driver.Session
+import GHC.Parser.Lexer
newtype PD a = PD { unPD :: DynFlags -> PState -> ParseResult a }
@@ -33,16 +38,13 @@ instance Applicative PD where
instance Monad PD where
(>>=) = thenPD
-#if !MIN_VERSION_base(4,13,0)
- fail = MonadFail.fail
-#endif
-
-instance MonadFail.MonadFail PD where
- fail = failPD
liftP :: P a -> PD a
liftP (P f) = PD $ \_ s -> f s
+failMsgPD :: String -> PD a
+failMsgPD = liftP . failMsgP
+
returnPD :: a -> PD a
returnPD = liftP . return
@@ -50,10 +52,22 @@ thenPD :: PD a -> (a -> PD b) -> PD b
(PD m) `thenPD` k = PD $ \d s ->
case m d s of
POk s1 a -> unPD (k a) d s1
- PFailed warnFn span err -> PFailed warnFn span err
-
-failPD :: String -> PD a
-failPD = liftP . fail
+ PFailed s1 -> PFailed s1
instance HasDynFlags PD where
getDynFlags = PD $ \d s -> POk s d
+
+getProfile :: PD Profile
+getProfile = targetProfile <$> getDynFlags
+
+getPlatform :: PD Platform
+getPlatform = profilePlatform <$> getProfile
+
+getPtrOpts :: PD PtrOpts
+getPtrOpts = do
+ dflags <- getDynFlags
+ profile <- getProfile
+ pure $ PtrOpts
+ { po_profile = profile
+ , po_align_check = gopt Opt_AlignmentSanitisation dflags
+ }
diff --git a/compiler/cmm/CmmOpt.hs b/compiler/GHC/Cmm/Opt.hs
index e837d29..4931220 100644
--- a/compiler/cmm/CmmOpt.hs
+++ b/compiler/GHC/Cmm/Opt.hs
@@ -1,7 +1,3 @@
--- The default iteration limit is a bit too low for the definitions
--- in this module.
-{-# OPTIONS_GHC -fmax-pmcheck-iterations=10000000 #-}
-
-----------------------------------------------------------------------------
--
-- Cmm optimisation
@@ -10,33 +6,32 @@
--
-----------------------------------------------------------------------------
-module CmmOpt (
+module GHC.Cmm.Opt (
constantFoldNode,
constantFoldExpr,
cmmMachOpFold,
cmmMachOpFoldM
) where
-import GhcPrelude
+import GHC.Prelude
-import CmmUtils
-import Cmm
-import DynFlags
-import Util
+import GHC.Cmm.Utils
+import GHC.Cmm
+import GHC.Utils.Misc
-import Outputable
-import Platform
+import GHC.Utils.Outputable
+import GHC.Platform
import Data.Bits
import Data.Maybe
-constantFoldNode :: DynFlags -> CmmNode e x -> CmmNode e x
-constantFoldNode dflags = mapExp (constantFoldExpr dflags)
+constantFoldNode :: Platform -> CmmNode e x -> CmmNode e x
+constantFoldNode platform = mapExp (constantFoldExpr platform)
-constantFoldExpr :: DynFlags -> CmmExpr -> CmmExpr
-constantFoldExpr dflags = wrapRecExp f
- where f (CmmMachOp op args) = cmmMachOpFold dflags op args
+constantFoldExpr :: Platform -> CmmExpr -> CmmExpr
+constantFoldExpr platform = wrapRecExp f
+ where f (CmmMachOp op args) = cmmMachOpFold platform op args
f (CmmRegOff r 0) = CmmReg r
f e = e
@@ -47,17 +42,17 @@ constantFoldExpr dflags = wrapRecExp f
-- been optimized and folded.
cmmMachOpFold
- :: DynFlags
+ :: Platform
-> MachOp -- The operation from an CmmMachOp
-> [CmmExpr] -- The optimized arguments
-> CmmExpr
-cmmMachOpFold dflags op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM dflags op args)
+cmmMachOpFold platform op args = fromMaybe (CmmMachOp op args) (cmmMachOpFoldM platform op args)
-- Returns Nothing if no changes, useful for Hoopl, also reduces
-- allocation!
cmmMachOpFoldM
- :: DynFlags
+ :: Platform
-> MachOp
-> [CmmExpr]
-> Maybe CmmExpr
@@ -74,6 +69,7 @@ cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
MO_SF_Conv _from to -> CmmLit (CmmFloat (fromInteger x) to)
MO_SS_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
MO_UU_Conv from to -> CmmLit (CmmInt (narrowU from x) to)
+ MO_XX_Conv from to -> CmmLit (CmmInt (narrowS from x) to)
_ -> panic $ "cmmMachOpFoldM: unknown unary op: " ++ show op
@@ -81,9 +77,10 @@ cmmMachOpFoldM _ op [CmmLit (CmmInt x rep)]
-- Eliminate conversion NOPs
cmmMachOpFoldM _ (MO_SS_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
cmmMachOpFoldM _ (MO_UU_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
+cmmMachOpFoldM _ (MO_XX_Conv rep1 rep2) [x] | rep1 == rep2 = Just x
-- Eliminate nested conversions where possible
-cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
+cmmMachOpFoldM platform conv_outer [CmmMachOp conv_inner [x]]
| Just (rep1,rep2,signed1) <- isIntConversion conv_inner,
Just (_, rep3,signed2) <- isIntConversion conv_outer
= case () of
@@ -93,13 +90,13 @@ cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
-- but remember to use the signedness from the widening, just in case
-- the final conversion is a widen.
| rep1 < rep2 && rep2 > rep3 ->
- Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
-- Nested widenings: collapse if the signedness is the same
| rep1 < rep2 && rep2 < rep3 && signed1 == signed2 ->
- Just $ cmmMachOpFold dflags (intconv signed1 rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (intconv signed1 rep1 rep3) [x]
-- Nested narrowings: collapse
| rep1 > rep2 && rep2 > rep3 ->
- Just $ cmmMachOpFold dflags (MO_UU_Conv rep1 rep3) [x]
+ Just $ cmmMachOpFold platform (MO_UU_Conv rep1 rep3) [x]
| otherwise ->
Nothing
where
@@ -116,22 +113,22 @@ cmmMachOpFoldM dflags conv_outer [CmmMachOp conv_inner [x]]
-- but what if the architecture only supports word-sized loads, should
-- we do the transformation anyway?
-cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
+cmmMachOpFoldM platform mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
= case mop of
-- for comparisons: don't forget to narrow the arguments before
-- comparing, since they might be out of range.
- MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth dflags))
- MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth dflags))
+ MO_Eq _ -> Just $ CmmLit (CmmInt (if x_u == y_u then 1 else 0) (wordWidth platform))
+ MO_Ne _ -> Just $ CmmLit (CmmInt (if x_u /= y_u then 1 else 0) (wordWidth platform))
- MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth dflags))
- MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth dflags))
- MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth dflags))
- MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth dflags))
+ MO_U_Gt _ -> Just $ CmmLit (CmmInt (if x_u > y_u then 1 else 0) (wordWidth platform))
+ MO_U_Ge _ -> Just $ CmmLit (CmmInt (if x_u >= y_u then 1 else 0) (wordWidth platform))
+ MO_U_Lt _ -> Just $ CmmLit (CmmInt (if x_u < y_u then 1 else 0) (wordWidth platform))
+ MO_U_Le _ -> Just $ CmmLit (CmmInt (if x_u <= y_u then 1 else 0) (wordWidth platform))
- MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth dflags))
- MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth dflags))
- MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth dflags))
- MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth dflags))
+ MO_S_Gt _ -> Just $ CmmLit (CmmInt (if x_s > y_s then 1 else 0) (wordWidth platform))
+ MO_S_Ge _ -> Just $ CmmLit (CmmInt (if x_s >= y_s then 1 else 0) (wordWidth platform))
+ MO_S_Lt _ -> Just $ CmmLit (CmmInt (if x_s < y_s then 1 else 0) (wordWidth platform))
+ MO_S_Le _ -> Just $ CmmLit (CmmInt (if x_s <= y_s then 1 else 0) (wordWidth platform))
MO_Add r -> Just $ CmmLit (CmmInt (x + y) r)
MO_Sub r -> Just $ CmmLit (CmmInt (x - y) r)
@@ -163,9 +160,9 @@ cmmMachOpFoldM dflags mop [CmmLit (CmmInt x xrep), CmmLit (CmmInt y _)]
-- also assume that constants have been shifted to the right when
-- possible.
-cmmMachOpFoldM dflags op [x@(CmmLit _), y]
+cmmMachOpFoldM platform op [x@(CmmLit _), y]
| not (isLit y) && isCommutableMachOp op
- = Just (cmmMachOpFold dflags op [y, x])
+ = Just (cmmMachOpFold platform op [y, x])
-- Turn (a+b)+c into a+(b+c) where possible. Because literals are
-- moved to the right, it is more likely that we will find
@@ -183,19 +180,19 @@ cmmMachOpFoldM dflags op [x@(CmmLit _), y]
-- Also don't do it if arg1 is PicBaseReg, so that we don't separate the
-- PicBaseReg from the corresponding label (or label difference).
--
-cmmMachOpFoldM dflags mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
+cmmMachOpFoldM platform mop1 [CmmMachOp mop2 [arg1,arg2], arg3]
| mop2 `associates_with` mop1
&& not (isLit arg1) && not (isPicReg arg1)
- = Just (cmmMachOpFold dflags mop2 [arg1, cmmMachOpFold dflags mop1 [arg2,arg3]])
+ = Just (cmmMachOpFold platform mop2 [arg1, cmmMachOpFold platform mop1 [arg2,arg3]])
where
MO_Add{} `associates_with` MO_Sub{} = True
mop1 `associates_with` mop2 =
mop1 == mop2 && isAssociativeMachOp mop1
-- special case: (a - b) + c ==> a + (c - b)
-cmmMachOpFoldM dflags mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
+cmmMachOpFoldM platform mop1@(MO_Add{}) [CmmMachOp mop2@(MO_Sub{}) [arg1,arg2], arg3]
| not (isLit arg1) && not (isPicReg arg1)
- = Just (cmmMachOpFold dflags mop1 [arg1, cmmMachOpFold dflags mop2 [arg3,arg2]])
+ = Just (cmmMachOpFold platform mop1 [arg1, cmmMachOpFold platform mop2 [arg3,arg2]])
-- special case: (PicBaseReg + lit) + N ==> PicBaseReg + (lit+N)
--
@@ -238,9 +235,9 @@ cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]
-- narrowing throws away bits from the operand, there's no way to do
-- the same comparison at the larger size.
-cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
+cmmMachOpFoldM platform cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
| -- powerPC NCG has a TODO for I8/I16 comparisons, so don't try
- platformArch (targetPlatform dflags) `elem` [ArchX86, ArchX86_64],
+ platformArch platform `elem` [ArchX86, ArchX86_64],
-- if the operand is widened:
Just (rep, signed, narrow_fn) <- maybe_conversion conv,
-- and this is a comparison operation:
@@ -248,7 +245,7 @@ cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-- and the literal fits in the smaller size:
i == narrow_fn rep i
-- then we can do the comparison at the smaller size
- = Just (cmmMachOpFold dflags narrow_cmp [x, CmmLit (CmmInt i rep)])
+ = Just (cmmMachOpFold platform narrow_cmp [x, CmmLit (CmmInt i rep)])
where
maybe_conversion (MO_UU_Conv from to)
| to > from
@@ -282,7 +279,7 @@ cmmMachOpFoldM dflags cmp [CmmMachOp conv [x], CmmLit (CmmInt i _)]
-- We can often do something with constants of 0 and 1 ...
-- See Note [Comparison operators]
-cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
+cmmMachOpFoldM platform mop [x, y@(CmmLit (CmmInt 0 _))]
= case mop of
-- Arithmetic
MO_Add _ -> Just x -- x + 0 = x
@@ -314,10 +311,10 @@ cmmMachOpFoldM dflags mop [x, y@(CmmLit (CmmInt 0 _))]
MO_S_Le _ | Just x' <- maybeInvertCmmExpr x -> Just x'
_ -> Nothing
where
- zero = CmmLit (CmmInt 0 (wordWidth dflags))
- one = CmmLit (CmmInt 1 (wordWidth dflags))
+ zero = CmmLit (CmmInt 0 (wordWidth platform))
+ one = CmmLit (CmmInt 1 (wordWidth platform))
-cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt 1 rep))]
= case mop of
-- Arithmetic: x*1 = x, etc
MO_Mul _ -> Just x
@@ -340,27 +337,27 @@ cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt 1 rep))]
MO_S_Ge _ | isComparisonExpr x -> Just x
_ -> Nothing
where
- zero = CmmLit (CmmInt 0 (wordWidth dflags))
- one = CmmLit (CmmInt 1 (wordWidth dflags))
+ zero = CmmLit (CmmInt 0 (wordWidth platform))
+ one = CmmLit (CmmInt 1 (wordWidth platform))
-- Now look for multiplication/division by powers of 2 (integers).
-cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
+cmmMachOpFoldM platform mop [x, (CmmLit (CmmInt n _))]
= case mop of
MO_Mul rep
| Just p <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold platform (MO_Shl rep) [x, CmmLit (CmmInt p rep)])
MO_U_Quot rep
| Just p <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
+ Just (cmmMachOpFold platform (MO_U_Shr rep) [x, CmmLit (CmmInt p rep)])
MO_U_Rem rep
| Just _ <- exactLog2 n ->
- Just (cmmMachOpFold dflags (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
+ Just (cmmMachOpFold platform (MO_And rep) [x, CmmLit (CmmInt (n - 1) rep)])
MO_S_Quot rep
| Just p <- exactLog2 n,
CmmReg _ <- x -> -- We duplicate x in signedQuotRemHelper, hence require
-- it is a reg. FIXME: remove this restriction.
- Just (cmmMachOpFold dflags (MO_S_Shr rep)
+ Just (cmmMachOpFold platform (MO_S_Shr rep)
[signedQuotRemHelper rep p, CmmLit (CmmInt p rep)])
MO_S_Rem rep
| Just p <- exactLog2 n,
@@ -369,8 +366,8 @@ cmmMachOpFoldM dflags mop [x, (CmmLit (CmmInt n _))]
-- We replace (x `rem` 2^p) by (x - (x `quot` 2^p) * 2^p).
-- Moreover, we fuse MO_S_Shr (last operation of MO_S_Quot)
-- and MO_S_Shl (multiplication by 2^p) into a single MO_And operation.
- Just (cmmMachOpFold dflags (MO_Sub rep)
- [x, cmmMachOpFold dflags (MO_And rep)
+ Just (cmmMachOpFold platform (MO_Sub rep)
+ [x, cmmMachOpFold platform (MO_And rep)
[signedQuotRemHelper rep p, CmmLit (CmmInt (- n) rep)]])
_ -> Nothing
where
diff --git a/compiler/cmm/CmmParse.y b/compiler/GHC/Cmm/Parser.y
index a3bba72..fd18946 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/GHC/Cmm/Parser.y
@@ -198,58 +198,64 @@ necessary to the stack to accommodate it (e.g. 2).
----------------------------------------------------------------------------- -}
{
-module CmmParse ( parseCmmFile ) where
-
-import GhcPrelude
-
-import StgCmmExtCode
-import CmmCallConv
-import StgCmmProf
-import StgCmmHeap
-import StgCmmMonad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit, emitStore
- , emitAssign, emitOutOfLine, withUpdFrameOff
- , getUpdFrameOff )
-import qualified StgCmmMonad as F
-import StgCmmUtils
-import StgCmmForeign
-import StgCmmExpr
-import StgCmmClosure
-import StgCmmLayout hiding (ArgRep(..))
-import StgCmmTicky
-import StgCmmBind ( emitBlackHoleCode, emitUpdateFrame )
-import CoreSyn ( Tickish(SourceNote) )
-
-import CmmOpt
-import MkGraph
-import Cmm
-import CmmUtils
-import CmmSwitch ( mkSwitchTargets )
-import CmmInfo
-import BlockId
-import CmmLex
-import CLabel
-import SMRep
-import Lexer
-import CmmMonad
-
-import CostCentre
-import ForeignCall
-import Module
-import Platform
-import Literal
-import Unique
-import UniqFM
-import SrcLoc
-import DynFlags
-import ErrUtils
-import StringBuffer
-import FastString
-import Panic
-import Constants
-import Outputable
-import BasicTypes
-import Bag ( emptyBag, unitBag )
-import Var
+{-# LANGUAGE TupleSections #-}
+
+module GHC.Cmm.Parser ( parseCmmFile ) where
+
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.Platform.Profile
+
+import GHC.StgToCmm.ExtCode
+import GHC.StgToCmm.Prof
+import GHC.StgToCmm.Heap
+import GHC.StgToCmm.Monad hiding ( getCode, getCodeR, getCodeScoped, emitLabel, emit
+ , emitStore, emitAssign, emitOutOfLine, withUpdFrameOff
+ , getUpdFrameOff, getProfile, getPlatform, getPtrOpts )
+import qualified GHC.StgToCmm.Monad as F
+import GHC.StgToCmm.Utils
+import GHC.StgToCmm.Foreign
+import GHC.StgToCmm.Expr
+import GHC.StgToCmm.Closure
+import GHC.StgToCmm.Layout hiding (ArgRep(..))
+import GHC.StgToCmm.Ticky
+import GHC.StgToCmm.Bind ( emitBlackHoleCode, emitUpdateFrame )
+
+import GHC.Core ( Tickish(SourceNote) )
+
+import GHC.Cmm.Opt
+import GHC.Cmm.Graph
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.Switch ( mkSwitchTargets )
+import GHC.Cmm.Info
+import GHC.Cmm.BlockId
+import GHC.Cmm.Lexer
+import GHC.Cmm.CLabel
+import GHC.Cmm.Monad hiding (getPlatform, getProfile, getPtrOpts)
+import qualified GHC.Cmm.Monad as PD
+import GHC.Cmm.CallConv
+import GHC.Runtime.Heap.Layout
+import GHC.Parser.Lexer
+
+import GHC.Types.CostCentre
+import GHC.Types.ForeignCall
+import GHC.Unit.Module
+import GHC.Types.Literal
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
+import GHC.Types.SrcLoc
+import GHC.Driver.Session
+import GHC.Utils.Error
+import GHC.Data.StringBuffer
+import GHC.Data.FastString
+import GHC.Utils.Panic
+import GHC.Settings.Constants
+import GHC.Utils.Outputable
+import GHC.Types.Basic
+import GHC.Data.Bag ( emptyBag, unitBag )
+import GHC.Types.Var
import Control.Monad
import Data.Array
@@ -257,6 +263,7 @@ import Data.Char ( ord )
import System.Exit
import Data.Maybe
import qualified Data.Map as M
+import qualified Data.ByteString.Char8 as BS8
#include "GhclibHsVersions.h"
}
@@ -372,9 +379,9 @@ cmm :: { CmmParse () }
cmmtop :: { CmmParse () }
: cmmproc { $1 }
| cmmdata { $1 }
- | decl { $1 }
- | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
- {% liftP . withThisPackage $ \pkg ->
+ | decl { $1 }
+ | 'CLOSURE' '(' NAME ',' NAME lits ')' ';'
+ {% liftP . withHomeUnitId $ \pkg ->
do lits <- sequence $6;
staticClosure pkg $3 $5 (map getLit lits) }
@@ -388,36 +395,36 @@ cmmtop :: { CmmParse () }
-- * we can derive closure and info table labels from a single NAME
cmmdata :: { CmmParse () }
- : 'section' STRING '{' data_label statics '}'
+ : 'section' STRING '{' data_label statics '}'
{ do lbl <- $4;
ss <- sequence $5;
- code (emitDecl (CmmData (Section (section $2) lbl) (Statics lbl $ concat ss))) }
+ code (emitDecl (CmmData (Section (section $2) lbl) (CmmStaticsRaw lbl (concat ss)))) }
data_label :: { CmmParse CLabel }
- : NAME ':'
- {% liftP . withThisPackage $ \pkg ->
- return (mkCmmDataLabel pkg $1) }
+ : NAME ':'
+ {% liftP . withHomeUnitId $ \pkg ->
+ return (mkCmmDataLabel pkg (NeedExternDecl False) $1) }
statics :: { [CmmParse [CmmStatic]] }
: {- empty -} { [] }
| static statics { $1 : $2 }
-
+
static :: { CmmParse [CmmStatic] }
: type expr ';' { do e <- $2;
return [CmmStaticLit (getLit e)] }
| type ';' { return [CmmUninitialised
(widthInBytes (typeWidth $1))] }
| 'bits8' '[' ']' STRING ';' { return [mkString $4] }
- | 'bits8' '[' INT ']' ';' { return [CmmUninitialised
+ | 'bits8' '[' INT ']' ';' { return [CmmUninitialised
(fromIntegral $3)] }
- | typenot8 '[' INT ']' ';' { return [CmmUninitialised
- (widthInBytes (typeWidth $1) *
+ | typenot8 '[' INT ']' ';' { return [CmmUninitialised
+ (widthInBytes (typeWidth $1) *
fromIntegral $3)] }
| 'CLOSURE' '(' NAME lits ')'
{ do { lits <- sequence $4
- ; dflags <- getDynFlags
+ ; profile <- getProfile
; return $ map CmmStaticLit $
- mkStaticClosure dflags (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
+ mkStaticClosure profile (mkForeignLabel $3 Nothing ForeignLabelInExternalPackage IsData)
-- mkForeignLabel because these are only used
-- for CHARLIKE and INTLIKE closures in the RTS.
dontCareCCS (map getLit lits) [] [] [] } }
@@ -452,18 +459,18 @@ maybe_body :: { CmmParse () }
info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
: NAME
- {% liftP . withThisPackage $ \pkg ->
+ {% liftP . withHomeUnitId $ \pkg ->
do newFunctionName $1 pkg
return (mkCmmCodeLabel pkg $1, Nothing, []) }
| 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, closure type, description, type
- {% liftP . withThisPackage $ \pkg ->
- do dflags <- getDynFlags
- let prof = profilingInfo dflags $11 $13
+ {% liftP . withHomeUnitId $ \pkg ->
+ do profile <- getProfile
+ let prof = profilingInfo profile $11 $13
rep = mkRTSRep (fromIntegral $9) $
- mkHeapRep dflags False (fromIntegral $5)
+ mkHeapRep profile False (fromIntegral $5)
(fromIntegral $7) Thunk
-- not really Thunk, but that makes the info table
-- we want.
@@ -472,16 +479,16 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
, cit_rep = rep
, cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },
[]) }
-
+
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type
- {% liftP . withThisPackage $ \pkg ->
- do dflags <- getDynFlags
- let prof = profilingInfo dflags $11 $13
+ {% liftP . withHomeUnitId $ \pkg ->
+ do profile <- getProfile
+ let prof = profilingInfo profile $11 $13
ty = Fun 0 (ArgSpec (fromIntegral $15))
-- Arity zero, arg_type $15
rep = mkRTSRep (fromIntegral $9) $
- mkHeapRep dflags False (fromIntegral $5)
+ mkHeapRep profile False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
@@ -493,13 +500,13 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
- {% liftP . withThisPackage $ \pkg ->
- do dflags <- getDynFlags
- let prof = profilingInfo dflags $13 $15
+ {% liftP . withHomeUnitId $ \pkg ->
+ do profile <- getProfile
+ let prof = profilingInfo profile $13 $15
ty = Constr (fromIntegral $9) -- Tag
- (stringToWord8s $13)
+ (BS8.pack $13)
rep = mkRTSRep (fromIntegral $11) $
- mkHeapRep dflags False (fromIntegral $5)
+ mkHeapRep profile False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
@@ -509,15 +516,15 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
-- If profiling is on, this string gets duplicated,
-- but that's the way the old code did it we can fix it some other time.
-
+
| 'INFO_TABLE_SELECTOR' '(' NAME ',' INT ',' INT ',' STRING ',' STRING ')'
-- selector, closure type, description, type
- {% liftP . withThisPackage $ \pkg ->
- do dflags <- getDynFlags
- let prof = profilingInfo dflags $9 $11
+ {% liftP . withHomeUnitId $ \pkg ->
+ do profile <- getProfile
+ let prof = profilingInfo profile $9 $11
ty = ThunkSelector (fromIntegral $5)
rep = mkRTSRep (fromIntegral $7) $
- mkHeapRep dflags False 0 0 ty
+ mkHeapRep profile False 0 0 ty
return (mkCmmEntryLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
@@ -526,7 +533,7 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ')'
-- closure type (no live regs)
- {% liftP . withThisPackage $ \pkg ->
+ {% liftP . withHomeUnitId $ \pkg ->
do let prof = NoProfilingInfo
rep = mkRTSRep (fromIntegral $5) $ mkStackRep []
return (mkCmmRetLabel pkg $3,
@@ -537,12 +544,12 @@ info :: { CmmParse (CLabel, Maybe CmmInfoTable, [LocalReg]) }
| 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs
- {% liftP . withThisPackage $ \pkg ->
- do dflags <- getDynFlags
+ {% liftP . withHomeUnitId $ \pkg ->
+ do platform <- getPlatform
live <- sequence $7
let prof = NoProfilingInfo
-- drop one for the info pointer
- bitmap = mkLiveness dflags (drop 1 live)
+ bitmap = mkLiveness platform (drop 1 live)
rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
return (mkCmmRetLabel pkg $3,
Just $ CmmInfoTable { cit_lbl = mkCmmRetInfoLabel pkg $3
@@ -571,19 +578,19 @@ importName
:: { (FastString, CLabel) }
-- A label imported without an explicit packageId.
- -- These are taken to come frome some foreign, unnamed package.
- : NAME
+ -- These are taken to come from some foreign, unnamed package.
+ : NAME
{ ($1, mkForeignLabel $1 Nothing ForeignLabelInExternalPackage IsFunction) }
-- as previous 'NAME', but 'IsData'
| 'CLOSURE' NAME
{ ($2, mkForeignLabel $2 Nothing ForeignLabelInExternalPackage IsData) }
- -- A label imported with an explicit packageId.
+ -- A label imported with an explicit UnitId.
| STRING NAME
- { ($2, mkCmmCodeLabel (fsToUnitId (mkFastString $1)) $2) }
-
-
+ { ($2, mkCmmCodeLabel (UnitId (mkFastString $1)) $2) }
+
+
names :: { [FastString] }
: NAME { [$1] }
| NAME ',' names { $1 : $3 }
@@ -669,9 +676,9 @@ bool_expr :: { CmmParse BoolExpr }
| expr { do e <- $1; return (BoolTest e) }
bool_op :: { CmmParse BoolExpr }
- : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3;
+ : bool_expr '&&' bool_expr { do e1 <- $1; e2 <- $3;
return (BoolAnd e1 e2) }
- | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3;
+ | bool_expr '||' bool_expr { do e1 <- $1; e2 <- $3;
return (BoolOr e1 e2) }
| '!' bool_expr { do e <- $2; return (BoolNot e) }
| '(' bool_op ')' { $2 }
@@ -682,8 +689,8 @@ safety :: { Safety }
vols :: { [GlobalReg] }
: '[' ']' { [] }
- | '[' '*' ']' {% do df <- getDynFlags
- ; return (realArgRegsCover df) }
+ | '[' '*' ']' {% do platform <- PD.getPlatform
+ ; return (realArgRegsCover platform) }
-- All of them. See comment attached
-- to realArgRegsCover
| '[' globals ']' { $2 }
@@ -757,7 +764,7 @@ expr :: { CmmParse CmmExpr }
expr0 :: { CmmParse CmmExpr }
: INT maybe_ty { return (CmmLit (CmmInt $1 (typeWidth $2))) }
| FLOAT maybe_ty { return (CmmLit (CmmFloat $1 (typeWidth $2))) }
- | STRING { do s <- code (newStringCLit $1);
+ | STRING { do s <- code (newStringCLit $1);
return (CmmLit s) }
| reg { $1 }
| type '[' expr ']' { do e <- $3; return (CmmLoad e $1) }
@@ -767,7 +774,7 @@ expr0 :: { CmmParse CmmExpr }
-- leaving out the type of a literal gives you the native word size in C--
maybe_ty :: { CmmType }
- : {- empty -} {% do dflags <- getDynFlags; return $ bWord dflags }
+ : {- empty -} {% do platform <- PD.getPlatform; return $ bWord platform }
| '::' type { $2 }
cmm_hint_exprs0 :: { [CmmParse (CmmExpr, ForeignHint)] }
@@ -807,7 +814,7 @@ foreign_formals :: { [CmmParse (LocalReg, ForeignHint)] }
| foreign_formal ',' foreign_formals { $1 : $3 }
foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
- : local_lreg { do e <- $1; return (e, (inferCmmHint (CmmReg (CmmLocal e)))) }
+ : local_lreg { do e <- $1; return (e, inferCmmHint (CmmReg (CmmLocal e))) }
| STRING local_lreg {% do h <- parseCmmHint $1;
return $ do
e <- $2; return (e,h) }
@@ -815,14 +822,14 @@ foreign_formal :: { CmmParse (LocalReg, ForeignHint) }
local_lreg :: { CmmParse LocalReg }
: NAME { do e <- lookupName $1;
return $
- case e of
+ case e of
CmmReg (CmmLocal r) -> r
other -> pprPanic "CmmParse:" (ftext $1 <> text " not a local register") }
lreg :: { CmmParse CmmReg }
: NAME { do e <- lookupName $1;
return $
- case e of
+ case e of
CmmReg r -> r
other -> pprPanic "CmmParse:" (ftext $1 <> text " not a register") }
| GLOBALREG { return (CmmGlobal $1) }
@@ -856,7 +863,7 @@ typenot8 :: { CmmType }
| 'bits512' { b512 }
| 'float32' { f32 }
| 'float64' { f64 }
- | 'gcptr' {% do dflags <- getDynFlags; return $ gcWord dflags }
+ | 'gcptr' {% do platform <- PD.getPlatform; return $ gcWord platform }
{
section :: String -> SectionType
@@ -868,18 +875,7 @@ section "bss" = UninitialisedData
section s = OtherSection s
mkString :: String -> CmmStatic
-mkString s = CmmString (map (fromIntegral.ord) s)
-
--- |
--- Given an info table, decide what the entry convention for the proc
--- is. That is, for an INFO_TABLE_RET we want the return convention,
--- otherwise it is a NativeNodeCall.
---
-infoConv :: Maybe CmmInfoTable -> Convention
-infoConv Nothing = NativeNodeCall
-infoConv (Just info)
- | isStackRep (cit_rep info) = NativeReturn
- | otherwise = NativeNodeCall
+mkString s = CmmString (BS8.pack s)
-- mkMachOp infers the type of the MachOp from the type of its first
-- argument. We assume that this is correct: for MachOps that don't have
@@ -887,9 +883,9 @@ infoConv (Just info)
-- the op.
mkMachOp :: (Width -> MachOp) -> [CmmParse CmmExpr] -> CmmParse CmmExpr
mkMachOp fn args = do
- dflags <- getDynFlags
+ platform <- getPlatform
arg_exprs <- sequence args
- return (CmmMachOp (fn (typeWidth (cmmExprType dflags (head arg_exprs)))) arg_exprs)
+ return (CmmMachOp (fn (typeWidth (cmmExprType platform (head arg_exprs)))) arg_exprs)
getLit :: CmmExpr -> CmmLit
getLit (CmmLit l) = l
@@ -899,13 +895,13 @@ getLit _ = panic "invalid literal" -- TODO messy failure
nameToMachOp :: FastString -> PD (Width -> MachOp)
nameToMachOp name =
case lookupUFM machOps name of
- Nothing -> fail ("unknown primitive " ++ unpackFS name)
+ Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
Just m -> return m
exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr)
exprOp name args_code = do
- dflags <- getDynFlags
- case lookupUFM (exprMacros dflags) name of
+ ptr_opts <- PD.getPtrOpts
+ case lookupUFM (exprMacros ptr_opts) name of
Just f -> return $ do
args <- sequence args_code
return (f args)
@@ -913,19 +909,22 @@ exprOp name args_code = do
mo <- nameToMachOp name
return $ mkMachOp mo args_code
-exprMacros :: DynFlags -> UniqFM ([CmmExpr] -> CmmExpr)
-exprMacros dflags = listToUFM [
- ( fsLit "ENTRY_CODE", \ [x] -> entryCode dflags x ),
- ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr dflags x ),
- ( fsLit "STD_INFO", \ [x] -> infoTable dflags x ),
- ( fsLit "FUN_INFO", \ [x] -> funInfoTable dflags x ),
- ( fsLit "GET_ENTRY", \ [x] -> entryCode dflags (closureInfoPtr dflags x) ),
- ( fsLit "GET_STD_INFO", \ [x] -> infoTable dflags (closureInfoPtr dflags x) ),
- ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable dflags (closureInfoPtr dflags x) ),
- ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType dflags x ),
- ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs dflags x ),
- ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs dflags x )
+exprMacros :: PtrOpts -> UniqFM FastString ([CmmExpr] -> CmmExpr)
+exprMacros ptr_opts = listToUFM [
+ ( fsLit "ENTRY_CODE", \ [x] -> entryCode platform x ),
+ ( fsLit "INFO_PTR", \ [x] -> closureInfoPtr ptr_opts x ),
+ ( fsLit "STD_INFO", \ [x] -> infoTable profile x ),
+ ( fsLit "FUN_INFO", \ [x] -> funInfoTable profile x ),
+ ( fsLit "GET_ENTRY", \ [x] -> entryCode platform (closureInfoPtr ptr_opts x) ),
+ ( fsLit "GET_STD_INFO", \ [x] -> infoTable profile (closureInfoPtr ptr_opts x) ),
+ ( fsLit "GET_FUN_INFO", \ [x] -> funInfoTable profile (closureInfoPtr ptr_opts x) ),
+ ( fsLit "INFO_TYPE", \ [x] -> infoTableClosureType profile x ),
+ ( fsLit "INFO_PTRS", \ [x] -> infoTablePtrs profile x ),
+ ( fsLit "INFO_NPTRS", \ [x] -> infoTableNonPtrs profile x )
]
+ where
+ profile = po_profile ptr_opts
+ platform = profilePlatform profile
-- we understand a subset of C-- primitives:
machOps = listToUFM $
@@ -995,40 +994,45 @@ machOps = listToUFM $
( "i2f64", flip MO_SF_Conv W64 )
]
-callishMachOps :: UniqFM ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
+callishMachOps :: UniqFM FastString ([CmmExpr] -> (CallishMachOp, [CmmExpr]))
callishMachOps = listToUFM $
map (\(x, y) -> (mkFastString x, y)) [
- ( "read_barrier", (,) MO_ReadBarrier ),
- ( "write_barrier", (,) MO_WriteBarrier ),
+ ( "read_barrier", (MO_ReadBarrier,)),
+ ( "write_barrier", (MO_WriteBarrier,)),
( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),
( "memset", memcpyLikeTweakArgs MO_Memset ),
( "memmove", memcpyLikeTweakArgs MO_Memmove ),
( "memcmp", memcpyLikeTweakArgs MO_Memcmp ),
- ("prefetch0", (,) $ MO_Prefetch_Data 0),
- ("prefetch1", (,) $ MO_Prefetch_Data 1),
- ("prefetch2", (,) $ MO_Prefetch_Data 2),
- ("prefetch3", (,) $ MO_Prefetch_Data 3),
+ ("prefetch0", (MO_Prefetch_Data 0,)),
+ ("prefetch1", (MO_Prefetch_Data 1,)),
+ ("prefetch2", (MO_Prefetch_Data 2,)),
+ ("prefetch3", (MO_Prefetch_Data 3,)),
- ( "popcnt8", (,) $ MO_PopCnt W8 ),
- ( "popcnt16", (,) $ MO_PopCnt W16 ),
- ( "popcnt32", (,) $ MO_PopCnt W32 ),
- ( "popcnt64", (,) $ MO_PopCnt W64 ),
+ ( "popcnt8", (MO_PopCnt W8,)),
+ ( "popcnt16", (MO_PopCnt W16,)),
+ ( "popcnt32", (MO_PopCnt W32,)),
+ ( "popcnt64", (MO_PopCnt W64,)),
- ( "pdep8", (,) $ MO_Pdep W8 ),
- ( "pdep16", (,) $ MO_Pdep W16 ),
- ( "pdep32", (,) $ MO_Pdep W32 ),
- ( "pdep64", (,) $ MO_Pdep W64 ),
+ ( "pdep8", (MO_Pdep W8,)),
+ ( "pdep16", (MO_Pdep W16,)),
+ ( "pdep32", (MO_Pdep W32,)),
+ ( "pdep64", (MO_Pdep W64,)),
- ( "pext8", (,) $ MO_Pext W8 ),
- ( "pext16", (,) $ MO_Pext W16 ),
- ( "pext32", (,) $ MO_Pext W32 ),
- ( "pext64", (,) $ MO_Pext W64 ),
+ ( "pext8", (MO_Pext W8,)),
+ ( "pext16", (MO_Pext W16,)),
+ ( "pext32", (MO_Pext W32,)),
+ ( "pext64", (MO_Pext W64,)),
- ( "cmpxchg8", (,) $ MO_Cmpxchg W8 ),
- ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
- ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),
- ( "cmpxchg64", (,) $ MO_Cmpxchg W64 )
+ ( "cmpxchg8", (MO_Cmpxchg W8,)),
+ ( "cmpxchg16", (MO_Cmpxchg W16,)),
+ ( "cmpxchg32", (MO_Cmpxchg W32,)),
+ ( "cmpxchg64", (MO_Cmpxchg W64,)),
+
+ ( "xchg8", (MO_Xchg W8,)),
+ ( "xchg16", (MO_Xchg W16,)),
+ ( "xchg32", (MO_Xchg W32,)),
+ ( "xchg64", (MO_Xchg W64,))
-- ToDo: the rest, maybe
-- edit: which rest?
@@ -1053,12 +1057,12 @@ parseSafety :: String -> PD Safety
parseSafety "safe" = return PlaySafe
parseSafety "unsafe" = return PlayRisky
parseSafety "interruptible" = return PlayInterruptible
-parseSafety str = fail ("unrecognised safety: " ++ str)
+parseSafety str = failMsgPD ("unrecognised safety: " ++ str)
parseCmmHint :: String -> PD ForeignHint
parseCmmHint "ptr" = return AddrHint
parseCmmHint "signed" = return SignedHint
-parseCmmHint str = fail ("unrecognised hint: " ++ str)
+parseCmmHint str = failMsgPD ("unrecognised hint: " ++ str)
-- labels are always pointers, so we might as well infer the hint
inferCmmHint :: CmmExpr -> ForeignHint
@@ -1085,12 +1089,12 @@ happyError = PD $ \_ s -> unP srcParseFail s
stmtMacro :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse ())
stmtMacro fun args_code = do
case lookupUFM stmtMacros fun of
- Nothing -> fail ("unknown macro: " ++ unpackFS fun)
+ Nothing -> failMsgPD ("unknown macro: " ++ unpackFS fun)
Just fcode -> return $ do
args <- sequence args_code
code (fcode args)
-stmtMacros :: UniqFM ([CmmExpr] -> FCode ())
+stmtMacros :: UniqFM FastString ([CmmExpr] -> FCode ())
stmtMacros = listToUFM [
( fsLit "CCS_ALLOC", \[words,ccs] -> profAlloc words ccs ),
( fsLit "ENTER_CCS_THUNK", \[e] -> enterCostCentreThunk e ),
@@ -1115,6 +1119,9 @@ stmtMacros = listToUFM [
( fsLit "LOAD_THREAD_STATE", \[] -> emitLoadThreadState ),
( fsLit "SAVE_THREAD_STATE", \[] -> emitSaveThreadState ),
+ ( fsLit "SAVE_REGS", \[] -> emitSaveRegs ),
+ ( fsLit "RESTORE_REGS", \[] -> emitRestoreRegs ),
+
( fsLit "LDV_ENTER", \[e] -> ldvEnter e ),
( fsLit "LDV_RECORD_CREATE", \[e] -> ldvRecordCreate e ),
@@ -1132,15 +1139,14 @@ stmtMacros = listToUFM [
emitPushUpdateFrame :: CmmExpr -> CmmExpr -> FCode ()
emitPushUpdateFrame sp e = do
- dflags <- getDynFlags
- emitUpdateFrame dflags sp mkUpdInfoLabel e
+ emitUpdateFrame sp mkUpdInfoLabel e
pushStackFrame :: [CmmParse CmmExpr] -> CmmParse () -> CmmParse ()
pushStackFrame fields body = do
- dflags <- getDynFlags
+ profile <- getProfile
exprs <- sequence fields
updfr_off <- getUpdFrameOff
- let (new_updfr_off, _, g) = copyOutOflow dflags NativeReturn Ret Old
+ let (new_updfr_off, _, g) = copyOutOflow profile NativeReturn Ret Old
[] updfr_off exprs
emit g
withUpdFrameOff new_updfr_off body
@@ -1151,29 +1157,28 @@ reserveStackFrame
-> CmmParse ()
-> CmmParse ()
reserveStackFrame psize preg body = do
- dflags <- getDynFlags
+ platform <- getPlatform
old_updfr_off <- getUpdFrameOff
reg <- preg
esize <- psize
- let size = case constantFoldExpr dflags esize of
+ let size = case constantFoldExpr platform esize of
CmmLit (CmmInt n _) -> n
_other -> pprPanic "CmmParse: not a compile-time integer: "
(ppr esize)
- let frame = old_updfr_off + wORD_SIZE dflags * fromIntegral size
+ let frame = old_updfr_off + platformWordSizeInBytes platform * fromIntegral size
emitAssign reg (CmmStackSlot Old frame)
withUpdFrameOff frame body
-profilingInfo dflags desc_str ty_str
- = if not (gopt Opt_SccProfilingOn dflags)
+profilingInfo profile desc_str ty_str
+ = if not (profileIsProfiling profile)
then NoProfilingInfo
- else ProfilingInfo (stringToWord8s desc_str)
- (stringToWord8s ty_str)
+ else ProfilingInfo (BS8.pack desc_str) (BS8.pack ty_str)
staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse ()
staticClosure pkg cl_label info payload
- = do dflags <- getDynFlags
- let lits = mkStaticClosure dflags (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
- code $ emitDataLits (mkCmmDataLabel pkg cl_label) lits
+ = do profile <- getProfile
+ let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []
+ code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits
foreignCall
:: String
@@ -1187,14 +1192,14 @@ foreignCall conv_string results_code expr_code args_code safety ret
= do conv <- case conv_string of
"C" -> return CCallConv
"stdcall" -> return StdCallConv
- _ -> fail ("unknown calling convention: " ++ conv_string)
+ _ -> failMsgPD ("unknown calling convention: " ++ conv_string)
return $ do
- dflags <- getDynFlags
+ platform <- getPlatform
results <- sequence results_code
expr <- expr_code
args <- sequence args_code
let
- expr' = adjCallTarget dflags conv expr args
+ expr' = adjCallTarget platform conv expr args
(arg_exprs, arg_hints) = unzip args
(res_regs, res_hints) = unzip results
fc = ForeignConvention conv arg_hints res_hints ret
@@ -1205,38 +1210,38 @@ foreignCall conv_string results_code expr_code args_code safety ret
doReturn :: [CmmParse CmmExpr] -> CmmParse ()
doReturn exprs_code = do
- dflags <- getDynFlags
+ profile <- getProfile
exprs <- sequence exprs_code
updfr_off <- getUpdFrameOff
- emit (mkReturnSimple dflags exprs updfr_off)
+ emit (mkReturnSimple profile exprs updfr_off)
-mkReturnSimple :: DynFlags -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
-mkReturnSimple dflags actuals updfr_off =
- mkReturn dflags e actuals updfr_off
- where e = entryCode dflags (CmmLoad (CmmStackSlot Old updfr_off)
- (gcWord dflags))
+mkReturnSimple :: Profile -> [CmmActual] -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple profile actuals updfr_off =
+ mkReturn profile e actuals updfr_off
+ where e = entryCode platform (CmmLoad (CmmStackSlot Old updfr_off)
+ (gcWord platform))
+ platform = profilePlatform profile
doRawJump :: CmmParse CmmExpr -> [GlobalReg] -> CmmParse ()
doRawJump expr_code vols = do
- dflags <- getDynFlags
+ profile <- getProfile
expr <- expr_code
updfr_off <- getUpdFrameOff
- emit (mkRawJump dflags expr updfr_off vols)
+ emit (mkRawJump profile expr updfr_off vols)
doJumpWithStack :: CmmParse CmmExpr -> [CmmParse CmmExpr]
-> [CmmParse CmmExpr] -> CmmParse ()
doJumpWithStack expr_code stk_code args_code = do
- dflags <- getDynFlags
+ profile <- getProfile
expr <- expr_code
stk_args <- sequence stk_code
args <- sequence args_code
updfr_off <- getUpdFrameOff
- emit (mkJumpExtra dflags NativeNodeCall expr args updfr_off stk_args)
+ emit (mkJumpExtra profile NativeNodeCall expr args updfr_off stk_args)
doCall :: CmmParse CmmExpr -> [CmmParse LocalReg] -> [CmmParse CmmExpr]
-> CmmParse ()
doCall expr_code res_code args_code = do
- dflags <- getDynFlags
expr <- expr_code
args <- sequence args_code
ress <- sequence res_code
@@ -1244,14 +1249,14 @@ doCall expr_code res_code args_code = do
c <- code $ mkCall expr (NativeNodeCall,NativeReturn) ress args updfr_off []
emit c
-adjCallTarget :: DynFlags -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
+adjCallTarget :: Platform -> CCallConv -> CmmExpr -> [(CmmExpr, ForeignHint) ]
-> CmmExpr
-- On Windows, we have to add the '@N' suffix to the label when making
-- a call with the stdcall calling convention.
-adjCallTarget dflags StdCallConv (CmmLit (CmmLabel lbl)) args
- | platformOS (targetPlatform dflags) == OSMinGW32
+adjCallTarget platform StdCallConv (CmmLit (CmmLabel lbl)) args
+ | platformOS platform == OSMinGW32
= CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
- where size (e, _) = max (wORD_SIZE dflags) (widthInBytes (typeWidth (cmmExprType dflags e)))
+ where size (e, _) = max (platformWordSizeInBytes platform) (widthInBytes (typeWidth (cmmExprType platform e)))
-- c.f. CgForeignCall.emitForeignCall
adjCallTarget _ _ expr _
= expr
@@ -1263,7 +1268,7 @@ primCall
-> PD (CmmParse ())
primCall results_code name args_code
= case lookupUFM callishMachOps name of
- Nothing -> fail ("unknown primitive " ++ unpackFS name)
+ Nothing -> failMsgPD ("unknown primitive " ++ unpackFS name)
Just f -> return $ do
results <- sequence results_code
args <- sequence args_code
@@ -1272,7 +1277,7 @@ primCall results_code name args_code
doStore :: CmmType -> CmmParse CmmExpr -> CmmParse CmmExpr -> CmmParse ()
doStore rep addr_code val_code
- = do dflags <- getDynFlags
+ = do platform <- getPlatform
addr <- addr_code
val <- val_code
-- if the specified store type does not match the type of the expr
@@ -1280,7 +1285,7 @@ doStore rep addr_code val_code
-- mismatch to be flagged by cmm-lint. If we don't do this, then
-- the store will happen at the wrong type, and the error will not
-- be noticed.
- let val_width = typeWidth (cmmExprType dflags val)
+ let val_width = typeWidth (cmmExprType platform val)
rep_width = typeWidth rep
let coerce_val
| val_width /= rep_width = CmmMachOp (MO_UU_Conv val_width rep_width) [val]
@@ -1354,7 +1359,7 @@ withSourceNote :: Located a -> Located b -> CmmParse c -> CmmParse c
withSourceNote a b parse = do
name <- getName
case combineSrcSpans (getLoc a) (getLoc b) of
- RealSrcSpan span -> code (emitTick (SourceNote span name)) >> parse
+ RealSrcSpan span _ -> code (emitTick (SourceNote span name)) >> parse
_other -> parse
-- -----------------------------------------------------------------------------
@@ -1374,7 +1379,7 @@ doSwitch :: Maybe (Integer,Integer)
doSwitch mb_range scrut arms deflt
= do
-- Compile code for the default branch
- dflt_entry <-
+ dflt_entry <-
case deflt of
Nothing -> return Nothing
Just e -> do b <- forkLabelledCode e; return (Just b)
@@ -1383,8 +1388,8 @@ doSwitch mb_range scrut arms deflt
table_entries <- mapM emitArm arms
let table = M.fromList (concat table_entries)
- dflags <- getDynFlags
- let range = fromMaybe (0, tARGET_MAX_WORD dflags) mb_range
+ platform <- getPlatform
+ let range = fromMaybe (0, platformMaxWord platform) mb_range
expr <- scrut
-- ToDo: check for out of range and jump to default if necessary
@@ -1408,16 +1413,17 @@ forkLabelledCode p = do
-- The initial environment: we define some constants that the compiler
-- knows about here.
-initEnv :: DynFlags -> Env
-initEnv dflags = listToUFM [
+initEnv :: Profile -> Env
+initEnv profile = listToUFM [
( fsLit "SIZEOF_StgHeader",
- VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize dflags)) (wordWidth dflags)) )),
+ VarN (CmmLit (CmmInt (fromIntegral (fixedHdrSize profile)) (wordWidth platform)) )),
( fsLit "SIZEOF_StgInfoTable",
- VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB dflags)) (wordWidth dflags)) ))
+ VarN (CmmLit (CmmInt (fromIntegral (stdInfoTableSizeB profile)) (wordWidth platform)) ))
]
+ where platform = profilePlatform profile
parseCmmFile :: DynFlags -> FilePath -> IO (Messages, Maybe CmmGroup)
-parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
+parseCmmFile dflags filename = withTiming dflags (text "ParseCmm"<+>brackets (text filename)) (\_ -> ()) $ do
buf <- hGetStringBuffer filename
let
init_loc = mkRealSrcLoc (mkFastString filename) 1 1
@@ -1425,14 +1431,11 @@ parseCmmFile dflags filename = withTiming (pure dflags) (text "ParseCmm"<+>brack
-- reset the lex_state: the Lexer monad leaves some stuff
-- in there we don't want.
case unPD cmmParse dflags init_state of
- PFailed warnFn span err -> do
- let msg = mkPlainErrMsg dflags span err
- errMsgs = (emptyBag, unitBag msg)
- warnMsgs = warnFn dflags
- return (unionMessages warnMsgs errMsgs, Nothing)
+ PFailed pst ->
+ return (getMessages pst dflags, Nothing)
POk pst code -> do
st <- initC
- let fcode = getCmm $ unEC code "global" (initEnv dflags) [] >> return ()
+ let fcode = getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()
(cmm,_) = runC dflags no_module st fcode
let ms = getMessages pst dflags
if (errorsFound dflags ms)
diff --git a/compiler/cmm/CmmPipeline.hs b/compiler/GHC/Cmm/Pipeline.hs
index 7f7c111..ccf3d36 100644
--- a/compiler/cmm/CmmPipeline.hs
+++ b/compiler/GHC/Cmm/Pipeline.hs
@@ -1,32 +1,36 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE TupleSections #-}
-module CmmPipeline (
+module GHC.Cmm.Pipeline (
-- | Converts C-- with an implicit stack and native C-- calls into
-- optimized, CPS converted and native-call-less C--. The latter
-- C-- can be used to generate assembly.
cmmPipeline
) where
-import GhcPrelude
-
-import Cmm
-import CmmLint
-import CmmBuildInfoTables
-import CmmCommonBlockElim
-import CmmImplementSwitchPlans
-import CmmProcPoint
-import CmmContFlowOpt
-import CmmLayoutStack
-import CmmSink
-import Hoopl.Collections
-
-import UniqSupply
-import DynFlags
-import ErrUtils
-import HscTypes
+import GHC.Prelude
+
+import GHC.Cmm
+import GHC.Cmm.Lint
+import GHC.Cmm.Info.Build
+import GHC.Cmm.CommonBlockElim
+import GHC.Cmm.Switch.Implement
+import GHC.Cmm.ProcPoint
+import GHC.Cmm.ContFlowOpt
+import GHC.Cmm.LayoutStack
+import GHC.Cmm.Sink
+import GHC.Cmm.Dataflow.Collections
+
+import GHC.Types.Unique.Supply
+import GHC.Driver.Session
+import GHC.Driver.Backend
+import GHC.Utils.Error
+import GHC.Driver.Types
import Control.Monad
-import Outputable
-import Platform
+import GHC.Utils.Outputable
+import GHC.Platform
+import Data.Either (partitionEithers)
-----------------------------------------------------------------------------
-- | Top level driver for C-- pipeline
@@ -37,22 +41,27 @@ cmmPipeline
-- dynamic flags: -dcmm-lint -ddump-cmm-cps
-> ModuleSRTInfo -- Info about SRTs generated so far
-> CmmGroup -- Input C-- with Procedures
- -> IO (ModuleSRTInfo, CmmGroup) -- Output CPS transformed C--
+ -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C--
-cmmPipeline hsc_env srtInfo prog =
+cmmPipeline hsc_env srtInfo prog = withTimingSilent dflags (text "Cmm pipeline") forceRes $
do let dflags = hsc_dflags hsc_env
- tops <- {-# SCC "tops" #-} mapM (cpsTop hsc_env) prog
+ tops <- {-# SCC "tops" #-} mapM (cpsTop dflags) prog
- (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo tops
- dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" (ppr cmms)
+ let (procs, data_) = partitionEithers tops
+ (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs dflags srtInfo procs data_
+ dumpWith dflags Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (ppr cmms)
return (srtInfo, cmms)
+ where forceRes (info, group) =
+ info `seq` foldr (\decl r -> decl `seq` r) () group
-cpsTop :: HscEnv -> CmmDecl -> IO (CAFEnv, [CmmDecl])
-cpsTop _ p@(CmmData {}) = return (mapEmpty, [p])
-cpsTop hsc_env proc =
+ dflags = hsc_dflags hsc_env
+
+cpsTop :: DynFlags -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))
+cpsTop dflags p@(CmmData _ statics) = return (Right (cafAnalData (targetPlatform dflags) statics, p))
+cpsTop dflags proc =
do
----------- Control-flow optimisations ----------------------------------
@@ -75,19 +84,22 @@ cpsTop hsc_env proc =
-- Any work storing block Labels must be performed _after_
-- elimCommonBlocks
+ ----------- Implement switches ------------------------------------------
g <- {-# SCC "createSwitchPlans" #-}
runUniqSM $ cmmImplementSwitchPlans dflags g
dump Opt_D_dump_cmm_switch "Post switch plan" g
----------- Proc points -------------------------------------------------
- let call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
+ let
+ call_pps :: ProcPointSet -- LabelMap
+ call_pps = {-# SCC "callProcPoints" #-} callProcPoints g
proc_points <-
if splitting_proc_points
then do
pp <- {-# SCC "minimalProcPointSet" #-} runUniqSM $
minimalProcPointSet (targetPlatform dflags) call_pps g
dumpWith dflags Opt_D_dump_cmm_proc "Proc points"
- (ppr l $$ ppr pp $$ ppr g)
+ FormatCMM (ppr l $$ ppr pp $$ ppr g)
return pp
else
return call_pps
@@ -106,16 +118,16 @@ cpsTop hsc_env proc =
Opt_D_dump_cmm_sink "Sink assignments"
------------- CAF analysis ----------------------------------------------
- let cafEnv = {-# SCC "cafAnal" #-} cafAnal call_pps l g
- dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" (ppr cafEnv)
+ let cafEnv = {-# SCC "cafAnal" #-} cafAnal platform call_pps l g
+ dumpWith dflags Opt_D_dump_cmm_caf "CAFEnv" FormatText (ppr cafEnv)
g <- if splitting_proc_points
then do
------------- Split into separate procedures -----------------------
let pp_map = {-# SCC "procPointAnalysis" #-}
procPointAnalysis proc_points g
- dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map" $
- ppr pp_map
+ dumpWith dflags Opt_D_dump_cmm_procmap "procpoint map"
+ FormatCMM (ppr pp_map)
g <- {-# SCC "splitAtProcPoints" #-} runUniqSM $
splitAtProcPoints dflags l call_pps proc_points pp_map
(CmmProc h l v g)
@@ -127,7 +139,7 @@ cpsTop hsc_env proc =
------------- Populate info tables with stack info -----------------
g <- {-# SCC "setInfoTableStackMap" #-}
- return $ map (setInfoTableStackMap dflags stackmaps) g
+ return $ map (setInfoTableStackMap platform stackmaps) g
dumps Opt_D_dump_cmm_info "after setInfoTableStackMap" g
----------- Control-flow optimisations -----------------------------
@@ -139,14 +151,13 @@ cpsTop hsc_env proc =
-- See Note [unreachable blocks]
dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g
- return (cafEnv, g)
+ return (Left (cafEnv, g))
- where dflags = hsc_dflags hsc_env
- platform = targetPlatform dflags
+ where platform = targetPlatform dflags
dump = dumpGraph dflags
dumps flag name
- = mapM_ (dumpWith dflags flag name . ppr)
+ = mapM_ (dumpWith dflags flag name FormatCMM . ppr)
condPass flag pass g dumpflag dumpname =
if gopt flag dflags
@@ -160,8 +171,8 @@ cpsTop hsc_env proc =
-- tablesNextToCode is off. The latter is because we have no
-- label to put on info tables for basic blocks that are not
-- the entry point.
- splitting_proc_points = hscTarget dflags /= HscAsm
- || not (tablesNextToCode dflags)
+ splitting_proc_points = backend dflags /= NCG
+ || not (platformTablesNextToCode platform)
|| -- Note [inconsistent-pic-reg]
usingInconsistentPicReg
usingInconsistentPicReg
@@ -292,7 +303,7 @@ cpsTop hsc_env proc =
-- Sp = Sp + 16
-- ...y...y...
--
--- But since we don't see any benefits from running sinking befroe stack
+-- But since we don't see any benefits from running sinking before stack
-- layout, this situation probably doesn't arise too often in practice.
--
@@ -342,7 +353,7 @@ runUniqSM m = do
dumpGraph :: DynFlags -> DumpFlag -> String -> CmmGraph -> IO ()
dumpGraph dflags flag name g = do
when (gopt Opt_DoCmmLinting dflags) $ do_lint g
- dumpWith dflags flag name (ppr g)
+ dumpWith dflags flag name FormatCMM (ppr g)
where
do_lint g = case cmmLintGraph dflags g of
Just err -> do { fatalErrorMsg dflags err
@@ -350,11 +361,13 @@ dumpGraph dflags flag name g = do
}
Nothing -> return ()
-dumpWith :: DynFlags -> DumpFlag -> String -> SDoc -> IO ()
-dumpWith dflags flag txt sdoc = do
- -- ToDo: No easy way of say "dump all the cmm, *and* split
- -- them into files." Also, -ddump-cmm-verbose doesn't play
- -- nicely with -ddump-to-file, since the headers get omitted.
- dumpIfSet_dyn dflags flag txt sdoc
- when (not (dopt flag dflags)) $
- dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose txt sdoc
+dumpWith :: DynFlags -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
+dumpWith dflags flag txt fmt sdoc = do
+ dumpIfSet_dyn dflags flag txt fmt sdoc
+ when (not (dopt flag dflags)) $
+ -- If `-ddump-cmm-verbose -ddump-to-file` is specified,
+ -- dump each Cmm pipeline stage output to a separate file. #16930
+ when (dopt Opt_D_dump_cmm_verbose dflags)
+ $ dumpAction dflags (mkDumpStyle alwaysQualify)
+ (dumpOptionsFromFlag flag) txt fmt sdoc
+ dumpIfSet_dyn dflags Opt_D_dump_cmm_verbose_by_proc txt fmt sdoc
diff --git a/compiler/cmm/PprCmm.hs b/compiler/GHC/Cmm/Ppr.hs
index 90f26e4..f451550 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/GHC/Cmm/Ppr.hs
@@ -1,4 +1,5 @@
{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts, FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
----------------------------------------------------------------------------
@@ -33,30 +34,29 @@
--
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
-module PprCmm
- ( module PprCmmDecl
- , module PprCmmExpr
+module GHC.Cmm.Ppr
+ ( module GHC.Cmm.Ppr.Decl
+ , module GHC.Cmm.Ppr.Expr
)
where
-import GhcPrelude hiding (succ)
-
-import BlockId ()
-import CLabel
-import Cmm
-import CmmUtils
-import CmmSwitch
-import DynFlags
-import FastString
-import Outputable
-import PprCmmDecl
-import PprCmmExpr
-import Util
-import PprCore ()
-
-import BasicTypes
-import Hoopl.Block
-import Hoopl.Graph
+import GHC.Prelude hiding (succ)
+
+import GHC.Platform
+import GHC.Driver.Session (targetPlatform)
+import GHC.Cmm.CLabel
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.Switch
+import GHC.Data.FastString
+import GHC.Utils.Outputable
+import GHC.Cmm.Ppr.Decl
+import GHC.Cmm.Ppr.Expr
+import GHC.Utils.Misc
+
+import GHC.Types.Basic
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
-------------------------------------------------
-- Outputable instances
@@ -69,7 +69,8 @@ instance Outputable CmmTopInfo where
instance Outputable (CmmNode e x) where
- ppr = pprNode
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprNode (targetPlatform dflags) e
instance Outputable Convention where
ppr = pprConvention
@@ -102,9 +103,8 @@ instance Outputable CmmGraph where
-- Outputting types Cmm contains
pprStackInfo :: CmmStackInfo -> SDoc
-pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
- text "arg_space: " <> ppr arg_space <+>
- text "updfr_space: " <> ppr updfr_space
+pprStackInfo (StackInfo {arg_space=arg_space}) =
+ text "arg_space: " <> ppr arg_space
pprTopInfo :: CmmTopInfo -> SDoc
pprTopInfo (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
@@ -179,26 +179,26 @@ pprForeignTarget (PrimTarget op)
(mkFastString (show op))
Nothing ForeignLabelInThisPackage IsFunction))
-pprNode :: CmmNode e x -> SDoc
-pprNode node = pp_node <+> pp_debug
+pprNode :: Platform -> CmmNode e x -> SDoc
+pprNode platform node = pp_node <+> pp_debug
where
pp_node :: SDoc
- pp_node = sdocWithDynFlags $ \dflags -> case node of
+ pp_node = case node of
-- label:
- CmmEntry id tscope -> lbl <> colon <+>
- (sdocWithDynFlags $ \dflags ->
- ppUnless (gopt Opt_SuppressTicks dflags) (text "//" <+> ppr tscope))
- where
- lbl = if gopt Opt_SuppressUniques dflags
- then text "_lbl_"
- else ppr id
+ CmmEntry id tscope ->
+ (sdocOption sdocSuppressUniques $ \case
+ True -> text "_lbl_"
+ False -> ppr id
+ )
+ <> colon
+ <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)
-- // text
CmmComment s -> text "//" <+> ftext s
-- //tick bla<...>
- CmmTick t -> ppUnless (gopt Opt_SuppressTicks dflags) $
- text "//tick" <+> ppr t
+ CmmTick t -> ppUnlessOption sdocSuppressTicks
+ (text "//tick" <+> ppr t)
-- unwind reg = expr;
CmmUnwind regs ->
@@ -211,8 +211,7 @@ pprNode node = pp_node <+> pp_debug
-- rep[lv] = expr;
CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
where
- rep = sdocWithDynFlags $ \dflags ->
- ppr ( cmmExprType dflags expr )
+ rep = ppr ( cmmExprType platform expr )
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs
index c4ee6fd..43a341b 100644
--- a/compiler/cmm/PprCmmDecl.hs
+++ b/compiler/GHC/Cmm/Ppr/Decl.hs
@@ -1,3 +1,5 @@
+{-# LANGUAGE GADTs #-}
+
----------------------------------------------------------------------------
--
-- Pretty-printing of common Cmm types
@@ -33,35 +35,35 @@
--
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module PprCmmDecl
+module GHC.Cmm.Ppr.Decl
( writeCmms, pprCmms, pprCmmGroup, pprSection, pprStatic
)
where
-import GhcPrelude
+import GHC.Prelude
-import PprCmmExpr
-import Cmm
+import GHC.Platform
+import GHC.Cmm.Ppr.Expr
+import GHC.Cmm
-import DynFlags
-import Outputable
-import FastString
+import GHC.Driver.Session
+import GHC.Utils.Outputable
+import GHC.Data.FastString
import Data.List
import System.IO
--- Temp Jan08
-import SMRep
+import qualified Data.ByteString as BS
pprCmms :: (Outputable info, Outputable g)
- => [GenCmmGroup CmmStatics info g] -> SDoc
+ => [GenCmmGroup RawCmmStatics info g] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ text "-------------------" $$ space
writeCmms :: (Outputable info, Outputable g)
- => DynFlags -> Handle -> [GenCmmGroup CmmStatics info g] -> IO ()
+ => DynFlags -> Handle -> [GenCmmGroup RawCmmStatics info g] -> IO ()
writeCmms dflags handle cmms = printForC dflags handle (pprCmms cmms)
-----------------------------------------------------------------------------
@@ -70,11 +72,12 @@ instance (Outputable d, Outputable info, Outputable i)
=> Outputable (GenCmmDecl d info i) where
ppr t = pprTop t
-instance Outputable CmmStatics where
+instance Outputable (GenCmmStatics a) where
ppr = pprStatics
instance Outputable CmmStatic where
- ppr = pprStatic
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprStatic (targetPlatform dflags) e
instance Outputable CmmInfoTable where
ppr = pprInfoTable
@@ -95,7 +98,7 @@ pprTop :: (Outputable d, Outputable info, Outputable i)
pprTop (CmmProc info lbl live graph)
- = vcat [ ppr lbl <> lparen <> rparen <+> text "// " <+> ppr live
+ = vcat [ ppr lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live
, nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ ppr graph
, rbrace ]
@@ -121,8 +124,8 @@ pprInfoTable (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
, case prof_info of
NoProfilingInfo -> empty
ProfilingInfo ct cd ->
- vcat [ text "type: " <> pprWord8String ct
- , text "desc: " <> pprWord8String cd ]
+ vcat [ text "type: " <> text (show (BS.unpack ct))
+ , text "desc: " <> text (show (BS.unpack cd)) ]
, text "srt: " <> ppr srt ]
instance Outputable ForeignHint where
@@ -137,14 +140,18 @@ instance Outputable ForeignHint where
-- Strings are printed as C strings, and we print them as I8[],
-- following C--
--
-pprStatics :: CmmStatics -> SDoc
-pprStatics (Statics lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
-pprStatic :: CmmStatic -> SDoc
-pprStatic s = case s of
- CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit lit <> semi
+pprStatics :: GenCmmStatics a -> SDoc
+pprStatics (CmmStatics lbl itbl ccs payload) =
+ ppr lbl <> colon <+> ppr itbl <+> ppr ccs <+> ppr payload
+pprStatics (CmmStaticsRaw lbl ds) = vcat ((ppr lbl <> colon) : map ppr ds)
+
+pprStatic :: Platform -> CmmStatic -> SDoc
+pprStatic platform s = case s of
+ CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi
CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
+ CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path)
-- --------------------------------------------------------------------------
-- data sections
diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
index 7bf73f1..5bed66d 100644
--- a/compiler/cmm/PprCmmExpr.hs
+++ b/compiler/GHC/Cmm/Ppr/Expr.hs
@@ -31,19 +31,21 @@
--
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
--
-
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-module PprCmmExpr
+
+module GHC.Cmm.Ppr.Expr
( pprExpr, pprLit
)
where
-import GhcPrelude
+import GHC.Prelude
-import CmmExpr
+import GHC.Platform
+import GHC.Driver.Session (targetPlatform)
+import GHC.Cmm.Expr
-import Outputable
-import DynFlags
+import GHC.Utils.Outputable
import Data.Maybe
import Numeric ( fromRat )
@@ -51,13 +53,15 @@ import Numeric ( fromRat )
-----------------------------------------------------------------------------
instance Outputable CmmExpr where
- ppr e = pprExpr e
+ ppr e = sdocWithDynFlags $ \dflags ->
+ pprExpr (targetPlatform dflags) e
instance Outputable CmmReg where
ppr e = pprReg e
instance Outputable CmmLit where
- ppr l = pprLit l
+ ppr l = sdocWithDynFlags $ \dflags ->
+ pprLit (targetPlatform dflags) l
instance Outputable LocalReg where
ppr e = pprLocalReg e
@@ -72,18 +76,17 @@ instance Outputable GlobalReg where
-- Expressions
--
-pprExpr :: CmmExpr -> SDoc
-pprExpr e
- = sdocWithDynFlags $ \dflags ->
- case e of
+pprExpr :: Platform -> CmmExpr -> SDoc
+pprExpr platform e
+ = case e of
CmmRegOff reg i ->
- pprExpr (CmmMachOp (MO_Add rep)
+ pprExpr platform (CmmMachOp (MO_Add rep)
[CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
- where rep = typeWidth (cmmRegType dflags reg)
- CmmLit lit -> pprLit lit
- _other -> pprExpr1 e
+ where rep = typeWidth (cmmRegType platform reg)
+ CmmLit lit -> pprLit platform lit
+ _other -> pprExpr1 platform e
--- Here's the precedence table from CmmParse.y:
+-- Here's the precedence table from GHC.Cmm.Parser:
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
-- %left '|'
-- %left '^'
@@ -97,10 +100,11 @@ pprExpr e
-- a default conservative behaviour.
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
-pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
-pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
- = pprExpr7 x <+> doc <+> pprExpr7 y
-pprExpr1 e = pprExpr7 e
+pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc
+pprExpr1 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp1 op
+ = pprExpr7 platform x <+> doc <+> pprExpr7 platform y
+pprExpr1 platform e = pprExpr7 platform e
infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
@@ -115,55 +119,57 @@ infixMachOp1 (MO_U_Lt _) = Just (char '<')
infixMachOp1 _ = Nothing
-- %left '-' '+'
-pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
- = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
-pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
- = pprExpr7 x <+> doc <+> pprExpr8 y
-pprExpr7 e = pprExpr8 e
+pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
+ = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
+pprExpr7 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp7 op
+ = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
+pprExpr7 platform e = pprExpr8 platform e
infixMachOp7 (MO_Add _) = Just (char '+')
infixMachOp7 (MO_Sub _) = Just (char '-')
infixMachOp7 _ = Nothing
-- %left '/' '*' '%'
-pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
- = pprExpr8 x <+> doc <+> pprExpr9 y
-pprExpr8 e = pprExpr9 e
+pprExpr8 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp8 op
+ = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
+pprExpr8 platform e = pprExpr9 platform e
infixMachOp8 (MO_U_Quot _) = Just (char '/')
infixMachOp8 (MO_Mul _) = Just (char '*')
infixMachOp8 (MO_U_Rem _) = Just (char '%')
infixMachOp8 _ = Nothing
-pprExpr9 :: CmmExpr -> SDoc
-pprExpr9 e =
+pprExpr9 :: Platform -> CmmExpr -> SDoc
+pprExpr9 platform e =
case e of
- CmmLit lit -> pprLit1 lit
+ CmmLit lit -> pprLit1 platform lit
CmmLoad expr rep -> ppr rep <> brackets (ppr expr)
CmmReg reg -> ppr reg
CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
- CmmMachOp mop args -> genMachOp mop args
+ CmmMachOp mop args -> genMachOp platform mop args
-genMachOp :: MachOp -> [CmmExpr] -> SDoc
-genMachOp mop args
+genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
+genMachOp platform mop args
| Just doc <- infixMachOp mop = case args of
-- dyadic
- [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+ [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y
-- unary
- [x] -> doc <> pprExpr9 x
+ [x] -> doc <> pprExpr9 platform x
- _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
+ _ -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args"
(pprMachOp mop <+>
- parens (hcat $ punctuate comma (map pprExpr args)))
+ parens (hcat $ punctuate comma (map (pprExpr platform) args)))
empty
| isJust (infixMachOp1 mop)
|| isJust (infixMachOp7 mop)
- || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
+ || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args))
- | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr args))
+ | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args))
where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
(show mop))
-- replace spaces in (show mop) with underscores,
@@ -187,16 +193,15 @@ infixMachOp mop
-- To minimise line noise we adopt the convention that if the literal
-- has the natural machine word size, we do not append the type
--
-pprLit :: CmmLit -> SDoc
-pprLit lit = sdocWithDynFlags $ \dflags ->
- case lit of
+pprLit :: Platform -> CmmLit -> SDoc
+pprLit platform lit = case lit of
CmmInt i rep ->
hcat [ (if i < 0 then parens else id)(integer i)
- , ppUnless (rep == wordWidth dflags) $
+ , ppUnless (rep == wordWidth platform) $
space <> dcolon <+> ppr rep ]
CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
- CmmVec lits -> char '<' <> commafy (map pprLit lits) <> char '>'
+ CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'
CmmLabel clbl -> ppr clbl
CmmLabelOff clbl i -> ppr clbl <> ppr_offset i
CmmLabelDiffOff clbl1 clbl2 i _ -> ppr clbl1 <> char '-'
@@ -204,9 +209,9 @@ pprLit lit = sdocWithDynFlags $ \dflags ->
CmmBlock id -> ppr id
CmmHighStackMark -> text "<highSp>"
-pprLit1 :: CmmLit -> SDoc
-pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
-pprLit1 lit = pprLit lit
+pprLit1 :: Platform -> CmmLit -> SDoc
+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)
+pprLit1 platform lit = pprLit platform lit
ppr_offset :: Int -> SDoc
ppr_offset i
@@ -227,18 +232,17 @@ pprReg r
-- We only print the type of the local reg if it isn't wordRep
--
pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq rep) = sdocWithDynFlags $ \dflags ->
+pprLocalReg (LocalReg uniq rep) =
-- = ppr rep <> char '_' <> ppr uniq
-- Temp Jan08
- char '_' <> pprUnique dflags uniq <>
+ char '_' <> pprUnique uniq <>
(if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
then dcolon <> ptr <> ppr rep
else dcolon <> ptr <> ppr rep)
where
- pprUnique dflags unique =
- if gopt Opt_SuppressUniques dflags
- then text "_locVar_"
- else ppr unique
+ pprUnique unique = sdocOption sdocSuppressUniques $ \case
+ True -> text "_locVar_"
+ False -> ppr unique
ptr = empty
--if isGcPtrType rep
-- then doubleQuotes (text "ptr")
@@ -249,7 +253,7 @@ pprArea :: Area -> SDoc
pprArea Old = text "old"
pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
--- needs to be kept in syn with CmmExpr.hs.GlobalReg
+-- needs to be kept in syn with 'GHC.Cmm.Expr.GlobalReg'
--
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg gr
diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs
index 427de3b..cca6931 100644
--- a/compiler/cmm/CmmProcPoint.hs
+++ b/compiler/GHC/Cmm/ProcPoint.hs
@@ -1,6 +1,7 @@
{-# LANGUAGE GADTs, DisambiguateRecordFields, BangPatterns #-}
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-module CmmProcPoint
+module GHC.Cmm.ProcPoint
( ProcPointSet, Status(..)
, callProcPoints, minimalProcPointSet
, splitAtProcPoints, procPointAnalysis
@@ -8,28 +9,28 @@ module CmmProcPoint
)
where
-import GhcPrelude hiding (last, unzip, succ, zip)
-
-import DynFlags
-import BlockId
-import CLabel
-import Cmm
-import PprCmm ()
-import CmmUtils
-import CmmInfo
-import CmmLive
-import CmmSwitch
+import GHC.Prelude hiding (last, unzip, succ, zip)
+
+import GHC.Driver.Session
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Cmm
+import GHC.Cmm.Ppr () -- For Outputable instances
+import GHC.Cmm.Utils
+import GHC.Cmm.Info
+import GHC.Cmm.Liveness
+import GHC.Cmm.Switch
import Data.List (sortBy)
-import Maybes
+import GHC.Data.Maybe
import Control.Monad
-import Outputable
-import Platform
-import UniqSupply
-import Hoopl.Block
-import Hoopl.Collections
-import Hoopl.Dataflow
-import Hoopl.Graph
-import Hoopl.Label
+import GHC.Utils.Outputable
+import GHC.Platform
+import GHC.Types.Unique.Supply
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
-- Compute a minimal set of proc points for a control-flow graph.
@@ -314,10 +315,12 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
-- when jumping to a PP that has an info table, if
-- tablesNextToCode is off we must jump to the entry
-- label instead.
+ platform = targetPlatform dflags
+ tablesNextToCode = platformTablesNextToCode platform
jump_label (Just info_lbl) _
- | tablesNextToCode dflags = info_lbl
- | otherwise = toEntryLbl info_lbl
- jump_label Nothing block_lbl = block_lbl
+ | tablesNextToCode = info_lbl
+ | otherwise = toEntryLbl platform info_lbl
+ jump_label Nothing block_lbl = block_lbl
add_if_pp id rst = case mapLookup id procLabels of
Just (lbl, mb_info_lbl) -> (id, jump_label mb_info_lbl lbl) : rst
@@ -355,7 +358,6 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
g' = replacePPIds g
live = ppLiveness (g_entry g')
stack_info = StackInfo { arg_space = 0
- , updfr_space = Nothing
, do_layout = True }
-- cannot use panic, this is printed by -ddump-cmm
@@ -386,7 +388,7 @@ splitAtProcPoints dflags entry_label callPPs procPoints procMap
procs
splitAtProcPoints _ _ _ _ _ t@(CmmData _ _) = return [t]
--- Only called from CmmProcPoint.splitAtProcPoints. NB. does a
+-- Only called from GHC.Cmm.ProcPoint.splitAtProcPoints. NB. does a
-- recursive lookup, see comment below.
replaceBranches :: LabelMap BlockId -> CmmGraph -> CmmGraph
replaceBranches env cmmg
diff --git a/compiler/cmm/CmmSink.hs b/compiler/GHC/Cmm/Sink.hs
index 6317cfe..bd8c19d 100644
--- a/compiler/cmm/CmmSink.hs
+++ b/compiler/GHC/Cmm/Sink.hs
@@ -1,25 +1,24 @@
{-# LANGUAGE GADTs #-}
-module CmmSink (
+module GHC.Cmm.Sink (
cmmSink
) where
-import GhcPrelude
+import GHC.Prelude
-import Cmm
-import CmmOpt
-import CmmLive
-import CmmUtils
-import Hoopl.Block
-import Hoopl.Label
-import Hoopl.Collections
-import Hoopl.Graph
-import CodeGen.Platform
-import Platform (isARM, platformArch)
+import GHC.Cmm
+import GHC.Cmm.Opt
+import GHC.Cmm.Liveness
+import GHC.Cmm.Utils
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Graph
+import GHC.Platform.Regs
-import DynFlags
-import Unique
-import UniqFM
-import PprCmm ()
+import GHC.Platform
+import GHC.Driver.Session
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
import qualified Data.IntSet as IntSet
import Data.List (partition)
@@ -133,7 +132,7 @@ elemLRegSet l = IntSet.member (getKey (getUnique l))
--
-- a nice loop, but we didn't eliminate the silly assignment at the end.
-- See Note [dependent assignments], which would probably fix this.
--- This is #8336 on Trac.
+-- This is #8336.
--
-- -----------
-- (2) From stg_atomically_frame in PrimOps.cmm
@@ -182,6 +181,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- pprTrace "sink" (ppr lbl) $
blockJoin first final_middle final_last : sink sunk' bs
where
+ platform = targetPlatform dflags
lbl = entryLabel b
(first, middle, last) = blockSplit b
@@ -196,7 +196,7 @@ cmmSink dflags graph = ofBlockList (g_entry graph) $ sink mapEmpty $ blocks
-- Now sink and inline in this block
(middle', assigs) = walk dflags ann_middles (mapFindWithDefault [] lbl sunk)
- fold_last = constantFoldNode dflags last
+ fold_last = constantFoldNode platform last
(final_last, assigs') = tryToInline dflags live fold_last assigs
-- We cannot sink into join points (successors with more than
@@ -331,12 +331,13 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
where
go [] block as = (block, as)
go ((live,node):ns) block as
- | shouldDiscard node live = go ns block as
+ | shouldDiscard node live = go ns block as
-- discard dead assignment
- | Just a <- shouldSink dflags node2 = go ns block (a : as1)
- | otherwise = go ns block' as'
+ | Just a <- shouldSink platform node2 = go ns block (a : as1)
+ | otherwise = go ns block' as'
where
- node1 = constantFoldNode dflags node
+ platform = targetPlatform dflags
+ node1 = constantFoldNode platform node
(node2, as1) = tryToInline dflags live node1 as
@@ -352,8 +353,8 @@ walk dflags nodes assigs = go nodes emptyBlock assigs
-- be profitable to sink assignments to global regs too, but the
-- liveness analysis doesn't track those (yet) so we can't.
--
-shouldSink :: DynFlags -> CmmNode e x -> Maybe Assignment
-shouldSink dflags (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem dflags e)
+shouldSink :: Platform -> CmmNode e x -> Maybe Assignment
+shouldSink platform (CmmAssign (CmmLocal r) e) | no_local_regs = Just (r, e, exprMem platform e)
where no_local_regs = True -- foldRegsUsed (\_ _ -> False) True e
shouldSink _ _other = Nothing
@@ -419,7 +420,7 @@ tryToInline
tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
where
- usages :: UniqFM Int -- Maps each LocalReg to a count of how often it is used
+ usages :: UniqFM LocalReg Int -- Maps each LocalReg to a count of how often it is used
usages = foldLocalRegsUsed dflags addUsage emptyUFM node
go _usages node _skipped [] = (node, [])
@@ -431,6 +432,7 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
| isTrivial dflags rhs = inline_and_keep
| otherwise = dont_inline
where
+ platform = targetPlatform dflags
inline_and_discard = go usages' inl_node skipped rest
where usages' = foldLocalRegsUsed dflags addUsage usages rhs
@@ -463,9 +465,9 @@ tryToInline dflags live node assigs = go usages node emptyLRegSet assigs
-- inl_exp is where the inlining actually takes place!
inl_exp (CmmReg (CmmLocal l')) | l == l' = rhs
inl_exp (CmmRegOff (CmmLocal l') off) | l == l'
- = cmmOffset dflags rhs off
+ = cmmOffset platform rhs off
-- re-constant fold after inlining
- inl_exp (CmmMachOp op args) = cmmMachOpFold dflags op args
+ inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args
inl_exp other = other
@@ -491,7 +493,7 @@ and apply above transformation to eliminate the comparison against 1.
It's tempting to just turn every != into == and then let cmmMachOpFold
do its thing, but that risks changing a nice fall-through conditional
into one that requires two jumps. (see swapcond_last in
-CmmContFlowOpt), so instead we carefully look for just the cases where
+GHC.Cmm.ContFlowOpt), so instead we carefully look for just the cases where
we can eliminate a comparison.
-}
improveConditional :: CmmNode O x -> CmmNode O x
@@ -551,7 +553,7 @@ improveConditional other = other
-- inline y, and we have a dead assignment to x. If we don't notice
-- that x is dead in tryToInline, we end up retaining it.
-addUsage :: UniqFM Int -> LocalReg -> UniqFM Int
+addUsage :: UniqFM LocalReg Int -> LocalReg -> UniqFM LocalReg Int
addUsage m r = addToUFM_C (+) m r 1
regsUsedIn :: LRegSet -> CmmExpr -> Bool
@@ -566,7 +568,7 @@ regsUsedIn ls e = wrapRecExpf f e False
-- clashing with C argument-passing registers, really the back-end
-- ought to be able to handle it properly, but currently neither PprC
-- nor the NCG can do it. See Note [Register parameter passing]
--- See also StgCmmForeign:load_args_into_temps.
+-- See also GHC.StgToCmm.Foreign.load_args_into_temps.
okToInline :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
okToInline dflags expr node@(CmmUnsafeForeignCall{}) =
not (globalRegistersConflict dflags expr node)
@@ -589,7 +591,7 @@ conflicts dflags (r, rhs, addr) node
-- (3) a store to an address conflicts with a read of the same memory
| CmmStore addr' e <- node
- , memConflicts addr (loadAddr dflags addr' (cmmExprWidth dflags e)) = True
+ , memConflicts addr (loadAddr platform addr' (cmmExprWidth platform e)) = True
-- (4) an assignment to Hp/Sp conflicts with a heap/stack read respectively
| HeapMem <- addr, CmmAssign (CmmGlobal Hp) _ <- node = True
@@ -604,19 +606,21 @@ conflicts dflags (r, rhs, addr) node
-- (7) otherwise, no conflict
| otherwise = False
+ where
+ platform = targetPlatform dflags
-- Returns True if node defines any global registers that are used in the
-- Cmm expression
globalRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
globalRegistersConflict dflags expr node =
- foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmGlobal r) expr)
+ foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmGlobal r) expr)
False node
-- Returns True if node defines any local registers that are used in the
-- Cmm expression
localRegistersConflict :: DynFlags -> CmmExpr -> CmmNode e x -> Bool
localRegistersConflict dflags expr node =
- foldRegsDefd dflags (\b r -> b || regUsedIn dflags (CmmLocal r) expr)
+ foldRegsDefd dflags (\b r -> b || regUsedIn (targetPlatform dflags) (CmmLocal r) expr)
False node
-- Note [Sinking and calls]
@@ -746,24 +750,24 @@ memConflicts (SpMem o1 w1) (SpMem o2 w2)
| otherwise = o2 + w2 > o1
memConflicts _ _ = True
-exprMem :: DynFlags -> CmmExpr -> AbsMem
-exprMem dflags (CmmLoad addr w) = bothMems (loadAddr dflags addr (typeWidth w)) (exprMem dflags addr)
-exprMem dflags (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem dflags) es)
-exprMem _ _ = NoMem
+exprMem :: Platform -> CmmExpr -> AbsMem
+exprMem platform (CmmLoad addr w) = bothMems (loadAddr platform addr (typeWidth w)) (exprMem platform addr)
+exprMem platform (CmmMachOp _ es) = foldr bothMems NoMem (map (exprMem platform) es)
+exprMem _ _ = NoMem
-loadAddr :: DynFlags -> CmmExpr -> Width -> AbsMem
-loadAddr dflags e w =
+loadAddr :: Platform -> CmmExpr -> Width -> AbsMem
+loadAddr platform e w =
case e of
- CmmReg r -> regAddr dflags r 0 w
- CmmRegOff r i -> regAddr dflags r i w
- _other | regUsedIn dflags spReg e -> StackMem
- | otherwise -> AnyMem
+ CmmReg r -> regAddr platform r 0 w
+ CmmRegOff r i -> regAddr platform r i w
+ _other | regUsedIn platform spReg e -> StackMem
+ | otherwise -> AnyMem
-regAddr :: DynFlags -> CmmReg -> Int -> Width -> AbsMem
+regAddr :: Platform -> CmmReg -> Int -> Width -> AbsMem
regAddr _ (CmmGlobal Sp) i w = SpMem i (widthInBytes w)
regAddr _ (CmmGlobal Hp) _ _ = HeapMem
regAddr _ (CmmGlobal CurrentTSO) _ _ = HeapMem -- important for PrimOps
-regAddr dflags r _ _ | isGcPtrType (cmmRegType dflags r) = HeapMem -- yay! GCPtr pays for itself
+regAddr platform r _ _ | isGcPtrType (cmmRegType platform r) = HeapMem -- yay! GCPtr pays for itself
regAddr _ _ _ _ = AnyMem
{-
diff --git a/compiler/GHC/Cmm/Switch/Implement.hs b/compiler/GHC/Cmm/Switch/Implement.hs
new file mode 100644
index 0000000..a91809e
--- /dev/null
+++ b/compiler/GHC/Cmm/Switch/Implement.hs
@@ -0,0 +1,118 @@
+{-# LANGUAGE GADTs #-}
+module GHC.Cmm.Switch.Implement
+ ( cmmImplementSwitchPlans
+ )
+where
+
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.BlockId
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.Switch
+import GHC.Types.Unique.Supply
+import GHC.Driver.Session
+import GHC.Utils.Monad (concatMapM)
+
+--
+-- This module replaces Switch statements as generated by the Stg -> Cmm
+-- transformation, which might be huge and sparse and hence unsuitable for
+-- assembly code, by proper constructs (if-then-else trees, dense jump tables).
+--
+-- The actual, abstract strategy is determined by createSwitchPlan in
+-- GHC.Cmm.Switch and returned as a SwitchPlan; here is just the implementation in
+-- terms of Cmm code. See Note [Cmm Switches, the general plan] in GHC.Cmm.Switch.
+--
+-- This division into different modules is both to clearly separate concerns,
+-- but also because createSwitchPlan needs access to the constructors of
+-- SwitchTargets, a data type exported abstractly by GHC.Cmm.Switch.
+--
+
+-- | Traverses the 'CmmGraph', making sure that 'CmmSwitch' are suitable for
+-- code generation.
+cmmImplementSwitchPlans :: DynFlags -> CmmGraph -> UniqSM CmmGraph
+cmmImplementSwitchPlans dflags g
+ -- Switch generation done by backend (LLVM/C)
+ | backendSupportsSwitch (backend dflags) = return g
+ | otherwise = do
+ blocks' <- concatMapM (visitSwitches (targetPlatform dflags)) (toBlockList g)
+ return $ ofBlockList (g_entry g) blocks'
+
+visitSwitches :: Platform -> CmmBlock -> UniqSM [CmmBlock]
+visitSwitches platform block
+ | (entry@(CmmEntry _ scope), middle, CmmSwitch vanillaExpr ids) <- blockSplit block
+ = do
+ let plan = createSwitchPlan ids
+ -- See Note [Floating switch expressions]
+ (assignSimple, simpleExpr) <- floatSwitchExpr platform vanillaExpr
+
+ (newTail, newBlocks) <- implementSwitchPlan platform scope simpleExpr plan
+
+ let block' = entry `blockJoinHead` middle `blockAppend` assignSimple `blockAppend` newTail
+
+ return $ block' : newBlocks
+
+ | otherwise
+ = return [block]
+
+-- Note [Floating switch expressions]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- When we translate a sparse switch into a search tree we would like
+-- to compute the value we compare against only once.
+
+-- For this purpose we assign the switch expression to a local register
+-- and then use this register when constructing the actual binary tree.
+
+-- This is important as the expression could contain expensive code like
+-- memory loads or divisions which we REALLY don't want to duplicate.
+
+-- This happened in parts of the handwritten RTS Cmm code. See also #16933
+
+-- See Note [Floating switch expressions]
+floatSwitchExpr :: Platform -> CmmExpr -> UniqSM (Block CmmNode O O, CmmExpr)
+floatSwitchExpr _ reg@(CmmReg {}) = return (emptyBlock, reg)
+floatSwitchExpr platform expr = do
+ (assign, expr') <- cmmMkAssign platform expr <$> getUniqueM
+ return (BMiddle assign, expr')
+
+
+-- Implementing a switch plan (returning a tail block)
+implementSwitchPlan :: Platform -> CmmTickScope -> CmmExpr -> SwitchPlan -> UniqSM (Block CmmNode O C, [CmmBlock])
+implementSwitchPlan platform scope expr = go
+ where
+ go (Unconditionally l)
+ = return (emptyBlock `blockJoinTail` CmmBranch l, [])
+ go (JumpTable ids)
+ = return (emptyBlock `blockJoinTail` CmmSwitch expr ids, [])
+ go (IfLT signed i ids1 ids2)
+ = do
+ (bid1, newBlocks1) <- go' ids1
+ (bid2, newBlocks2) <- go' ids2
+
+ let lt | signed = cmmSLtWord
+ | otherwise = cmmULtWord
+ scrut = lt platform expr $ CmmLit $ mkWordCLit platform i
+ lastNode = CmmCondBranch scrut bid1 bid2 Nothing
+ lastBlock = emptyBlock `blockJoinTail` lastNode
+ return (lastBlock, newBlocks1++newBlocks2)
+ go (IfEqual i l ids2)
+ = do
+ (bid2, newBlocks2) <- go' ids2
+
+ let scrut = cmmNeWord platform expr $ CmmLit $ mkWordCLit platform i
+ lastNode = CmmCondBranch scrut bid2 l Nothing
+ lastBlock = emptyBlock `blockJoinTail` lastNode
+ return (lastBlock, newBlocks2)
+
+ -- Same but returning a label to branch to
+ go' (Unconditionally l)
+ = return (l, [])
+ go' p
+ = do
+ bid <- mkBlockId `fmap` getUniqueM
+ (last, newBlocks) <- go p
+ let block = CmmEntry bid scope `blockJoinHead` last
+ return (bid, block: newBlocks)
diff --git a/compiler/cmm/CmmUtils.hs b/compiler/GHC/Cmm/Utils.hs
index a5d1a8e..d762f0d 100644
--- a/compiler/cmm/CmmUtils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -1,4 +1,8 @@
{-# LANGUAGE GADTs, RankNTypes #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE LambdaCase #-}
+
+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
-----------------------------------------------------------------------------
--
@@ -8,7 +12,7 @@
--
-----------------------------------------------------------------------------
-module CmmUtils(
+module GHC.Cmm.Utils(
-- CmmType
primRepCmmType, slotCmmType, slotForeignHint,
typeCmmType, typeForeignHint, primRepForeignHint,
@@ -16,7 +20,7 @@ module CmmUtils(
-- CmmLit
zeroCLit, mkIntCLit,
mkWordCLit, packHalfWordsCLit,
- mkByteStringCLit,
+ mkByteStringCLit, mkFileEmbedLit,
mkDataLits, mkRODataLits,
mkStgWordCLit,
@@ -35,17 +39,16 @@ module CmmUtils(
cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord,
cmmToWord,
+ cmmMkAssign,
+
isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,
baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
currentTSOExpr, currentNurseryExpr, cccsExpr,
- -- Statics
- blankWord,
-
-- Tagging
cmmTagMask, cmmPointerMask, cmmUntag, cmmIsTagged,
- cmmConstrTag1,
+ cmmConstrTag1, mAX_PTR_TAG, tAG_MASK,
-- Overlap and usage
regsOverlap, regUsedIn,
@@ -65,25 +68,27 @@ module CmmUtils(
blockTicks
) where
-import GhcPrelude
+import GHC.Prelude
-import TyCon ( PrimRep(..), PrimElemRep(..) )
-import RepType ( UnaryType, SlotTy (..), typePrimRep1 )
+import GHC.Core.TyCon ( PrimRep(..), PrimElemRep(..) )
+import GHC.Types.RepType ( UnaryType, SlotTy (..), typePrimRep1 )
-import SMRep
-import Cmm
-import BlockId
-import CLabel
-import Outputable
-import DynFlags
-import CodeGen.Platform
+import GHC.Platform
+import GHC.Runtime.Heap.Layout
+import GHC.Cmm
+import GHC.Cmm.BlockId
+import GHC.Cmm.CLabel
+import GHC.Utils.Outputable
+import GHC.Types.Unique
+import GHC.Platform.Regs
-import Data.Word
+import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
import Data.Bits
-import Hoopl.Graph
-import Hoopl.Label
-import Hoopl.Block
-import Hoopl.Collections
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Collections
---------------------------------------------------
--
@@ -91,29 +96,33 @@ import Hoopl.Collections
--
---------------------------------------------------
-primRepCmmType :: DynFlags -> PrimRep -> CmmType
-primRepCmmType _ VoidRep = panic "primRepCmmType:VoidRep"
-primRepCmmType dflags LiftedRep = gcWord dflags
-primRepCmmType dflags UnliftedRep = gcWord dflags
-primRepCmmType dflags IntRep = bWord dflags
-primRepCmmType dflags WordRep = bWord dflags
-primRepCmmType _ Int8Rep = b8
-primRepCmmType _ Word8Rep = b8
-primRepCmmType _ Int16Rep = b16
-primRepCmmType _ Word16Rep = b16
-primRepCmmType _ Int64Rep = b64
-primRepCmmType _ Word64Rep = b64
-primRepCmmType dflags AddrRep = bWord dflags
-primRepCmmType _ FloatRep = f32
-primRepCmmType _ DoubleRep = f64
-primRepCmmType _ (VecRep len rep) = vec len (primElemRepCmmType rep)
-
-slotCmmType :: DynFlags -> SlotTy -> CmmType
-slotCmmType dflags PtrSlot = gcWord dflags
-slotCmmType dflags WordSlot = bWord dflags
-slotCmmType _ Word64Slot = b64
-slotCmmType _ FloatSlot = f32
-slotCmmType _ DoubleSlot = f64
+primRepCmmType :: Platform -> PrimRep -> CmmType
+primRepCmmType platform = \case
+ VoidRep -> panic "primRepCmmType:VoidRep"
+ LiftedRep -> gcWord platform
+ UnliftedRep -> gcWord platform
+ IntRep -> bWord platform
+ WordRep -> bWord platform
+ Int8Rep -> b8
+ Word8Rep -> b8
+ Int16Rep -> b16
+ Word16Rep -> b16
+ Int32Rep -> b32
+ Word32Rep -> b32
+ Int64Rep -> b64
+ Word64Rep -> b64
+ AddrRep -> bWord platform
+ FloatRep -> f32
+ DoubleRep -> f64
+ (VecRep len rep) -> vec len (primElemRepCmmType rep)
+
+slotCmmType :: Platform -> SlotTy -> CmmType
+slotCmmType platform = \case
+ PtrSlot -> gcWord platform
+ WordSlot -> bWord platform
+ Word64Slot -> b64
+ FloatSlot -> f32
+ DoubleSlot -> f64
primElemRepCmmType :: PrimElemRep -> CmmType
primElemRepCmmType Int8ElemRep = b8
@@ -127,8 +136,8 @@ primElemRepCmmType Word64ElemRep = b64
primElemRepCmmType FloatElemRep = f32
primElemRepCmmType DoubleElemRep = f64
-typeCmmType :: DynFlags -> UnaryType -> CmmType
-typeCmmType dflags ty = primRepCmmType dflags (typePrimRep1 ty)
+typeCmmType :: Platform -> UnaryType -> CmmType
+typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)
primRepForeignHint :: PrimRep -> ForeignHint
primRepForeignHint VoidRep = panic "primRepForeignHint:VoidRep"
@@ -137,10 +146,12 @@ primRepForeignHint UnliftedRep = AddrHint
primRepForeignHint IntRep = SignedHint
primRepForeignHint Int8Rep = SignedHint
primRepForeignHint Int16Rep = SignedHint
+primRepForeignHint Int32Rep = SignedHint
primRepForeignHint Int64Rep = SignedHint
primRepForeignHint WordRep = NoHint
primRepForeignHint Word8Rep = NoHint
primRepForeignHint Word16Rep = NoHint
+primRepForeignHint Word32Rep = NoHint
primRepForeignHint Word64Rep = NoHint
primRepForeignHint AddrRep = AddrHint -- NB! AddrHint, but NonPtrArg
primRepForeignHint FloatRep = NoHint
@@ -165,38 +176,44 @@ typeForeignHint = primRepForeignHint . typePrimRep1
-- XXX: should really be Integer, since Int doesn't necessarily cover
-- the full range of target Ints.
-mkIntCLit :: DynFlags -> Int -> CmmLit
-mkIntCLit dflags i = CmmInt (toInteger i) (wordWidth dflags)
+mkIntCLit :: Platform -> Int -> CmmLit
+mkIntCLit platform i = CmmInt (toInteger i) (wordWidth platform)
-mkIntExpr :: DynFlags -> Int -> CmmExpr
-mkIntExpr dflags i = CmmLit $! mkIntCLit dflags i
+mkIntExpr :: Platform -> Int -> CmmExpr
+mkIntExpr platform i = CmmLit $! mkIntCLit platform i
-zeroCLit :: DynFlags -> CmmLit
-zeroCLit dflags = CmmInt 0 (wordWidth dflags)
+zeroCLit :: Platform -> CmmLit
+zeroCLit platform = CmmInt 0 (wordWidth platform)
-zeroExpr :: DynFlags -> CmmExpr
-zeroExpr dflags = CmmLit (zeroCLit dflags)
+zeroExpr :: Platform -> CmmExpr
+zeroExpr platform = CmmLit (zeroCLit platform)
-mkWordCLit :: DynFlags -> Integer -> CmmLit
-mkWordCLit dflags wd = CmmInt wd (wordWidth dflags)
+mkWordCLit :: Platform -> Integer -> CmmLit
+mkWordCLit platform wd = CmmInt wd (wordWidth platform)
+-- | We make a top-level decl for the string, and return a label pointing to it
mkByteStringCLit
- :: CLabel -> [Word8] -> (CmmLit, GenCmmDecl CmmStatics info stmt)
--- We have to make a top-level decl for the string,
--- and return a literal pointing to it
+ :: CLabel -> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkByteStringCLit lbl bytes
- = (CmmLabel lbl, CmmData (Section sec lbl) $ Statics lbl [CmmString bytes])
+ = (CmmLabel lbl, CmmData (Section sec lbl) $ CmmStaticsRaw lbl [CmmString bytes])
where
-- This can not happen for String literals (as there \NUL is replaced by
-- C0 80). However, it can happen with Addr# literals.
- sec = if 0 `elem` bytes then ReadOnlyData else CString
+ sec = if 0 `BS.elem` bytes then ReadOnlyData else CString
+
+-- | We make a top-level decl for the embedded binary file, and return a label pointing to it
+mkFileEmbedLit
+ :: CLabel -> FilePath -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
+mkFileEmbedLit lbl path
+ = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path]))
+
-mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
--- Build a data-segment data block
+-- | Build a data-segment data block
+mkDataLits :: Section -> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits section lbl lits
- = CmmData section (Statics lbl $ map CmmStaticLit lits)
+ = CmmData section (CmmStaticsRaw lbl $ map CmmStaticLit lits)
-mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl CmmStatics info stmt
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
-- Build a read-only data block
mkRODataLits lbl lits
= mkDataLits section lbl lits
@@ -207,19 +224,19 @@ mkRODataLits lbl lits
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
-mkStgWordCLit :: DynFlags -> StgWord -> CmmLit
-mkStgWordCLit dflags wd = CmmInt (fromStgWord wd) (wordWidth dflags)
+mkStgWordCLit :: Platform -> StgWord -> CmmLit
+mkStgWordCLit platform wd = CmmInt (fromStgWord wd) (wordWidth platform)
-packHalfWordsCLit :: DynFlags -> StgHalfWord -> StgHalfWord -> CmmLit
+packHalfWordsCLit :: Platform -> StgHalfWord -> StgHalfWord -> CmmLit
-- Make a single word literal in which the lower_half_word is
-- at the lower address, and the upper_half_word is at the
-- higher address
-- ToDo: consider using half-word lits instead
-- but be careful: that's vulnerable when reversed
-packHalfWordsCLit dflags lower_half_word upper_half_word
- = if wORDS_BIGENDIAN dflags
- then mkWordCLit dflags ((l `shiftL` hALF_WORD_SIZE_IN_BITS dflags) .|. u)
- else mkWordCLit dflags (l .|. (u `shiftL` hALF_WORD_SIZE_IN_BITS dflags))
+packHalfWordsCLit platform lower_half_word upper_half_word
+ = case platformByteOrder platform of
+ BigEndian -> mkWordCLit platform ((l `shiftL` halfWordSizeInBits platform) .|. u)
+ LittleEndian -> mkWordCLit platform (l .|. (u `shiftL` halfWordSizeInBits platform))
where l = fromStgHalfWord lower_half_word
u = fromStgHalfWord upper_half_word
@@ -232,26 +249,23 @@ packHalfWordsCLit dflags lower_half_word upper_half_word
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)
-cmmOffsetExpr :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExpr :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
-- assumes base and offset have the same CmmType
-cmmOffsetExpr dflags e (CmmLit (CmmInt n _)) = cmmOffset dflags e (fromInteger n)
-cmmOffsetExpr dflags e byte_off = CmmMachOp (MO_Add (cmmExprWidth dflags e)) [e, byte_off]
-
-cmmOffset :: DynFlags -> CmmExpr -> Int -> CmmExpr
-cmmOffset _ e 0 = e
-cmmOffset _ (CmmReg reg) byte_off = cmmRegOff reg byte_off
-cmmOffset _ (CmmRegOff reg m) byte_off = cmmRegOff reg (m+byte_off)
-cmmOffset _ (CmmLit lit) byte_off = CmmLit (cmmOffsetLit lit byte_off)
-cmmOffset _ (CmmStackSlot area off) byte_off
- = CmmStackSlot area (off - byte_off)
+cmmOffsetExpr platform e (CmmLit (CmmInt n _)) = cmmOffset platform e (fromInteger n)
+cmmOffsetExpr platform e byte_off = CmmMachOp (MO_Add (cmmExprWidth platform e)) [e, byte_off]
+
+cmmOffset :: Platform -> CmmExpr -> Int -> CmmExpr
+cmmOffset _platform e 0 = e
+cmmOffset platform e byte_off = case e of
+ CmmReg reg -> cmmRegOff reg byte_off
+ CmmRegOff reg m -> cmmRegOff reg (m+byte_off)
+ CmmLit lit -> CmmLit (cmmOffsetLit lit byte_off)
+ CmmStackSlot area off -> CmmStackSlot area (off - byte_off)
-- note stack area offsets increase towards lower addresses
-cmmOffset _ (CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]) byte_off2
- = CmmMachOp (MO_Add rep)
- [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off2) rep)]
-cmmOffset dflags expr byte_off
- = CmmMachOp (MO_Add width) [expr, CmmLit (CmmInt (toInteger byte_off) width)]
- where
- width = cmmExprWidth dflags expr
+ CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt byte_off1 _rep)]
+ -> CmmMachOp (MO_Add rep) [expr, CmmLit (CmmInt (byte_off1 + toInteger byte_off) rep)]
+ _ -> CmmMachOp (MO_Add width) [e, CmmLit (CmmInt (toInteger byte_off) width)]
+ where width = cmmExprWidth platform e
-- Smart constructor for CmmRegOff. Same caveats as cmmOffset above.
cmmRegOff :: CmmReg -> Int -> CmmExpr
@@ -273,37 +287,37 @@ cmmLabelOff lbl byte_off = CmmLabelOff lbl byte_off
-- | Useful for creating an index into an array, with a statically known offset.
-- The type is the element type; used for making the multiplier
-cmmIndex :: DynFlags
+cmmIndex :: Platform
-> Width -- Width w
-> CmmExpr -- Address of vector of items of width w
-> Int -- Which element of the vector (0 based)
-> CmmExpr -- Address of i'th element
-cmmIndex dflags width base idx = cmmOffset dflags base (idx * widthInBytes width)
+cmmIndex platform width base idx = cmmOffset platform base (idx * widthInBytes width)
-- | Useful for creating an index into an array, with an unknown offset.
-cmmIndexExpr :: DynFlags
+cmmIndexExpr :: Platform
-> Width -- Width w
-> CmmExpr -- Address of vector of items of width w
-> CmmExpr -- Which element of the vector (0 based)
-> CmmExpr -- Address of i'th element
-cmmIndexExpr dflags width base (CmmLit (CmmInt n _)) = cmmIndex dflags width base (fromInteger n)
-cmmIndexExpr dflags width base idx =
- cmmOffsetExpr dflags base byte_off
+cmmIndexExpr platform width base (CmmLit (CmmInt n _)) = cmmIndex platform width base (fromInteger n)
+cmmIndexExpr platform width base idx =
+ cmmOffsetExpr platform base byte_off
where
- idx_w = cmmExprWidth dflags idx
- byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr dflags (widthInLog width)]
+ idx_w = cmmExprWidth platform idx
+ byte_off = CmmMachOp (MO_Shl idx_w) [idx, mkIntExpr platform (widthInLog width)]
-cmmLoadIndex :: DynFlags -> CmmType -> CmmExpr -> Int -> CmmExpr
-cmmLoadIndex dflags ty expr ix = CmmLoad (cmmIndex dflags (typeWidth ty) expr ix) ty
+cmmLoadIndex :: Platform -> CmmType -> CmmExpr -> Int -> CmmExpr
+cmmLoadIndex platform ty expr ix = CmmLoad (cmmIndex platform (typeWidth ty) expr ix) ty
-- The "B" variants take byte offsets
cmmRegOffB :: CmmReg -> ByteOff -> CmmExpr
cmmRegOffB = cmmRegOff
-cmmOffsetB :: DynFlags -> CmmExpr -> ByteOff -> CmmExpr
+cmmOffsetB :: Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB = cmmOffset
-cmmOffsetExprB :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprB :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprB = cmmOffsetExpr
cmmLabelOffB :: CLabel -> ByteOff -> CmmLit
@@ -315,25 +329,25 @@ cmmOffsetLitB = cmmOffsetLit
-----------------------
-- The "W" variants take word offsets
-cmmOffsetExprW :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOffsetExprW :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
-- The second arg is a *word* offset; need to change it to bytes
-cmmOffsetExprW dflags e (CmmLit (CmmInt n _)) = cmmOffsetW dflags e (fromInteger n)
-cmmOffsetExprW dflags e wd_off = cmmIndexExpr dflags (wordWidth dflags) e wd_off
+cmmOffsetExprW platform e (CmmLit (CmmInt n _)) = cmmOffsetW platform e (fromInteger n)
+cmmOffsetExprW platform e wd_off = cmmIndexExpr platform (wordWidth platform) e wd_off
-cmmOffsetW :: DynFlags -> CmmExpr -> WordOff -> CmmExpr
-cmmOffsetW dflags e n = cmmOffsetB dflags e (wordsToBytes dflags n)
+cmmOffsetW :: Platform -> CmmExpr -> WordOff -> CmmExpr
+cmmOffsetW platform e n = cmmOffsetB platform e (wordsToBytes platform n)
-cmmRegOffW :: DynFlags -> CmmReg -> WordOff -> CmmExpr
-cmmRegOffW dflags reg wd_off = cmmRegOffB reg (wordsToBytes dflags wd_off)
+cmmRegOffW :: Platform -> CmmReg -> WordOff -> CmmExpr
+cmmRegOffW platform reg wd_off = cmmRegOffB reg (wordsToBytes platform wd_off)
-cmmOffsetLitW :: DynFlags -> CmmLit -> WordOff -> CmmLit
-cmmOffsetLitW dflags lit wd_off = cmmOffsetLitB lit (wordsToBytes dflags wd_off)
+cmmOffsetLitW :: Platform -> CmmLit -> WordOff -> CmmLit
+cmmOffsetLitW platform lit wd_off = cmmOffsetLitB lit (wordsToBytes platform wd_off)
-cmmLabelOffW :: DynFlags -> CLabel -> WordOff -> CmmLit
-cmmLabelOffW dflags lbl wd_off = cmmLabelOffB lbl (wordsToBytes dflags wd_off)
+cmmLabelOffW :: Platform -> CLabel -> WordOff -> CmmLit
+cmmLabelOffW platform lbl wd_off = cmmLabelOffB lbl (wordsToBytes platform wd_off)
-cmmLoadIndexW :: DynFlags -> CmmExpr -> Int -> CmmType -> CmmExpr
-cmmLoadIndexW dflags base off ty = CmmLoad (cmmOffsetW dflags base off) ty
+cmmLoadIndexW :: Platform -> CmmExpr -> Int -> CmmType -> CmmExpr
+cmmLoadIndexW platform base off ty = CmmLoad (cmmOffsetW platform base off) ty
-----------------------
cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
@@ -341,35 +355,41 @@ cmmULtWord, cmmUGeWord, cmmUGtWord, cmmUShrWord,
cmmNeWord, cmmEqWord,
cmmOrWord, cmmAndWord,
cmmSubWord, cmmAddWord, cmmMulWord, cmmQuotWord
- :: DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
-cmmOrWord dflags e1 e2 = CmmMachOp (mo_wordOr dflags) [e1, e2]
-cmmAndWord dflags e1 e2 = CmmMachOp (mo_wordAnd dflags) [e1, e2]
-cmmNeWord dflags e1 e2 = CmmMachOp (mo_wordNe dflags) [e1, e2]
-cmmEqWord dflags e1 e2 = CmmMachOp (mo_wordEq dflags) [e1, e2]
-cmmULtWord dflags e1 e2 = CmmMachOp (mo_wordULt dflags) [e1, e2]
-cmmUGeWord dflags e1 e2 = CmmMachOp (mo_wordUGe dflags) [e1, e2]
-cmmUGtWord dflags e1 e2 = CmmMachOp (mo_wordUGt dflags) [e1, e2]
-cmmSLtWord dflags e1 e2 = CmmMachOp (mo_wordSLt dflags) [e1, e2]
-cmmUShrWord dflags e1 e2 = CmmMachOp (mo_wordUShr dflags) [e1, e2]
-cmmAddWord dflags e1 e2 = CmmMachOp (mo_wordAdd dflags) [e1, e2]
-cmmSubWord dflags e1 e2 = CmmMachOp (mo_wordSub dflags) [e1, e2]
-cmmMulWord dflags e1 e2 = CmmMachOp (mo_wordMul dflags) [e1, e2]
-cmmQuotWord dflags e1 e2 = CmmMachOp (mo_wordUQuot dflags) [e1, e2]
-
-cmmNegate :: DynFlags -> CmmExpr -> CmmExpr
-cmmNegate _ (CmmLit (CmmInt n rep)) = CmmLit (CmmInt (-n) rep)
-cmmNegate dflags e = CmmMachOp (MO_S_Neg (cmmExprWidth dflags e)) [e]
-
-blankWord :: DynFlags -> CmmStatic
-blankWord dflags = CmmUninitialised (wORD_SIZE dflags)
-
-cmmToWord :: DynFlags -> CmmExpr -> CmmExpr
-cmmToWord dflags e
+ :: Platform -> CmmExpr -> CmmExpr -> CmmExpr
+cmmOrWord platform e1 e2 = CmmMachOp (mo_wordOr platform) [e1, e2]
+cmmAndWord platform e1 e2 = CmmMachOp (mo_wordAnd platform) [e1, e2]
+cmmNeWord platform e1 e2 = CmmMachOp (mo_wordNe platform) [e1, e2]
+cmmEqWord platform e1 e2 = CmmMachOp (mo_wordEq platform) [e1, e2]
+cmmULtWord platform e1 e2 = CmmMachOp (mo_wordULt platform) [e1, e2]
+cmmUGeWord platform e1 e2 = CmmMachOp (mo_wordUGe platform) [e1, e2]
+cmmUGtWord platform e1 e2 = CmmMachOp (mo_wordUGt platform) [e1, e2]
+cmmSLtWord platform e1 e2 = CmmMachOp (mo_wordSLt platform) [e1, e2]
+cmmUShrWord platform e1 e2 = CmmMachOp (mo_wordUShr platform) [e1, e2]
+cmmAddWord platform e1 e2 = CmmMachOp (mo_wordAdd platform) [e1, e2]
+cmmSubWord platform e1 e2 = CmmMachOp (mo_wordSub platform) [e1, e2]
+cmmMulWord platform e1 e2 = CmmMachOp (mo_wordMul platform) [e1, e2]
+cmmQuotWord platform e1 e2 = CmmMachOp (mo_wordUQuot platform) [e1, e2]
+
+cmmNegate :: Platform -> CmmExpr -> CmmExpr
+cmmNegate platform = \case
+ (CmmLit (CmmInt n rep))
+ -> CmmLit (CmmInt (-n) rep)
+ e -> CmmMachOp (MO_S_Neg (cmmExprWidth platform e)) [e]
+
+cmmToWord :: Platform -> CmmExpr -> CmmExpr
+cmmToWord platform e
| w == word = e
| otherwise = CmmMachOp (MO_UU_Conv w word) [e]
where
- w = cmmExprWidth dflags e
- word = wordWidth dflags
+ w = cmmExprWidth platform e
+ word = wordWidth platform
+
+cmmMkAssign :: Platform -> CmmExpr -> Unique -> (CmmNode O O, CmmExpr)
+cmmMkAssign platform expr uq =
+ let !ty = cmmExprType platform expr
+ reg = (CmmLocal (LocalReg uq ty))
+ in (CmmAssign reg expr, CmmReg reg)
+
---------------------------------------------------
--
@@ -407,23 +427,29 @@ isComparisonExpr _ = False
--
---------------------------------------------------
+tAG_MASK :: Platform -> Int
+tAG_MASK platform = (1 `shiftL` pc_TAG_BITS (platformConstants platform)) - 1
+
+mAX_PTR_TAG :: Platform -> Int
+mAX_PTR_TAG = tAG_MASK
+
-- Tag bits mask
-cmmTagMask, cmmPointerMask :: DynFlags -> CmmExpr
-cmmTagMask dflags = mkIntExpr dflags (tAG_MASK dflags)
-cmmPointerMask dflags = mkIntExpr dflags (complement (tAG_MASK dflags))
+cmmTagMask, cmmPointerMask :: Platform -> CmmExpr
+cmmTagMask platform = mkIntExpr platform (tAG_MASK platform)
+cmmPointerMask platform = mkIntExpr platform (complement (tAG_MASK platform))
-- Used to untag a possibly tagged pointer
-- A static label need not be untagged
-cmmUntag, cmmIsTagged, cmmConstrTag1 :: DynFlags -> CmmExpr -> CmmExpr
+cmmUntag, cmmIsTagged, cmmConstrTag1 :: Platform -> CmmExpr -> CmmExpr
cmmUntag _ e@(CmmLit (CmmLabel _)) = e
-- Default case
-cmmUntag dflags e = cmmAndWord dflags e (cmmPointerMask dflags)
+cmmUntag platform e = cmmAndWord platform e (cmmPointerMask platform)
-- Test if a closure pointer is untagged
-cmmIsTagged dflags e = cmmNeWord dflags (cmmAndWord dflags e (cmmTagMask dflags)) (zeroExpr dflags)
+cmmIsTagged platform e = cmmNeWord platform (cmmAndWord platform e (cmmTagMask platform)) (zeroExpr platform)
-- Get constructor tag, but one based.
-cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
+cmmConstrTag1 platform e = cmmAndWord platform e (cmmTagMask platform)
-----------------------------------------------------------------------------
@@ -433,10 +459,10 @@ cmmConstrTag1 dflags e = cmmAndWord dflags e (cmmTagMask dflags)
-- platform, in the sense that writing to one will clobber the
-- other. This includes the case that the two registers are the same
-- STG register. See Note [Overlapping global registers] for details.
-regsOverlap :: DynFlags -> CmmReg -> CmmReg -> Bool
-regsOverlap dflags (CmmGlobal g) (CmmGlobal g')
- | Just real <- globalRegMaybe (targetPlatform dflags) g,
- Just real' <- globalRegMaybe (targetPlatform dflags) g',
+regsOverlap :: Platform -> CmmReg -> CmmReg -> Bool
+regsOverlap platform (CmmGlobal g) (CmmGlobal g')
+ | Just real <- globalRegMaybe platform g,
+ Just real' <- globalRegMaybe platform g',
real == real'
= True
regsOverlap _ reg reg' = reg == reg'
@@ -447,14 +473,14 @@ regsOverlap _ reg reg' = reg == reg'
--
-- We must check for overlapping registers and not just equal
-- registers here, otherwise CmmSink may incorrectly reorder
--- assignments that conflict due to overlap. See Trac #10521 and Note
+-- assignments that conflict due to overlap. See #10521 and Note
-- [Overlapping global registers].
-regUsedIn :: DynFlags -> CmmReg -> CmmExpr -> Bool
-regUsedIn dflags = regUsedIn_ where
+regUsedIn :: Platform -> CmmReg -> CmmExpr -> Bool
+regUsedIn platform = regUsedIn_ where
_ `regUsedIn_` CmmLit _ = False
reg `regUsedIn_` CmmLoad e _ = reg `regUsedIn_` e
- reg `regUsedIn_` CmmReg reg' = regsOverlap dflags reg reg'
- reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap dflags reg reg'
+ reg `regUsedIn_` CmmReg reg' = regsOverlap platform reg reg'
+ reg `regUsedIn_` CmmRegOff reg' _ = regsOverlap platform reg reg'
reg `regUsedIn_` CmmMachOp _ es = any (reg `regUsedIn_`) es
_ `regUsedIn_` CmmStackSlot _ _ = False
@@ -464,13 +490,14 @@ regUsedIn dflags = regUsedIn_ where
--
---------------------------------------------
-mkLiveness :: DynFlags -> [LocalReg] -> Liveness
+mkLiveness :: Platform -> [LocalReg] -> Liveness
mkLiveness _ [] = []
-mkLiveness dflags (reg:regs)
- = bits ++ mkLiveness dflags regs
+mkLiveness platform (reg:regs)
+ = bits ++ mkLiveness platform regs
where
- sizeW = (widthInBytes (typeWidth (localRegType reg)) + wORD_SIZE dflags - 1)
- `quot` wORD_SIZE dflags
+ word_size = platformWordSizeInBytes platform
+ sizeW = (widthInBytes (typeWidth (localRegType reg)) + word_size - 1)
+ `quot` word_size
-- number of words, rounded up
bits = replicate sizeW is_non_ptr -- True <=> Non Ptr
@@ -517,7 +544,7 @@ toBlockListEntryFirst g
-- have both true and false successors. Block ordering can make a big difference
-- in performance in the LLVM backend. Note that we rely crucially on the order
-- of successors returned for CmmCondBranch by the NonLocal instance for CmmNode
--- defined in cmm/CmmNode.hs. -GBM
+-- defined in "GHC.Cmm.Node". -GBM
toBlockListEntryFirstFalseFallthrough :: CmmGraph -> [CmmBlock]
toBlockListEntryFirstFalseFallthrough g
| mapNull m = []
diff --git a/compiler/nativeGen/AsmCodeGen.hs b/compiler/GHC/CmmToAsm.hs
index 5a11a6a..d1b893f 100644
--- a/compiler/nativeGen/AsmCodeGen.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -6,13 +6,16 @@
--
-- -----------------------------------------------------------------------------
-{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms #-}
+{-# LANGUAGE BangPatterns, CPP, GADTs, ScopedTypeVariables, PatternSynonyms,
+ DeriveFunctor #-}
#if !defined(GHC_LOADED_INTO_GHCI)
{-# LANGUAGE UnboxedTuples #-}
#endif
-module AsmCodeGen (
+{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
+
+module GHC.CmmToAsm (
-- * Module entry point
nativeCodeGen
@@ -26,79 +29,79 @@ module AsmCodeGen (
) where
#include "GhclibHsVersions.h"
-#include "nativeGen/NCG.h"
-
-
-import GhcPrelude
-
-import qualified X86.CodeGen
-import qualified X86.Regs
-import qualified X86.Instr
-import qualified X86.Ppr
-
-import qualified SPARC.CodeGen
-import qualified SPARC.Regs
-import qualified SPARC.Instr
-import qualified SPARC.Ppr
-import qualified SPARC.ShortcutJump
-import qualified SPARC.CodeGen.Expand
-
-import qualified PPC.CodeGen
-import qualified PPC.Regs
-import qualified PPC.RegInfo
-import qualified PPC.Instr
-import qualified PPC.Ppr
-
-import RegAlloc.Liveness
-import qualified RegAlloc.Linear.Main as Linear
-
-import qualified GraphColor as Color
-import qualified RegAlloc.Graph.Main as Color
-import qualified RegAlloc.Graph.Stats as Color
-import qualified RegAlloc.Graph.TrivColorable as Color
-
-import AsmUtils
-import TargetReg
-import Platform
-import BlockLayout
-import Config
-import Instruction
-import PIC
-import Reg
-import NCGMonad
-import CFG
-import Dwarf
-import Debug
-
-import BlockId
-import CgUtils ( fixStgRegisters )
-import Cmm
-import CmmUtils
-import Hoopl.Collections
-import Hoopl.Label
-import Hoopl.Block
-import CmmOpt ( cmmMachOpFold )
-import PprCmm
-import CLabel
-
-import UniqFM
-import UniqSupply
-import DynFlags
-import Util
-
-import BasicTypes ( Alignment )
-import qualified Pretty
-import BufWrite
-import Outputable
-import FastString
-import UniqSet
-import ErrUtils
-import Module
-import Stream (Stream)
-import qualified Stream
+
+import GHC.Prelude
+
+import qualified GHC.CmmToAsm.X86.CodeGen as X86.CodeGen
+import qualified GHC.CmmToAsm.X86.Regs as X86.Regs
+import qualified GHC.CmmToAsm.X86.Instr as X86.Instr
+import qualified GHC.CmmToAsm.X86.Ppr as X86.Ppr
+
+import qualified GHC.CmmToAsm.SPARC.CodeGen as SPARC.CodeGen
+import qualified GHC.CmmToAsm.SPARC.Regs as SPARC.Regs
+import qualified GHC.CmmToAsm.SPARC.Instr as SPARC.Instr
+import qualified GHC.CmmToAsm.SPARC.Ppr as SPARC.Ppr
+import qualified GHC.CmmToAsm.SPARC.ShortcutJump as SPARC.ShortcutJump
+import qualified GHC.CmmToAsm.SPARC.CodeGen.Expand as SPARC.CodeGen.Expand
+
+import qualified GHC.CmmToAsm.PPC.CodeGen as PPC.CodeGen
+import qualified GHC.CmmToAsm.PPC.Regs as PPC.Regs
+import qualified GHC.CmmToAsm.PPC.RegInfo as PPC.RegInfo
+import qualified GHC.CmmToAsm.PPC.Instr as PPC.Instr
+import qualified GHC.CmmToAsm.PPC.Ppr as PPC.Ppr
+
+import GHC.CmmToAsm.Reg.Liveness
+import qualified GHC.CmmToAsm.Reg.Linear as Linear
+
+import qualified GHC.Data.Graph.Color as Color
+import qualified GHC.CmmToAsm.Reg.Graph as Color
+import qualified GHC.CmmToAsm.Reg.Graph.Stats as Color
+import qualified GHC.CmmToAsm.Reg.Graph.TrivColorable as Color
+
+import GHC.Utils.Asm
+import GHC.CmmToAsm.Reg.Target
+import GHC.Platform
+import GHC.CmmToAsm.BlockLayout as BlockLayout
+import GHC.Settings.Config
+import GHC.CmmToAsm.Instr
+import GHC.CmmToAsm.PIC
+import GHC.Platform.Reg
+import GHC.Platform.Reg.Class (RegClass)
+import GHC.CmmToAsm.Monad
+import GHC.CmmToAsm.CFG
+import GHC.CmmToAsm.Dwarf
+import GHC.CmmToAsm.Config
+import GHC.Cmm.DebugBlock
+
+import GHC.Cmm.BlockId
+import GHC.StgToCmm.CgUtils ( fixStgRegisters )
+import GHC.Cmm
+import GHC.Cmm.Utils
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Opt ( cmmMachOpFold )
+import GHC.Cmm.Ppr
+import GHC.Cmm.CLabel
+
+import GHC.Types.Unique.FM
+import GHC.Types.Unique.Supply
+import GHC.Driver.Session
+import GHC.Utils.Misc
+
+import GHC.Types.Basic ( Alignment )
+import qualified GHC.Utils.Ppr as Pretty
+import GHC.Utils.BufHandle
+import GHC.Utils.Outputable as Outputable
+import GHC.Data.FastString
+import GHC.Types.Unique.Set
+import GHC.Utils.Error
+import GHC.Unit
+import GHC.Data.Stream (Stream)
+import qualified GHC.Data.Stream as Stream
-- DEBUGGING ONLY
---import OrdList
+--import GHC.Data.OrdList
import Data.List
import Data.Maybe
@@ -156,97 +159,103 @@ The machine-dependent bits break down as follows:
-}
--------------------
-nativeCodeGen :: DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
- -> Stream IO RawCmmGroup ()
- -> IO UniqSupply
+nativeCodeGen :: forall a . DynFlags -> Module -> ModLocation -> Handle -> UniqSupply
+ -> Stream IO RawCmmGroup a
+ -> IO a
nativeCodeGen dflags this_mod modLoc h us cmms
- = let platform = targetPlatform dflags
+ = let config = initConfig dflags
+ platform = ncgPlatform config
nCG' :: ( Outputable statics, Outputable instr
, Outputable jumpDest, Instruction instr)
- => NcgImpl statics instr jumpDest -> IO UniqSupply
+ => NcgImpl statics instr jumpDest -> IO a
nCG' ncgImpl = nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
in case platformArch platform of
- ArchX86 -> nCG' (x86NcgImpl dflags)
- ArchX86_64 -> nCG' (x86_64NcgImpl dflags)
- ArchPPC -> nCG' (ppcNcgImpl dflags)
- ArchSPARC -> nCG' (sparcNcgImpl dflags)
+ ArchX86 -> nCG' (x86NcgImpl config)
+ ArchX86_64 -> nCG' (x86_64NcgImpl config)
+ ArchPPC -> nCG' (ppcNcgImpl config)
+ ArchS390X -> panic "nativeCodeGen: No NCG for S390X"
+ ArchSPARC -> nCG' (sparcNcgImpl config)
ArchSPARC64 -> panic "nativeCodeGen: No NCG for SPARC64"
ArchARM {} -> panic "nativeCodeGen: No NCG for ARM"
ArchARM64 -> panic "nativeCodeGen: No NCG for ARM64"
- ArchPPC_64 _ -> nCG' (ppcNcgImpl dflags)
+ ArchPPC_64 _ -> nCG' (ppcNcgImpl config)
ArchAlpha -> panic "nativeCodeGen: No NCG for Alpha"
ArchMipseb -> panic "nativeCodeGen: No NCG for mipseb"
ArchMipsel -> panic "nativeCodeGen: No NCG for mipsel"
ArchUnknown -> panic "nativeCodeGen: No NCG for unknown arch"
ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"
-x86NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)
+x86NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)
X86.Instr.Instr X86.Instr.JumpDest
-x86NcgImpl dflags
- = (x86_64NcgImpl dflags) { ncg_x86fp_kludge = map x86fp_kludge }
+x86NcgImpl config
+ = (x86_64NcgImpl config)
-x86_64NcgImpl :: DynFlags -> NcgImpl (Alignment, CmmStatics)
+x86_64NcgImpl :: NCGConfig -> NcgImpl (Alignment, RawCmmStatics)
X86.Instr.Instr X86.Instr.JumpDest
-x86_64NcgImpl dflags
+x86_64NcgImpl config
= NcgImpl {
- cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
- ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr dflags
+ ncgConfig = config
+ ,cmmTopCodeGen = X86.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = X86.CodeGen.generateJumpTableForInstr config
,getJumpDestBlockId = X86.Instr.getJumpDestBlockId
,canShortcut = X86.Instr.canShortcut
,shortcutStatics = X86.Instr.shortcutStatics
,shortcutJump = X86.Instr.shortcutJump
- ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl
- ,maxSpillSlots = X86.Instr.maxSpillSlots dflags
+ ,pprNatCmmDecl = X86.Ppr.pprNatCmmDecl config
+ ,maxSpillSlots = X86.Instr.maxSpillSlots config
,allocatableRegs = X86.Regs.allocatableRegs platform
- ,ncg_x86fp_kludge = id
,ncgAllocMoreStack = X86.Instr.allocMoreStack platform
,ncgExpandTop = id
,ncgMakeFarBranches = const id
,extractUnwindPoints = X86.CodeGen.extractUnwindPoints
,invertCondBranches = X86.CodeGen.invertCondBranches
}
- where platform = targetPlatform dflags
+ where
+ platform = ncgPlatform config
-ppcNcgImpl :: DynFlags -> NcgImpl CmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
-ppcNcgImpl dflags
+ppcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics PPC.Instr.Instr PPC.RegInfo.JumpDest
+ppcNcgImpl config
= NcgImpl {
- cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
- ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr dflags
+ ncgConfig = config
+ ,cmmTopCodeGen = PPC.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = PPC.CodeGen.generateJumpTableForInstr config
,getJumpDestBlockId = PPC.RegInfo.getJumpDestBlockId
,canShortcut = PPC.RegInfo.canShortcut
,shortcutStatics = PPC.RegInfo.shortcutStatics
,shortcutJump = PPC.RegInfo.shortcutJump
- ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl
- ,maxSpillSlots = PPC.Instr.maxSpillSlots dflags
+ ,pprNatCmmDecl = PPC.Ppr.pprNatCmmDecl config
+ ,maxSpillSlots = PPC.Instr.maxSpillSlots config
,allocatableRegs = PPC.Regs.allocatableRegs platform
- ,ncg_x86fp_kludge = id
,ncgAllocMoreStack = PPC.Instr.allocMoreStack platform
,ncgExpandTop = id
,ncgMakeFarBranches = PPC.Instr.makeFarBranches
,extractUnwindPoints = const []
,invertCondBranches = \_ _ -> id
}
- where platform = targetPlatform dflags
+ where
+ platform = ncgPlatform config
-sparcNcgImpl :: DynFlags -> NcgImpl CmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
-sparcNcgImpl dflags
+sparcNcgImpl :: NCGConfig -> NcgImpl RawCmmStatics SPARC.Instr.Instr SPARC.ShortcutJump.JumpDest
+sparcNcgImpl config
= NcgImpl {
- cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
- ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr dflags
+ ncgConfig = config
+ ,cmmTopCodeGen = SPARC.CodeGen.cmmTopCodeGen
+ ,generateJumpTableForInstr = SPARC.CodeGen.generateJumpTableForInstr platform
,getJumpDestBlockId = SPARC.ShortcutJump.getJumpDestBlockId
,canShortcut = SPARC.ShortcutJump.canShortcut
,shortcutStatics = SPARC.ShortcutJump.shortcutStatics
,shortcutJump = SPARC.ShortcutJump.shortcutJump
- ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl
- ,maxSpillSlots = SPARC.Instr.maxSpillSlots dflags
+ ,pprNatCmmDecl = SPARC.Ppr.pprNatCmmDecl config
+ ,maxSpillSlots = SPARC.Instr.maxSpillSlots config
,allocatableRegs = SPARC.Regs.allocatableRegs
- ,ncg_x86fp_kludge = id
,ncgAllocMoreStack = noAllocMoreStack
,ncgExpandTop = map SPARC.CodeGen.Expand.expandTop
,ncgMakeFarBranches = const id
,extractUnwindPoints = const []
,invertCondBranches = \_ _ -> id
}
+ where
+ platform = ncgPlatform config
--
-- Allocating more stack space for spilling is currently only
@@ -281,7 +290,7 @@ data NativeGenAcc statics instr
, ngs_dwarfFiles :: !DwarfFiles
, ngs_unwinds :: !(LabelMap [UnwindPoint])
-- ^ see Note [Unwinding information in the NCG]
- -- and Note [What is this unwinding business?] in Debug.
+ -- and Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
}
{-
@@ -306,7 +315,7 @@ field of NativeGenAcc. This is a label map which contains an entry for each
procedure, containing a list of unwinding points (e.g. a label and an associated
unwinding table).
-See also Note [What is this unwinding business?] in Debug.
+See also Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
-}
nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,
@@ -316,8 +325,8 @@ nativeCodeGen' :: (Outputable statics, Outputable instr,Outputable jumpDest,
-> NcgImpl statics instr jumpDest
-> Handle
-> UniqSupply
- -> Stream IO RawCmmGroup ()
- -> IO UniqSupply
+ -> Stream IO RawCmmGroup a
+ -> IO a
nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
= do
-- BufHandle is a performance hack. We could hide it inside
@@ -325,9 +334,10 @@ nativeCodeGen' dflags this_mod modLoc ncgImpl h us cmms
-- printDocs here (in order to do codegen in constant space).
bufh <- newBufHandle h
let ngs0 = NGS [] [] [] [] [] [] emptyUFM mapEmpty
- (ngs, us') <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
+ (ngs, us', a) <- cmmNativeGenStream dflags this_mod modLoc ncgImpl bufh us
cmms ngs0
- finishNativeGen dflags modLoc bufh us' ngs
+ _ <- finishNativeGen dflags modLoc bufh us' ngs
+ return a
finishNativeGen :: Instruction instr
=> DynFlags
@@ -337,9 +347,9 @@ finishNativeGen :: Instruction instr
-> NativeGenAcc statics instr
-> IO UniqSupply
finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
- = do
+ = withTimingSilent dflags (text "NCG") (`seq` ()) $ do
-- Write debug data and finish
- let emitDw = debugLevel dflags > 0 && not (gopt Opt_SplitObjs dflags)
+ let emitDw = debugLevel dflags > 0
us' <- if not emitDw then return us else do
(dwarf, us') <- dwarfGen dflags modLoc us (ngs_debug ngs)
emitNativeCode dflags bufh dwarf
@@ -348,7 +358,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
-- dump global NCG stats for graph coloring allocator
let stats = concat (ngs_colorStats ngs)
- when (not (null stats)) $ do
+ unless (null stats) $ do
-- build the global register conflict graph
let graphGlobal
@@ -361,6 +371,7 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
let platform = targetPlatform dflags
dumpIfSet_dyn dflags
Opt_D_dump_asm_conflicts "Register conflict graph"
+ FormatText
$ Color.dotGraph
(targetRegDotColor platform)
(Color.trivColorable platform
@@ -371,15 +382,18 @@ finishNativeGen dflags modLoc bufh@(BufHandle _ _ h) us ngs
-- dump global NCG stats for linear allocator
let linearStats = concat (ngs_linearStats ngs)
- when (not (null linearStats)) $
+ unless (null linearStats) $
dump_stats (Linear.pprStats (concat (ngs_natives ngs)) linearStats)
-- write out the imports
- printSDocLn Pretty.LeftMode dflags h (mkCodeStyle AsmStyle)
+ let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ printSDocLn ctx Pretty.LeftMode h
$ makeImportsDoc dflags (concat (ngs_imports ngs))
return us'
where
- dump_stats = dumpSDoc dflags alwaysQualify Opt_D_dump_asm_stats "NCG stats"
+ dump_stats = dumpAction dflags (mkDumpStyle alwaysQualify)
+ (dumpOptionsFromFlag Opt_D_dump_asm_stats) "NCG stats"
+ FormatText
cmmNativeGenStream :: (Outputable statics, Outputable instr
,Outputable jumpDest, Instruction instr)
@@ -388,62 +402,52 @@ cmmNativeGenStream :: (Outputable statics, Outputable instr
-> NcgImpl statics instr jumpDest
-> BufHandle
-> UniqSupply
- -> Stream IO RawCmmGroup ()
+ -> Stream IO RawCmmGroup a
-> NativeGenAcc statics instr
- -> IO (NativeGenAcc statics instr, UniqSupply)
+ -> IO (NativeGenAcc statics instr, UniqSupply, a)
cmmNativeGenStream dflags this_mod modLoc ncgImpl h us cmm_stream ngs
= do r <- Stream.runStream cmm_stream
case r of
- Left () ->
+ Left a ->
return (ngs { ngs_imports = reverse $ ngs_imports ngs
, ngs_natives = reverse $ ngs_natives ngs
, ngs_colorStats = reverse $ ngs_colorStats ngs
, ngs_linearStats = reverse $ ngs_linearStats ngs
},
- us)
+ us,
+ a)
Right (cmms, cmm_stream') -> do
-
- -- Generate debug information
- let debugFlag = debugLevel dflags > 0
- !ndbgs | debugFlag = cmmDebugGen modLoc cmms
- | otherwise = []
- dbgMap = debugToMap ndbgs
-
- -- Insert split marker, generate native code
- let splitObjs = gopt Opt_SplitObjs dflags
- split_marker = CmmProc mapEmpty mkSplitMarkerLabel [] $
- ofBlockList (panic "split_marker_entry") []
- cmms' | splitObjs = split_marker : cmms
- | otherwise = cmms
- (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
- dbgMap us cmms' ngs 0
-
- -- Link native code information into debug blocks
- -- See Note [What is this unwinding business?] in Debug.
- let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
- dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos"
- (vcat $ map ppr ldbgs)
-
- -- Emit & clear DWARF information when generating split
- -- object files, as we need it to land in the same object file
- -- When using split sections, note that we do not split the debug
- -- info but emit all the info at once in finishNativeGen.
- (ngs'', us'') <-
- if debugFlag && splitObjs
- then do (dwarf, us'') <- dwarfGen dflags modLoc us ldbgs
- emitNativeCode dflags h dwarf
- return (ngs' { ngs_debug = []
- , ngs_dwarfFiles = emptyUFM
- , ngs_labels = [] },
- us'')
- else return (ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs
- , ngs_labels = [] },
- us')
-
- cmmNativeGenStream dflags this_mod modLoc ncgImpl h us''
+ (us', ngs'') <-
+ withTimingSilent
+ dflags
+ ncglabel (\(a, b) -> a `seq` b `seq` ()) $ do
+ -- Generate debug information
+ let debugFlag = debugLevel dflags > 0
+ !ndbgs | debugFlag = cmmDebugGen modLoc cmms
+ | otherwise = []
+ dbgMap = debugToMap ndbgs
+
+ -- Generate native code
+ (ngs',us') <- cmmNativeGens dflags this_mod modLoc ncgImpl h
+ dbgMap us cmms ngs 0
+
+ -- Link native code information into debug blocks
+ -- See Note [What is this unwinding business?] in "GHC.Cmm.DebugBlock".
+ let !ldbgs = cmmDebugLink (ngs_labels ngs') (ngs_unwinds ngs') ndbgs
+ unless (null ldbgs) $
+ dumpIfSet_dyn dflags Opt_D_dump_debug "Debug Infos" FormatText
+ (vcat $ map ppr ldbgs)
+
+ -- Accumulate debug information for emission in finishNativeGen.
+ let ngs'' = ngs' { ngs_debug = ngs_debug ngs' ++ ldbgs, ngs_labels = [] }
+ return (us', ngs'')
+
+ cmmNativeGenStream dflags this_mod modLoc ncgImpl h us'
cmm_stream' ngs''
+ where ncglabel = text "NCG"
+
-- | Do native code generation on all these cmms.
--
cmmNativeGens :: forall statics instr jumpDest.
@@ -483,14 +487,14 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
nonDetEltsUFM $ fileIds' `minusUFM` fileIds
-- See Note [Unique Determinism and code generation]
pprDecl (f,n) = text "\t.file " <> ppr n <+>
- doubleQuotes (ftext f)
+ pprFilePathString (unpackFS f)
emitNativeCode dflags h $ vcat $
map pprDecl newFileIds ++
map (pprNatCmmDecl ncgImpl) native
-- force evaluation all this stuff to avoid space leaks
- {-# SCC "seqString" #-} evaluate $ seqString (showSDoc dflags $ vcat $ map ppr imports)
+ {-# SCC "seqString" #-} evaluate $ seqList (showSDoc dflags $ vcat $ map ppr imports) ()
let !labels' = if debugLevel dflags > 0
then cmmDebugLabels isMetaInstr native else []
@@ -508,19 +512,16 @@ cmmNativeGens dflags this_mod modLoc ncgImpl h dbgMap = go
}
go us' cmms ngs' (count + 1)
- seqString [] = ()
- seqString (x:xs) = x `seq` seqString xs
-
emitNativeCode :: DynFlags -> BufHandle -> SDoc -> IO ()
emitNativeCode dflags h sdoc = do
- {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc dflags h
- (mkCodeStyle AsmStyle) sdoc
+ let ctx = initSDocContext dflags (mkCodeStyle AsmStyle)
+ {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc
-- dump native code
dumpIfSet_dyn dflags
- Opt_D_dump_asm "Asm code"
+ Opt_D_dump_asm "Asm code" FormatASM
sdoc
-- | Complete native code generation phase for a single top-level chunk of Cmm.
@@ -548,7 +549,8 @@ cmmNativeGen
cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= do
- let platform = targetPlatform dflags
+ let config = ncgConfig ncgImpl
+ let platform = ncgPlatform config
let proc_name = case cmm of
(CmmProc _ entry_label _ _) -> ppr entry_label
@@ -557,15 +559,15 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- rewrite assignments to global regs
let fixed_cmm =
{-# SCC "fixStgRegisters" #-}
- fixStgRegisters dflags cmm
+ fixStgRegisters platform cmm
-- cmm to cmm optimisations
let (opt_cmm, imports) =
{-# SCC "cmmToCmm" #-}
- cmmToCmm dflags this_mod fixed_cmm
+ cmmToCmm config this_mod fixed_cmm
dumpIfSet_dyn dflags
- Opt_D_dump_opt_cmm "Optimised Cmm"
+ Opt_D_dump_opt_cmm "Optimised Cmm" FormatCMM
(pprCmmGroup [opt_cmm])
let cmmCfg = {-# SCC "getCFG" #-}
@@ -578,9 +580,8 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
(cmmTopCodeGen ncgImpl)
fileIds dbgMap opt_cmm cmmCfg
-
dumpIfSet_dyn dflags
- Opt_D_dump_asm_native "Native code"
+ Opt_D_dump_asm_native "Native code" FormatASM
(vcat $ map (pprNatCmmDecl ncgImpl) native)
maybeDumpCfg dflags (Just nativeCfgWeights) "CFG Weights - Native" proc_name
@@ -588,18 +589,17 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- tag instructions with register liveness information
-- also drops dead code. We don't keep the cfg in sync on
-- some backends, so don't use it there.
- let livenessCfg = if (backendMaintainsCfg dflags)
+ let livenessCfg = if backendMaintainsCfg platform
then Just nativeCfgWeights
else Nothing
let (withLiveness, usLive) =
{-# SCC "regLiveness" #-}
initUs usGen
- $ mapM (regLiveness platform)
- -- TODO: Only use CFG for x86
- $ map (natCmmTopToLive livenessCfg) native
+ $ mapM (cmmTopLiveness livenessCfg platform) native
dumpIfSet_dyn dflags
Opt_D_dump_asm_liveness "Liveness annotations added"
+ FormatCMM
(vcat $ map ppr withLiveness)
-- allocate registers
@@ -608,7 +608,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
|| gopt Opt_RegsIterative dflags )
then do
-- the regs usable for allocation
- let (alloc_regs :: UniqFM (UniqSet RealReg))
+ let (alloc_regs :: UniqFM RegClass (UniqSet RealReg))
= foldr (\r -> plusUFM_C unionUniqSets
$ unitUFM (targetClassOfRealReg platform r) (unitUniqSet r))
emptyUFM
@@ -619,7 +619,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
= {-# SCC "RegAlloc-color" #-}
initUs usLive
$ Color.regAlloc
- dflags
+ config
alloc_regs
(mkUniqSet [0 .. maxSpillSlots ncgImpl])
(maxSpillSlots ncgImpl)
@@ -639,10 +639,12 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- dump out what happened during register allocation
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
+ FormatCMM
(vcat $ map (pprNatCmmDecl ncgImpl) alloced)
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc_stages "Build/spill stages"
+ FormatText
(vcat $ map (\(stage, stats)
-> text "# --------------------------"
$$ text "# cmm " <> int count <> text " Stage " <> int stage
@@ -665,7 +667,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
-- do linear register allocation
let reg_alloc proc = do
(alloced, maybe_more_stack, ra_stats) <-
- Linear.regAlloc dflags proc
+ Linear.regAlloc config proc
case maybe_more_stack of
Nothing -> return ( alloced, ra_stats, [] )
Just amount -> do
@@ -681,6 +683,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
dumpIfSet_dyn dflags
Opt_D_dump_asm_regalloc "Registers allocated"
+ FormatCMM
(vcat $ map (pprNatCmmDecl ncgImpl) alloced)
let mPprStats =
@@ -700,30 +703,22 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
cfgRegAllocUpdates = (concatMap Linear.ra_fixupList raStats)
let cfgWithFixupBlks =
- pure addNodesBetween <*> livenessCfg <*> pure cfgRegAllocUpdates
+ (\cfg -> addNodesBetween dflags cfg cfgRegAllocUpdates) <$> livenessCfg
-- Insert stack update blocks
- let postRegCFG :: Maybe CFG
- postRegCFG =
- pure (foldl' (\m (from,to) -> addImmediateSuccessor from to m )) <*>
- cfgWithFixupBlks <*> pure stack_updt_blks
-
- ---- x86fp_kludge. This pass inserts ffree instructions to clear
- ---- the FPU stack on x86. The x86 ABI requires that the FPU stack
- ---- is clear, and library functions can return odd results if it
- ---- isn't.
- ----
- ---- NB. must happen before shortcutBranches, because that
- ---- generates JXX_GBLs which we can't fix up in x86fp_kludge.
- let kludged = {-# SCC "x86fp_kludge" #-} ncg_x86fp_kludge ncgImpl alloced
+ let postRegCFG =
+ pure (foldl' (\m (from,to) -> addImmediateSuccessor dflags from to m ))
+ <*> cfgWithFixupBlks
+ <*> pure stack_updt_blks
---- generate jump tables
let tabled =
{-# SCC "generateJumpTables" #-}
- generateJumpTables ncgImpl kludged
+ generateJumpTables ncgImpl alloced
- dumpIfSet_dyn dflags
+ when (not $ null nativeCfgWeights) $ dumpIfSet_dyn dflags
Opt_D_dump_cfg_weights "CFG Update information"
+ FormatText
( text "stack:" <+> ppr stack_updt_blks $$
text "linearAlloc:" <+> ppr cfgRegAllocUpdates )
@@ -732,8 +727,9 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "shortcutBranches" #-}
shortcutBranches dflags ncgImpl tabled postRegCFG
- let optimizedCFG =
- optimizeCFG (cfgWeightInfo dflags) cmm <$> postShortCFG
+ let optimizedCFG :: Maybe CFG
+ optimizedCFG =
+ optimizeCFG (gopt Opt_CmmStaticPred dflags) (cfgWeightInfo dflags) cmm <$!> postShortCFG
maybeDumpCfg dflags optimizedCFG "CFG Weights - Final" proc_name
@@ -741,12 +737,13 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
let getBlks (CmmProc _info _lbl _live (ListGraph blocks)) = blocks
getBlks _ = []
- when ( backendMaintainsCfg dflags &&
+ when ( backendMaintainsCfg platform &&
(gopt Opt_DoAsmLinting dflags || debugIsOn )) $ do
let blocks = concatMap getBlks shorted
let labels = setFromList $ fmap blockId blocks :: LabelSet
- return $! seq (pure sanityCheckCfg <*> optimizedCFG <*> pure labels <*>
- pure (text "cfg not in lockstep")) ()
+ let cfg = fromJust optimizedCFG
+ return $! seq (sanityCheckCfg cfg labels $
+ text "cfg not in lockstep") ()
---- sequence blocks
let sequenced :: [NatCmmDecl statics instr]
@@ -763,9 +760,9 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
{-# SCC "invertCondBranches" #-}
map invert sequenced
where
- invertConds :: LabelMap CmmStatics -> [NatBasicBlock instr]
+ invertConds :: LabelMap RawCmmStatics -> [NatBasicBlock instr]
-> [NatBasicBlock instr]
- invertConds = (invertCondBranches ncgImpl) optimizedCFG
+ invertConds = invertCondBranches ncgImpl optimizedCFG
invert top@CmmData {} = top
invert (CmmProc info lbl live (ListGraph blocks)) =
CmmProc info lbl live (ListGraph $ invertConds info blocks)
@@ -778,6 +775,7 @@ cmmNativeGen dflags this_mod modLoc ncgImpl us fileIds dbgMap cmm count
dumpIfSet_dyn dflags
Opt_D_dump_asm_expanded "Synthetic instructions expanded"
+ FormatCMM
(vcat $ map (pprNatCmmDecl ncgImpl) expanded)
-- generate unwinding information from cmm
@@ -804,6 +802,7 @@ maybeDumpCfg dflags (Just cfg) msg proc_name
| otherwise
= dumpIfSet_dyn
dflags Opt_D_dump_cfg_weights msg
+ FormatText
(proc_name <> char ':' $$ pprEdgeWeights cfg)
-- | Make sure all blocks we want the layout algorithm to place have been placed.
@@ -824,12 +823,6 @@ checkLayout procsUnsequenced procsSequenced =
getBlockIds (CmmProc _ _ _ (ListGraph blocks)) =
setFromList $ map blockId blocks
-
-x86fp_kludge :: NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr -> NatCmmDecl (Alignment, CmmStatics) X86.Instr.Instr
-x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge (CmmProc info lbl live (ListGraph code)) =
- CmmProc info lbl live (ListGraph $ X86.Instr.i386_insert_ffrees code)
-
-- | Compute unwinding tables for the blocks of a procedure
computeUnwinding :: Instruction instr
=> DynFlags -> NcgImpl statics instr jumpDest
@@ -847,7 +840,7 @@ computeUnwinding _ ncgImpl (CmmProc _ _ _ (ListGraph blks)) =
-- relevant register writes within a procedure.
--
-- However, the only unwinding information that we care about in GHC is for
- -- Sp. The fact that CmmLayoutStack already ensures that we have unwind
+ -- Sp. The fact that GHC.Cmm.LayoutStack already ensures that we have unwind
-- information at the beginning of every block means that there is no need
-- to perform this sort of push-down.
mapFromList [ (blk_lbl, extractUnwindPoints ncgImpl instrs)
@@ -873,7 +866,7 @@ makeImportsDoc dflags imports
-- security. GHC generated code does not need an executable
-- stack so add the note in:
(if platformHasGnuNonexecStack platform
- then text ".section .note.GNU-stack,\"\"," <> sectionType "progbits"
+ then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"
else Outputable.empty)
$$
-- And just because every other compiler does, let's stick in
@@ -884,9 +877,8 @@ makeImportsDoc dflags imports
else Outputable.empty)
where
- platform = targetPlatform dflags
- arch = platformArch platform
- os = platformOS platform
+ config = initConfig dflags
+ platform = ncgPlatform config
-- Generate "symbol stubs" for all external symbols that might
-- come from a dynamic library.
@@ -896,10 +888,10 @@ makeImportsDoc dflags imports
-- (Hack) sometimes two Labels pretty-print the same, but have
-- different uniques; so we compare their text versions...
dyld_stubs imps
- | needImportedSymbols dflags arch os
+ | needImportedSymbols config
= vcat $
- (pprGotDeclaration dflags arch os :) $
- map ( pprImportedSymbol dflags platform . fst . head) $
+ (pprGotDeclaration config :) $
+ map ( pprImportedSymbol config . fst . head) $
groupBy (\(_,a) (_,b) -> a == b) $
sortBy (\(_,a) (_,b) -> compare a b) $
map doPpr $
@@ -907,7 +899,9 @@ makeImportsDoc dflags imports
| otherwise
= Outputable.empty
- doPpr lbl = (lbl, renderWithStyle dflags (pprCLabel platform lbl) astyle)
+ doPpr lbl = (lbl, renderWithStyle
+ (initSDocContext dflags astyle)
+ (pprCLabel_NCG platform lbl))
astyle = mkCodeStyle AsmStyle
-- -----------------------------------------------------------------------------
@@ -1072,10 +1066,10 @@ Ideas for other things we could do (put these in Hoopl please!):
temp assignments, and certain assigns to mem...)
-}
-cmmToCmm :: DynFlags -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
+cmmToCmm :: NCGConfig -> Module -> RawCmmDecl -> (RawCmmDecl, [CLabel])
cmmToCmm _ _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags this_mod (CmmProc info lbl live graph)
- = runCmmOpt dflags this_mod $
+cmmToCmm config this_mod (CmmProc info lbl live graph)
+ = runCmmOpt config this_mod $
do blocks' <- mapM cmmBlockConFold (toBlockList graph)
return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')
@@ -1089,13 +1083,11 @@ pattern OptMResult x y = (# x, y #)
{-# COMPLETE OptMResult #-}
#else
-data OptMResult a = OptMResult !a ![CLabel]
+data OptMResult a = OptMResult !a ![CLabel] deriving (Functor)
#endif
-newtype CmmOptM a = CmmOptM (DynFlags -> Module -> [CLabel] -> OptMResult a)
-
-instance Functor CmmOptM where
- fmap = liftM
+newtype CmmOptM a = CmmOptM (NCGConfig -> Module -> [CLabel] -> OptMResult a)
+ deriving (Functor)
instance Applicative CmmOptM where
pure x = CmmOptM $ \_ _ imports -> OptMResult x imports
@@ -1103,11 +1095,11 @@ instance Applicative CmmOptM where
instance Monad CmmOptM where
(CmmOptM f) >>= g =
- CmmOptM $ \dflags this_mod imports0 ->
- case f dflags this_mod imports0 of
+ CmmOptM $ \config this_mod imports0 ->
+ case f config this_mod imports0 of
OptMResult x imports1 ->
case g x of
- CmmOptM g' -> g' dflags this_mod imports1
+ CmmOptM g' -> g' config this_mod imports1
instance CmmMakeDynamicReferenceM CmmOptM where
addImport = addImportCmmOpt
@@ -1116,12 +1108,12 @@ instance CmmMakeDynamicReferenceM CmmOptM where
addImportCmmOpt :: CLabel -> CmmOptM ()
addImportCmmOpt lbl = CmmOptM $ \_ _ imports -> OptMResult () (lbl:imports)
-instance HasDynFlags CmmOptM where
- getDynFlags = CmmOptM $ \dflags _ imports -> OptMResult dflags imports
+getCmmOptConfig :: CmmOptM NCGConfig
+getCmmOptConfig = CmmOptM $ \config _ imports -> OptMResult config imports
-runCmmOpt :: DynFlags -> Module -> CmmOptM a -> (a, [CLabel])
-runCmmOpt dflags this_mod (CmmOptM f) =
- case f dflags this_mod [] of
+runCmmOpt :: NCGConfig -> Module -> CmmOptM a -> (a, [CLabel])
+runCmmOpt config this_mod (CmmOptM f) =
+ case f config this_mod [] of
OptMResult result imports -> (result, imports)
cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock
@@ -1185,28 +1177,26 @@ cmmStmtConFold stmt
cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprConFold referenceKind expr = do
- dflags <- getDynFlags
+ config <- getCmmOptConfig
- -- With -O1 and greater, the cmmSink pass does constant-folding, so
- -- we don't need to do it again here.
- let expr' = if optLevel dflags >= 1
+ let expr' = if not (ncgDoConstantFolding config)
then expr
- else cmmExprCon dflags expr
+ else cmmExprCon config expr
cmmExprNative referenceKind expr'
-cmmExprCon :: DynFlags -> CmmExpr -> CmmExpr
-cmmExprCon dflags (CmmLoad addr rep) = CmmLoad (cmmExprCon dflags addr) rep
-cmmExprCon dflags (CmmMachOp mop args)
- = cmmMachOpFold dflags mop (map (cmmExprCon dflags) args)
+cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr
+cmmExprCon config (CmmLoad addr rep) = CmmLoad (cmmExprCon config addr) rep
+cmmExprCon config (CmmMachOp mop args)
+ = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args)
cmmExprCon _ other = other
-- handles both PIC and non-PIC cases... a very strange mixture
-- of things to do.
cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr
cmmExprNative referenceKind expr = do
- dflags <- getDynFlags
- let platform = targetPlatform dflags
+ config <- getCmmOptConfig
+ let platform = ncgPlatform config
arch = platformArch platform
case expr of
CmmLoad addr rep
@@ -1225,29 +1215,29 @@ cmmExprNative referenceKind expr = do
CmmLit (CmmLabel lbl)
-> do
- cmmMakeDynamicReference dflags referenceKind lbl
+ cmmMakeDynamicReference config referenceKind lbl
CmmLit (CmmLabelOff lbl off)
-> do
- dynRef <- cmmMakeDynamicReference dflags referenceKind lbl
+ dynRef <- cmmMakeDynamicReference config referenceKind lbl
-- need to optimize here, since it's late
- return $ cmmMachOpFold dflags (MO_Add (wordWidth dflags)) [
+ return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [
dynRef,
- (CmmLit $ CmmInt (fromIntegral off) (wordWidth dflags))
+ (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))
]
-- On powerpc (non-PIC), it's easier to jump directly to a label than
-- to use the register table, so we replace these registers
-- with the corresponding labels:
CmmReg (CmmGlobal EagerBlackholeInfo)
- | arch == ArchPPC && not (positionIndependent dflags)
+ | arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))
CmmReg (CmmGlobal GCEnter1)
- | arch == ArchPPC && not (positionIndependent dflags)
+ | arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))
CmmReg (CmmGlobal GCFun)
- | arch == ArchPPC && not (positionIndependent dflags)
+ | arch == ArchPPC && not (ncgPIC config)
-> cmmExprNative referenceKind $
CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))
diff --git a/compiler/GHC/CmmToAsm/BlockLayout.hs b/compiler/GHC/CmmToAsm/BlockLayout.hs
new file mode 100644
index 0000000..f5b3a58
--- /dev/null
+++ b/compiler/GHC/CmmToAsm/BlockLayout.hs
@@ -0,0 +1,939 @@
+--
+-- Copyright (c) 2018 Andreas Klebinger
+--
+
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+
+module GHC.CmmToAsm.BlockLayout
+ ( sequenceTop, backendMaintainsCfg)
+where
+
+#include "GhclibHsVersions.h"
+import GHC.Prelude
+
+import GHC.CmmToAsm.Instr
+import GHC.CmmToAsm.Monad
+import GHC.CmmToAsm.CFG
+
+import GHC.Cmm.BlockId
+import GHC.Cmm
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Label
+
+import GHC.Platform
+import GHC.Driver.Session (gopt, GeneralFlag(..), DynFlags, targetPlatform)
+import GHC.Types.Unique.FM
+import GHC.Utils.Misc
+
+import GHC.Data.Graph.Directed
+import GHC.Utils.Outputable
+import GHC.Data.Maybe
+
+-- DEBUGGING ONLY
+--import GHC.Cmm.DebugBlock
+--import Debug.Trace
+import GHC.Data.List.SetOps (removeDups)
+
+import GHC.Data.OrdList
+import Data.List
+import Data.Foldable (toList)
+
+import qualified Data.Set as Set
+import Data.STRef
+import Control.Monad.ST.Strict
+import Control.Monad (foldM)
+
+{-
+ Note [CFG based code layout]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ The major steps in placing blocks are as follow:
+ * Compute a CFG based on the Cmm AST, see getCfgProc.
+ This CFG will have edge weights representing a guess
+ on how important they are.
+ * After we convert Cmm to Asm we run `optimizeCFG` which
+ adds a few more "educated guesses" to the equation.
+ * Then we run loop analysis on the CFG (`loopInfo`) which tells us
+ about loop headers, loop nesting levels and the sort.
+ * Based on the CFG and loop information refine the edge weights
+ in the CFG and normalize them relative to the most often visited
+ node. (See `mkGlobalWeights`)
+ * Feed this CFG into the block layout code (`sequenceTop`) in this
+ module. Which will then produce a code layout based on the input weights.
+
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ~~~ Note [Chain based CFG serialization]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ For additional information also look at
+ https://gitlab.haskell.org/ghc/ghc/wikis/commentary/compiler/code-layout
+
+ We have a CFG with edge weights based on which we try to place blocks next to
+ each other.
+
+ Edge weights not only represent likelihood of control transfer between blocks
+ but also how much a block would benefit from being placed sequentially after
+ it's predecessor.
+ For example blocks which are preceded by an info table are more likely to end
+ up in a different cache line than their predecessor and we can't eliminate the jump
+ so there is less benefit to placing them sequentially.
+
+ For example consider this example:
+
+ A: ...
+ jmp cond D (weak successor)
+ jmp B
+ B: ...
+ jmp C
+ C: ...
+ jmp X
+ D: ...
+ jmp B (weak successor)
+
+ We determine a block layout by building up chunks (calling them chains) of
+ possible control flows for which blocks will be placed sequentially.
+
+ Eg for our example we might end up with two chains like:
+ [A->B->C->X],[D]. Blocks inside chains will always be placed sequentially.
+ However there is no particular order in which chains are placed since
+ (hopefully) the blocks for which sequentiality is important have already
+ been placed in the same chain.
+
+ -----------------------------------------------------------------------------
+ 1) First try to create a list of good chains.
+ -----------------------------------------------------------------------------
+
+ Good chains are these which allow us to eliminate jump instructions.
+ Which further eliminate often executed jumps first.
+
+ We do so by:
+
+ *) Ignore edges which represent instructions which can not be replaced
+ by fall through control flow. Primarily calls and edges to blocks which
+ are prefixed by a info table we have to jump across.
+
+ *) Then process remaining edges in order of frequency taken and:
+
+ +) If source and target have not been placed build a new chain from them.
+
+ +) If source and target have been placed, and are ends of differing chains
+ try to merge the two chains.
+
+ +) If one side of the edge is a end/front of a chain, add the other block of
+ to edge to the same chain
+
+ Eg if we look at edge (B -> C) and already have the chain (A -> B)
+ then we extend the chain to (A -> B -> C).
+
+ +) If the edge was used to modify or build a new chain remove the edge from
+ our working list.
+
+ *) If there any blocks not being placed into a chain after these steps we place
+ them into a chain consisting of only this block.
+
+ Ranking edges by their taken frequency, if
+ two edges compete for fall through on the same target block, the one taken
+ more often will automatically win out. Resulting in fewer instructions being
+ executed.
+
+ Creating singleton chains is required for situations where we have code of the
+ form:
+
+ A: goto B:
+ <infoTable>
+ B: goto C:
+ <infoTable>
+ C: ...
+
+ As the code in block B is only connected to the rest of the program via edges
+ which will be ignored in this step we make sure that B still ends up in a chain
+ this way.
+
+ -----------------------------------------------------------------------------
+ 2) We also try to fuse chains.
+ -----------------------------------------------------------------------------
+
+ As a result from the above step we still end up with multiple chains which
+ represent sequential control flow chunks. But they are not yet suitable for
+ code layout as we need to place *all* blocks into a single sequence.
+
+ In this step we combine chains result from the above step via these steps:
+
+ *) Look at the ranked list of *all* edges, including calls/jumps across info tables
+ and the like.
+
+ *) Look at each edge and
+
+ +) Given an edge (A -> B) try to find two chains for which
+ * Block A is at the end of one chain
+ * Block B is at the front of the other chain.
+ +) If we find such a chain we "fuse" them into a single chain, remove the
+ edge from working set and continue.
+ +) If we can't find such chains we skip the edge and continue.
+
+ -----------------------------------------------------------------------------
+ 3) Place indirect successors (neighbours) after each other
+ -----------------------------------------------------------------------------
+
+ We might have chains [A,B,C,X],[E] in a CFG of the sort:
+
+ A ---> B ---> C --------> X(exit)
+ \- ->E- -/
+
+ While E does not follow X it's still beneficial to place them near each other.
+ This can be advantageous if eg C,X,E will end up in the same cache line.
+
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ~~~ Note [Triangle Control Flow]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ Checking if an argument is already evaluated leads to a somewhat
+ special case which looks like this:
+
+ A:
+ if (R1 & 7 != 0) goto Leval; else goto Lwork;
+ Leval: // global
+ call (I64[R1])(R1) returns to Lwork, args: 8, res: 8, upd: 8;
+ Lwork: // global
+ ...
+
+ A
+ |\
+ | Leval
+ |/ - (This edge can be missing because of optimizations)
+ Lwork
+
+ Once we hit the metal the call instruction is just 2-3 bytes large
+ depending on the register used. So we lay out the assembly like this:
+
+ movq %rbx,%rax
+ andl $7,%eax
+ cmpq $1,%rax
+ jne Lwork
+ Leval:
+ jmp *(%rbx) # encoded in 2-3 bytes.
+ <info table>
+ Lwork:
+ ...
+
+ We could explicitly check for this control flow pattern.
+
+ This is advantageous because:
+ * It's optimal if the argument isn't evaluated.
+ * If it's evaluated we only have the extra cost of jumping over
+ the 2-3 bytes for the call.
+ * Guarantees the smaller encoding for the conditional jump.
+
+ However given that Lwork usually has an info table we
+ penalize this edge. So Leval should get placed first
+ either way and things work out for the best.
+
+ Optimizing for the evaluated case instead would penalize
+ the other code path. It adds an jump as we can't fall through
+ to Lwork because of the info table.
+ Assuming that Lwork is large the chance that the "call" ends up
+ in the same cache line is also fairly small.
+
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ~~~ Note [Layout relevant edge weights]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ The input to the chain based code layout algorithm is a CFG
+ with edges annotated with their frequency. The frequency
+ of traversal corresponds quite well to the cost of not placing
+ the connected blocks next to each other.
+
+ However even if having the same frequency certain edges are
+ inherently more or less relevant to code layout.
+
+ In particular:
+
+ * Edges which cross an info table are less relevant than others.
+
+ If we place the blocks across this edge next to each other
+ they are still separated by the info table which negates
+ much of the benefit. It makes it less likely both blocks
+ will share a cache line reducing the benefits from locality.
+ But it also prevents us from eliminating jump instructions.
+
+ * Conditional branches and switches are slightly less relevant.
+
+ We can completely remove unconditional jumps by placing them
+ next to each other. This is not true for conditional branch edges.
+ We apply a small modifier to them to ensure edges for which we can
+ eliminate the overhead completely are considered first. See also #18053.
+
+ * Edges constituted by a call are ignored.
+
+ Considering these hardly helped with performance and ignoring
+ them helps quite a bit to improve compiler performance.
+
+ So we perform a preprocessing step where we apply a multiplicator
+ to these kinds of edges.
+
+ -}
+
+
+-- | Look at X number of blocks in two chains to determine
+-- if they are "neighbours".
+neighbourOverlapp :: Int
+neighbourOverlapp = 2
+
+-- | Maps blocks near the end of a chain to it's chain AND
+-- the other blocks near the end.
+-- [A,B,C,D,E] Gives entries like (B -> ([A,B], [A,B,C,D,E]))
+-- where [A,B] are blocks in the end region of a chain.
+-- This is cheaper then recomputing the ends multiple times.
+type FrontierMap = LabelMap ([BlockId],BlockChain)
+
+-- | A non empty ordered sequence of basic blocks.
+-- It is suitable for serialization in this order.
+--
+-- We use OrdList instead of [] to allow fast append on both sides
+-- when combining chains.
+newtype BlockChain
+ = BlockChain { chainBlocks :: (OrdList BlockId) }
+
+-- All chains are constructed the same way so comparison
+-- including structure is faster.
+instance Eq BlockChain where
+ BlockChain b1 == BlockChain b2 = strictlyEqOL b1 b2
+
+-- Useful for things like sets and debugging purposes, sorts by blocks
+-- in the chain.
+instance Ord (BlockChain) where
+ (BlockChain lbls1) `compare` (BlockChain lbls2)
+ = ASSERT(toList lbls1 /= toList lbls2 || lbls1 `strictlyEqOL` lbls2)
+ strictlyOrdOL lbls1 lbls2
+
+instance Outputable (BlockChain) where
+ ppr (BlockChain blks) =
+ parens (text "Chain:" <+> ppr (fromOL $ blks) )
+
+chainFoldl :: (b -> BlockId -> b) -> b -> BlockChain -> b
+chainFoldl f z (BlockChain blocks) = foldl' f z blocks
+
+noDups :: [BlockChain] -> Bool
+noDups chains =
+ let chainBlocks = concatMap chainToBlocks chains :: [BlockId]
+ (_blocks, dups) = removeDups compare chainBlocks
+ in if null dups then True
+ else pprTrace "Duplicates:" (ppr (map toList dups) $$ text "chains" <+> ppr chains ) False
+
+inFront :: BlockId -> BlockChain -> Bool
+inFront bid (BlockChain seq)
+ = headOL seq == bid
+
+chainSingleton :: BlockId -> BlockChain
+chainSingleton lbl
+ = BlockChain (unitOL lbl)
+
+chainFromList :: [BlockId] -> BlockChain
+chainFromList = BlockChain . toOL
+
+chainSnoc :: BlockChain -> BlockId -> BlockChain
+chainSnoc (BlockChain blks) lbl
+ = BlockChain (blks `snocOL` lbl)
+
+chainCons :: BlockId -> BlockChain -> BlockChain
+chainCons lbl (BlockChain blks)
+ = BlockChain (lbl `consOL` blks)
+
+chainConcat :: BlockChain -> BlockChain -> BlockChain
+chainConcat (BlockChain blks1) (BlockChain blks2)
+ = BlockChain (blks1 `appOL` blks2)
+
+chainToBlocks :: BlockChain -> [BlockId]
+chainToBlocks (BlockChain blks) = fromOL blks
+
+-- | Given the Chain A -> B -> C -> D and we break at C
+-- we get the two Chains (A -> B, C -> D) as result.
+breakChainAt :: BlockId -> BlockChain
+ -> (BlockChain,BlockChain)
+breakChainAt bid (BlockChain blks)
+ | not (bid == head rblks)
+ = panic "Block not in chain"
+ | otherwise
+ = (BlockChain (toOL lblks),
+ BlockChain (toOL rblks))
+ where
+ (lblks, rblks) = break (\lbl -> lbl == bid) (fromOL blks)
+
+takeR :: Int -> BlockChain -> [BlockId]
+takeR n (BlockChain blks) =
+ take n . fromOLReverse $ blks
+
+takeL :: Int -> BlockChain -> [BlockId]
+takeL n (BlockChain blks) =
+ take n . fromOL $ blks
+
+-- Note [Combining neighborhood chains]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+-- See also Note [Chain based CFG serialization]
+-- We have the chains (A-B-C-D) and (E-F) and an Edge C->E.
+--
+-- While placing the latter after the former doesn't result in sequential
+-- control flow it is still beneficial. As block C and E might end
+-- up in the same cache line.
+--
+-- So we place these chains next to each other even if we can't fuse them.
+--
+-- A -> B -> C -> D
+-- v
+-- - -> E -> F ...
+--
+-- A simple heuristic to chose which chains we want to combine:
+-- * Process edges in descending priority.
+-- * Check if there is a edge near the end of one chain which goes
+-- to a block near the start of another edge.
+--
+-- While we could take into account the space between the two blocks which
+-- share an edge this blows up compile times quite a bit. It requires
+-- us to find all edges between two chains, check the distance for all edges,
+-- rank them based on the distance and only then we can select two chains
+-- to combine. Which would add a lot of complexity for little gain.
+--
+-- So instead we just rank by the strength of the edge and use the first pair we
+-- find.
+
+-- | For a given list of chains and edges try to combine chains with strong
+-- edges between them.
+combineNeighbourhood :: [CfgEdge] -- ^ Edges to consider
+ -> [BlockChain] -- ^ Current chains of blocks
+ -> ([BlockChain], Set.Set (BlockId,BlockId))
+ -- ^ Resulting list of block chains, and a set of edges which
+ -- were used to fuse chains and as such no longer need to be
+ -- considered.
+combineNeighbourhood edges chains
+ = -- pprTraceIt "Neighbours" $
+ -- pprTrace "combineNeighbours" (ppr edges) $
+ applyEdges edges endFrontier startFrontier (Set.empty)
+ where
+ --Build maps from chain ends to chains
+ endFrontier, startFrontier :: FrontierMap
+ endFrontier =
+ mapFromList $ concatMap (\chain ->
+ let ends = getEnds chain :: [BlockId]
+ entry = (ends,chain)
+ in map (\x -> (x,entry)) ends ) chains
+ startFrontier =
+ mapFromList $ concatMap (\chain ->
+ let front = getFronts chain
+ entry = (front,chain)
+ in map (\x -> (x,entry)) front) chains
+ applyEdges :: [CfgEdge] -> FrontierMap -> FrontierMap -> Set.Set (BlockId, BlockId)
+ -> ([BlockChain], Set.Set (BlockId,BlockId))
+ applyEdges [] chainEnds _chainFronts combined =
+ (ordNub $ map snd $ mapElems chainEnds, combined)
+ applyEdges ((CfgEdge from to _w):edges) chainEnds chainFronts combined
+ | Just (c1_e,c1) <- mapLookup from chainEnds
+ , Just (c2_f,c2) <- mapLookup to chainFronts
+ , c1 /= c2 -- Avoid trying to concat a chain with itself.
+ = let newChain = chainConcat c1 c2
+ newChainFrontier = getFronts newChain
+ newChainEnds = getEnds newChain
+ newFronts :: FrontierMap
+ newFronts =
+ let withoutOld =
+ foldl' (\m b -> mapDelete b m :: FrontierMap) chainFronts (c2_f ++ getFronts c1)
+ entry =
+ (newChainFrontier,newChain) --let bound to ensure sharing
+ in foldl' (\m x -> mapInsert x entry m)
+ withoutOld newChainFrontier
+
+ newEnds =
+ let withoutOld = foldl' (\m b -> mapDelete b m) chainEnds (c1_e ++ getEnds c2)
+ entry = (newChainEnds,newChain) --let bound to ensure sharing
+ in foldl' (\m x -> mapInsert x entry m)
+ withoutOld newChainEnds
+ in
+ -- pprTrace "ApplyEdges"
+ -- (text "before" $$
+ -- text "fronts" <+> ppr chainFronts $$
+ -- text "ends" <+> ppr chainEnds $$
+
+ -- text "various" $$
+ -- text "newChain" <+> ppr newChain $$
+ -- text "newChainFrontier" <+> ppr newChainFrontier $$
+ -- text "newChainEnds" <+> ppr newChainEnds $$
+ -- text "drop" <+> ppr ((c2_f ++ getFronts c1) ++ (c1_e ++ getEnds c2)) $$
+
+ -- text "after" $$
+ -- text "fronts" <+> ppr newFronts $$
+ -- text "ends" <+> ppr newEnds
+ -- )
+ applyEdges edges newEnds newFronts (Set.insert (from,to) combined)
+ | otherwise
+ = applyEdges edges chainEnds chainFronts combined
+ where
+
+ getFronts chain = takeL neighbourOverlapp chain
+ getEnds chain = takeR neighbourOverlapp chain
+
+-- In the last stop we combine all chains into a single one.
+-- Trying to place chains with strong edges next to each other.
+mergeChains :: [CfgEdge] -> [BlockChain]
+ -> (BlockChain)
+mergeChains edges chains
+ = -- pprTrace "combine" (ppr edges) $
+ runST $ do
+ let addChain m0 chain = do
+ ref <- newSTRef chain
+ return $ chainFoldl (\m' b -> mapInsert b ref m') m0 chain
+ chainMap' <- foldM (\m0 c -> addChain m0 c) mapEmpty chains
+ merge edges chainMap'
+ where
+ -- We keep a map from ALL blocks to their respective chain (sigh)
+ -- This is required since when looking at an edge we need to find
+ -- the associated chains quickly.
+ -- We use a map of STRefs, maintaining a invariant of one STRef per chain.
+ -- When merging chains we can update the
+ -- STRef of one chain once (instead of writing to the map for each block).
+ -- We then overwrite the STRefs for the other chain so there is again only
+ -- a single STRef for the combined chain.
+ -- The difference in terms of allocations saved is ~0.2% with -O so actually
+ -- significant compared to using a regular map.
+
+ merge :: forall s. [CfgEdge] -> LabelMap (STRef s BlockChain) -> ST s BlockChain
+ merge [] chains = do
+ chains' <- ordNub <$> (mapM readSTRef $ mapElems chains) :: ST s [BlockChain]
+ return $ foldl' chainConcat (head chains') (tail chains')
+ merge ((CfgEdge from to _):edges) chains
+ -- | pprTrace "merge" (ppr (from,to) <> ppr chains) False
+ -- = undefined
+ | cFrom == cTo
+ = merge edges chains
+ | otherwise
+ = do
+ chains' <- mergeComb cFrom cTo
+ merge edges chains'
+ where
+ mergeComb :: STRef s BlockChain -> STRef s BlockChain -> ST s (LabelMap (STRef s BlockChain))
+ mergeComb refFrom refTo = do
+ cRight <- readSTRef refTo
+ chain <- pure chainConcat <*> readSTRef refFrom <*> pure cRight
+ writeSTRef refFrom chain
+ return $ chainFoldl (\m b -> mapInsert b refFrom m) chains cRight
+
+ cFrom = expectJust "mergeChains:chainMap:from" $ mapLookup from chains
+ cTo = expectJust "mergeChains:chainMap:to" $ mapLookup to chains
+
+
+-- See Note [Chain based CFG serialization] for the general idea.
+-- This creates and fuses chains at the same time for performance reasons.
+
+-- Try to build chains from a list of edges.
+-- Edges must be sorted **descending** by their priority.
+-- Returns the constructed chains, along with all edges which
+-- are irrelevant past this point, this information doesn't need
+-- to be complete - it's only used to speed up the process.
+-- An Edge is irrelevant if the ends are part of the same chain.
+-- We say these edges are already linked
+buildChains :: [CfgEdge] -> [BlockId]
+ -> ( LabelMap BlockChain -- Resulting chains, indexd by end if chain.
+ , Set.Set (BlockId, BlockId)) --List of fused edges.
+buildChains edges blocks
+ = runST $ buildNext setEmpty mapEmpty mapEmpty edges Set.empty
+ where
+ -- buildNext builds up chains from edges one at a time.
+
+ -- We keep a map from the ends of chains to the chains.
+ -- This way we can easily check if an block should be appended to an
+ -- existing chain!
+ -- We store them using STRefs so we don't have to rebuild the spine of both
+ -- maps every time we update a chain.
+ buildNext :: forall s. LabelSet
+ -> LabelMap (STRef s BlockChain) -- Map from end of chain to chain.
+ -> LabelMap (STRef s BlockChain) -- Map from start of chain to chain.
+ -> [CfgEdge] -- Edges to check - ordered by decreasing weight
+ -> Set.Set (BlockId, BlockId) -- Used edges
+ -> ST s ( LabelMap BlockChain -- Chains by end
+ , Set.Set (BlockId, BlockId) --List of fused edges
+ )
+ buildNext placed _chainStarts chainEnds [] linked = do
+ ends' <- sequence $ mapMap readSTRef chainEnds :: ST s (LabelMap BlockChain)
+ -- Any remaining blocks have to be made to singleton chains.
+ -- They might be combined with other chains later on outside this function.
+ let unplaced = filter (\x -> not (setMember x placed)) blocks
+ singletons = map (\x -> (x,chainSingleton x)) unplaced :: [(BlockId,BlockChain)]
+ return (foldl' (\m (k,v) -> mapInsert k v m) ends' singletons , linked)
+ buildNext placed chainStarts chainEnds (edge:todo) linked
+ | from == to
+ -- We skip self edges
+ = buildNext placed chainStarts chainEnds todo (Set.insert (from,to) linked)
+ | not (alreadyPlaced from) &&
+ not (alreadyPlaced to)
+ = do
+ --pprTraceM "Edge-Chain:" (ppr edge)
+ chain' <- newSTRef $ chainFromList [from,to]
+ buildNext
+ (setInsert to (setInsert from placed))
+ (mapInsert from chain' chainStarts)
+ (mapInsert to chain' chainEnds)
+ todo
+ (Set.insert (from,to) linked)
+
+ | (alreadyPlaced from) &&
+ (alreadyPlaced to)
+ , Just predChain <- mapLookup from chainEnds
+ , Just succChain <- mapLookup to chainStarts
+ , predChain /= succChain -- Otherwise we try to create a cycle.
+ = do
+ -- pprTraceM "Fusing edge" (ppr edge)
+ fuseChain predChain succChain
+
+ | (alreadyPlaced from) &&
+ (alreadyPlaced to)
+ = --pprTraceM "Skipping:" (ppr edge) >>
+ buildNext placed chainStarts chainEnds todo linked
+
+ | otherwise
+ = do -- pprTraceM "Finding chain for:" (ppr edge $$
+ -- text "placed" <+> ppr placed)
+ findChain
+ where
+ from = edgeFrom edge
+ to = edgeTo edge
+ alreadyPlaced blkId = (setMember blkId placed)
+
+ -- Combine two chains into a single one.
+ fuseChain :: STRef s BlockChain -> STRef s BlockChain
+ -> ST s ( LabelMap BlockChain -- Chains by end
+ , Set.Set (BlockId, BlockId) --List of fused edges
+ )
+ fuseChain fromRef toRef = do
+ fromChain <- readSTRef fromRef
+ toChain <- readSTRef toRef
+ let newChain = chainConcat fromChain toChain
+ ref <- newSTRef newChain
+ let start = head $ takeL 1 newChain
+ let end = head $ takeR 1 newChain
+ -- chains <- sequence $ mapMap readSTRef chainStarts
+ -- pprTraceM "pre-fuse chains:" $ ppr chains
+ buildNext
+ placed
+ (mapInsert start ref $ mapDelete to $ chainStarts)
+ (mapInsert end ref $ mapDelete from $ chainEnds)
+ todo
+ (Set.insert (from,to) linked)
+
+
+ --Add the block to a existing chain or creates a new chain
+ findChain :: ST s ( LabelMap BlockChain -- Chains by end
+ , Set.Set (BlockId, BlockId) --List of fused edges
+ )
+ findChain
+ -- We can attach the block to the end of a chain
+ | alreadyPlaced from
+ , Just predChain <- mapLookup from chainEnds
+ = do
+ chain <- readSTRef predChain
+ let newChain = chainSnoc chain to
+ writeSTRef predChain newChain
+ let chainEnds' = mapInsert to predChain $ mapDelete from chainEnds
+ -- chains <- sequence $ mapMap readSTRef chainStarts
+ -- pprTraceM "from chains:" $ ppr chains
+ buildNext (setInsert to placed) chainStarts chainEnds' todo (Set.insert (from,to) linked)
+ -- We can attack it to the front of a chain
+ | alreadyPlaced to
+ , Just succChain <- mapLookup to chainStarts
+ = do
+ chain <- readSTRef succChain
+ let newChain = from `chainCons` chain
+ writeSTRef succChain newChain
+ let chainStarts' = mapInsert from succChain $ mapDelete to chainStarts
+ -- chains <- sequence $ mapMap readSTRef chainStarts'
+ -- pprTraceM "to chains:" $ ppr chains
+ buildNext (setInsert from placed) chainStarts' chainEnds todo (Set.insert (from,to) linked)
+ -- The placed end of the edge is part of a chain already and not an end.
+ | otherwise
+ = do
+ let block = if alreadyPlaced to then from else to
+ --pprTraceM "Singleton" $ ppr block
+ let newChain = chainSingleton block
+ ref <- newSTRef newChain
+ buildNext (setInsert block placed) (mapInsert block ref chainStarts)
+ (mapInsert block ref chainEnds) todo (linked)
+ where
+ alreadyPlaced blkId = (setMember blkId placed)
+
+-- | Place basic blocks based on the given CFG.
+-- See Note [Chain based CFG serialization]
+sequenceChain :: forall a i. (Instruction i, Outputable i)
+ => LabelMap a -- ^ Keys indicate an info table on the block.
+ -> CFG -- ^ Control flow graph and some meta data.
+ -> [GenBasicBlock i] -- ^ List of basic blocks to be placed.
+ -> [GenBasicBlock i] -- ^ Blocks placed in sequence.
+sequenceChain _info _weights [] = []
+sequenceChain _info _weights [x] = [x]
+sequenceChain info weights blocks@((BasicBlock entry _):_) =
+ let directEdges :: [CfgEdge]
+ directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights)
+ where
+ -- Apply modifiers to turn edge frequencies into useable weights
+ -- for computing code layout.
+ -- See also Note [Layout relevant edge weights]
+ relevantWeight :: CfgEdge -> Maybe CfgEdge
+ relevantWeight edge@(CfgEdge from to edgeInfo)
+ | (EdgeInfo CmmSource { trans_cmmNode = CmmCall {} } _) <- edgeInfo
+ -- Ignore edges across calls.
+ = Nothing
+ | mapMember to info
+ , w <- edgeWeight edgeInfo
+ -- The payoff is quite small if we jump over an info table
+ = Just (CfgEdge from to edgeInfo { edgeWeight = w/8 })
+ | (EdgeInfo CmmSource { trans_cmmNode = exitNode } _) <- edgeInfo
+ , cantEliminate exitNode
+ , w <- edgeWeight edgeInfo
+ -- A small penalty to edge types which
+ -- we can't optimize away by layout.
+ -- w * 0.96875 == w - w/32
+ = Just (CfgEdge from to edgeInfo { edgeWeight = w * 0.96875 })
+ | otherwise
+ = Just edge
+ where
+ cantEliminate CmmCondBranch {} = True
+ cantEliminate CmmSwitch {} = True
+ cantEliminate _ = False
+
+ blockMap :: LabelMap (GenBasicBlock i)
+ blockMap
+ = foldl' (\m blk@(BasicBlock lbl _ins) ->
+ mapInsert lbl blk m)
+ mapEmpty blocks
+
+ (builtChains, builtEdges)
+ = {-# SCC "buildChains" #-}
+ --pprTraceIt "generatedChains" $
+ --pprTrace "blocks" (ppr (mapKeys blockMap)) $
+ buildChains directEdges (mapKeys blockMap)
+
+ rankedEdges :: [CfgEdge]
+ -- Sort descending by weight, remove fused edges
+ rankedEdges =
+ filter (\edge -> not (Set.member (edgeFrom edge,edgeTo edge) builtEdges)) $
+ directEdges
+
+ (neighbourChains, combined)
+ = ASSERT(noDups $ mapElems builtChains)
+ {-# SCC "groupNeighbourChains" #-}
+ -- pprTraceIt "NeighbourChains" $
+ combineNeighbourhood rankedEdges (mapElems builtChains)
+
+
+ allEdges :: [CfgEdge]
+ allEdges = {-# SCC allEdges #-}
+ sortOn (relevantWeight) $ filter (not . deadEdge) $ (infoEdgeList weights)
+ where
+ deadEdge :: CfgEdge -> Bool
+ deadEdge (CfgEdge from to _) = let e = (from,to) in Set.member e combined || Set.member e builtEdges
+ relevantWeight :: CfgEdge -> EdgeWeight
+ relevantWeight (CfgEdge _ _ edgeInfo)
+ | EdgeInfo (CmmSource { trans_cmmNode = CmmCall {}}) _ <- edgeInfo
+ -- Penalize edges across calls
+ = weight/(64.0)
+ | otherwise
+ = weight
+ where
+ -- negate to sort descending
+ weight = negate (edgeWeight edgeInfo)
+
+ masterChain =
+ {-# SCC "mergeChains" #-}
+ -- pprTraceIt "MergedChains" $
+ mergeChains allEdges neighbourChains
+
+ --Make sure the first block stays first
+ prepedChains
+ | inFront entry masterChain
+ = [masterChain]
+ | (rest,entry) <- breakChainAt entry masterChain
+ = [entry,rest]
+#if __GLASGOW_HASKELL__ <= 810
+ | otherwise = pprPanic "Entry point eliminated" $
+ ppr masterChain
+#endif
+
+ blockList
+ = ASSERT(noDups [masterChain])
+ (concatMap fromOL $ map chainBlocks prepedChains)
+
+ --chainPlaced = setFromList $ map blockId blockList :: LabelSet
+ chainPlaced = setFromList $ blockList :: LabelSet
+ unplaced =
+ let blocks = mapKeys blockMap
+ isPlaced b = setMember (b) chainPlaced
+ in filter (\block -> not (isPlaced block)) blocks
+
+ placedBlocks =
+ -- We want debug builds to catch this as it's a good indicator for
+ -- issues with CFG invariants. But we don't want to blow up production
+ -- builds if something slips through.
+ ASSERT(null unplaced)
+ --pprTraceIt "placedBlocks" $
+ -- ++ [] is stil kinda expensive
+ if null unplaced then blockList else blockList ++ unplaced
+ getBlock bid = expectJust "Block placement" $ mapLookup bid blockMap
+ in
+ --Assert we placed all blocks given as input
+ ASSERT(all (\bid -> mapMember bid blockMap) placedBlocks)
+ dropJumps info $ map getBlock placedBlocks
+
+{-# SCC dropJumps #-}
+-- | Remove redundant jumps between blocks when we can rely on
+-- fall through.
+dropJumps :: forall a i. Instruction i => LabelMap a -> [GenBasicBlock i]
+ -> [GenBasicBlock i]
+dropJumps _ [] = []
+dropJumps info ((BasicBlock lbl ins):todo)
+ | not . null $ ins --This can happen because of shortcutting
+ , [dest] <- jumpDestsOfInstr (last ins)
+ , ((BasicBlock nextLbl _) : _) <- todo
+ , not (mapMember dest info)
+ , nextLbl == dest
+ = BasicBlock lbl (init ins) : dropJumps info todo
+ | otherwise
+ = BasicBlock lbl ins : dropJumps info todo
+
+
+-- -----------------------------------------------------------------------------
+-- Sequencing the basic blocks
+
+-- Cmm BasicBlocks are self-contained entities: they always end in a
+-- jump, either non-local or to another basic block in the same proc.
+-- In this phase, we attempt to place the basic blocks in a sequence
+-- such that as many of the local jumps as possible turn into
+-- fallthroughs.
+
+sequenceTop
+ :: (Instruction instr, Outputable instr)
+ => DynFlags -- Determine which layout algo to use
+ -> NcgImpl statics instr jumpDest
+ -> Maybe CFG -- ^ CFG if we have one.
+ -> NatCmmDecl statics instr -- ^ Function to serialize
+ -> NatCmmDecl statics instr
+
+sequenceTop _ _ _ top@(CmmData _ _) = top
+sequenceTop dflags ncgImpl edgeWeights
+ (CmmProc info lbl live (ListGraph blocks))
+ | (gopt Opt_CfgBlocklayout dflags) && backendMaintainsCfg (targetPlatform dflags)
+ --Use chain based algorithm
+ , Just cfg <- edgeWeights
+ = CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
+ {-# SCC layoutBlocks #-}
+ sequenceChain info cfg blocks )
+ | otherwise
+ --Use old algorithm
+ = let cfg = if dontUseCfg then Nothing else edgeWeights
+ in CmmProc info lbl live ( ListGraph $ ncgMakeFarBranches ncgImpl info $
+ {-# SCC layoutBlocks #-}
+ sequenceBlocks cfg info blocks)
+ where
+ dontUseCfg = gopt Opt_WeightlessBlocklayout dflags ||
+ (not $ backendMaintainsCfg (targetPlatform dflags))
+
+-- The old algorithm:
+-- It is very simple (and stupid): We make a graph out of
+-- the blocks where there is an edge from one block to another iff the
+-- first block ends by jumping to the second. Then we topologically
+-- sort this graph. Then traverse the list: for each block, we first
+-- output the block, then if it has an out edge, we move the
+-- destination of the out edge to the front of the list, and continue.
+
+-- FYI, the classic layout for basic blocks uses postorder DFS; this
+-- algorithm is implemented in Hoopl.
+
+sequenceBlocks :: Instruction inst => Maybe CFG -> LabelMap a
+ -> [GenBasicBlock inst] -> [GenBasicBlock inst]
+sequenceBlocks _edgeWeight _ [] = []
+sequenceBlocks edgeWeights infos (entry:blocks) =
+ let entryNode = mkNode edgeWeights entry
+ bodyNodes = reverse
+ (flattenSCCs (sccBlocks edgeWeights blocks))
+ in dropJumps infos . seqBlocks infos $ ( entryNode : bodyNodes)
+ -- the first block is the entry point ==> it must remain at the start.
+
+sccBlocks
+ :: Instruction instr
+ => Maybe CFG -> [NatBasicBlock instr]
+ -> [SCC (Node BlockId (NatBasicBlock instr))]
+sccBlocks edgeWeights blocks =
+ stronglyConnCompFromEdgedVerticesUniqR
+ (map (mkNode edgeWeights) blocks)
+
+mkNode :: (Instruction t)
+ => Maybe CFG -> GenBasicBlock t
+ -> Node BlockId (GenBasicBlock t)
+mkNode edgeWeights block@(BasicBlock id instrs) =
+ DigraphNode block id outEdges
+ where
+ outEdges :: [BlockId]
+ outEdges
+ --Select the heaviest successor, ignore weights <= zero
+ = successor
+ where
+ successor
+ | Just successors <- fmap (`getSuccEdgesSorted` id)
+ edgeWeights -- :: Maybe [(Label, EdgeInfo)]
+ = case successors of
+ [] -> []
+ ((target,info):_)
+ | length successors > 2 || edgeWeight info <= 0 -> []
+ | otherwise -> [target]
+ | otherwise
+ = case jumpDestsOfInstr (last instrs) of
+ [one] -> [one]
+ _many -> []
+
+
+seqBlocks :: LabelMap i -> [Node BlockId (GenBasicBlock t1)]
+ -> [GenBasicBlock t1]
+seqBlocks infos blocks = placeNext pullable0 todo0
+ where
+ -- pullable: Blocks that are not yet placed
+ -- todo: Original order of blocks, to be followed if we have no good
+ -- reason not to;
+ -- may include blocks that have already been placed, but then
+ -- these are not in pullable
+ pullable0 = listToUFM [ (i,(b,n)) | DigraphNode b i n <- blocks ]
+ todo0 = map node_key blocks
+
+ placeNext _ [] = []
+ placeNext pullable (i:rest)
+ | Just (block, pullable') <- lookupDeleteUFM pullable i
+ = place pullable' rest block
+ | otherwise
+ -- We already placed this block, so ignore
+ = placeNext pullable rest
+
+ place pullable todo (block,[])
+ = block : placeNext pullable todo
+ place pullable todo (block@(BasicBlock id instrs),[next])
+ | mapMember next infos
+ = block : placeNext pullable todo
+ | Just (nextBlock, pullable') <- lookupDeleteUFM pullable next
+ = BasicBlock id instrs : place pullable' todo nextBlock
+ | otherwise
+ = block : placeNext pullable todo
+ place _ _ (_,tooManyNextNodes)
+ = pprPanic "seqBlocks" (ppr tooManyNextNodes)
+
+
+lookupDeleteUFM :: UniqFM BlockId elt -> BlockId
+ -> Maybe (elt, UniqFM BlockId elt)
+lookupDeleteUFM m k = do -- Maybe monad
+ v <- lookupUFM m k
+ return (v, delFromUFM m k)
+
+backendMaintainsCfg :: Platform -> Bool
+backendMaintainsCfg platform = case platformArch platform of
+ -- ArchX86 -- Should work but not tested so disabled currently.
+ ArchX86_64 -> True
+ _otherwise -> False
+
diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs
new file mode 100644
index 0000000..475abb5
--- /dev/null
+++ b/compiler/GHC/CmmToAsm/CFG.hs
@@ -0,0 +1,1349 @@
+--
+-- Copyright (c) 2018 Andreas Klebinger
+--
+
+{-# LANGUAGE TypeFamilies, ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE Rank2Types #-}
+{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE DataKinds #-}
+
+module GHC.CmmToAsm.CFG
+ ( CFG, CfgEdge(..), EdgeInfo(..), EdgeWeight(..)
+ , TransitionSource(..)
+
+ --Modify the CFG
+ , addWeightEdge, addEdge
+ , delEdge, delNode
+ , addNodesBetween, shortcutWeightMap
+ , reverseEdges, filterEdges
+ , addImmediateSuccessor
+ , mkWeightInfo, adjustEdgeWeight, setEdgeWeight
+
+ --Query the CFG
+ , infoEdgeList, edgeList
+ , getSuccessorEdges, getSuccessors
+ , getSuccEdgesSorted
+ , getEdgeInfo
+ , getCfgNodes, hasNode
+
+ -- Loop Information
+ , loopMembers, loopLevels, loopInfo
+
+ --Construction/Misc
+ , getCfg, getCfgProc, pprEdgeWeights, sanityCheckCfg
+
+ --Find backedges and update their weight
+ , optimizeCFG
+ , mkGlobalWeights
+
+ )
+where
+
+#include "GhclibHsVersions.h"
+
+import GHC.Prelude
+
+import GHC.Cmm.BlockId
+import GHC.Cmm as Cmm
+
+import GHC.Cmm.Utils
+import GHC.Cmm.Switch
+import GHC.Cmm.Dataflow.Collections
+import GHC.Cmm.Dataflow.Label
+import GHC.Cmm.Dataflow.Block
+import qualified GHC.Cmm.Dataflow.Graph as G
+
+import GHC.Utils.Misc
+import GHC.Data.Graph.Directed
+import GHC.Data.Maybe
+
+import GHC.Types.Unique
+import qualified GHC.CmmToAsm.CFG.Dominators as Dom
+import Data.IntMap.Strict (IntMap)
+import Data.IntSet (IntSet)
+
+import qualified Data.IntMap.Strict as IM
+import qualified Data.Map as M
+import qualified Data.IntSet as IS
+import qualified Data.Set as S
+import Data.Tree
+import Data.Bifunctor
+
+import GHC.Utils.Outputable
+-- DEBUGGING ONLY
+--import GHC.Cmm.DebugBlock
+--import GHC.Data.OrdList
+--import GHC.Cmm.DebugBlock.Trace
+import GHC.Cmm.Ppr () -- For Outputable instances
+import qualified GHC.Driver.Session as D
+
+import Data.List (sort, nub, partition)
+import Data.STRef.Strict
+import Control.Monad.ST
+
+import Data.Array.MArray
+import Data.Array.ST
+import Data.Array.IArray
+import Data.Array.Unsafe (unsafeFreeze)
+import Data.Array.Base (unsafeRead, unsafeWrite)
+
+import Control.Monad
+
+type Prob = Double
+
+type Edge = (BlockId, BlockId)
+type Edges = [Edge]
+
+newtype EdgeWeight
+ = EdgeWeight { weightToDouble :: Double }
+ deriving (Eq,Ord,Enum,Num,Real,Fractional)
+
+instance Outputable EdgeWeight where
+ ppr (EdgeWeight w) = doublePrec 5 w
+
+type EdgeInfoMap edgeInfo = LabelMap (LabelMap edgeInfo)
+
+-- | A control flow graph where edges have been annotated with a weight.
+-- Implemented as IntMap (IntMap \<edgeData>)
+-- We must uphold the invariant that for each edge A -> B we must have:
+-- A entry B in the outer map.
+-- A entry B in the map we get when looking up A.
+-- Maintaining this invariant is useful as any failed lookup now indicates
+-- an actual error in code which might go unnoticed for a while
+-- otherwise.
+type CFG = EdgeInfoMap EdgeInfo
+
+data CfgEdge
+ = CfgEdge
+ { edgeFrom :: !BlockId
+ , edgeTo :: !BlockId
+ , edgeInfo :: !EdgeInfo
+ }
+
+-- | Careful! Since we assume there is at most one edge from A to B
+-- the Eq instance does not consider weight.
+instance Eq CfgEdge where
+ (==) (CfgEdge from1 to1 _) (CfgEdge from2 to2 _)
+ = from1 == from2 && to1 == to2
+
+-- | Edges are sorted ascending pointwise by weight, source and destination
+instance Ord CfgEdge where
+ compare (CfgEdge from1 to1 (EdgeInfo {edgeWeight = weight1}))
+ (CfgEdge from2 to2 (EdgeInfo {edgeWeight = weight2}))
+ | weight1 < weight2 || weight1 == weight2 && from1 < from2 ||
+ weight1 == weight2 && from1 == from2 && to1 < to2
+ = LT
+ | from1 == from2 && to1 == to2 && weight1 == weight2
+ = EQ
+ | otherwise
+ = GT
+
+instance Outputable CfgEdge where
+ ppr (CfgEdge from1 to1 edgeInfo)
+ = parens (ppr from1 <+> text "-(" <> ppr edgeInfo <> text ")->" <+> ppr to1)
+
+-- | Can we trace back a edge to a specific Cmm Node
+-- or has it been introduced during assembly codegen. We use this to maintain
+-- some information which would otherwise be lost during the
+-- Cmm \<-> asm transition.
+-- See also Note [Inverting Conditional Branches]
+data TransitionSource
+ = CmmSource { trans_cmmNode :: (CmmNode O C)
+ , trans_info :: BranchInfo }
+ | AsmCodeGen
+ deriving (Eq)
+
+data BranchInfo = NoInfo -- ^ Unknown, but not heap or stack check.
+ | HeapStackCheck -- ^ Heap or stack check
+ deriving Eq
+
+instance Outputable BranchInfo where
+ ppr NoInfo = text "regular"
+ ppr HeapStackCheck = text "heap/stack"
+
+isHeapOrStackCheck :: TransitionSource -> Bool
+isHeapOrStackCheck (CmmSource { trans_info = HeapStackCheck}) = True
+isHeapOrStackCheck _ = False
+
+-- | Information about edges
+data EdgeInfo
+ = EdgeInfo
+ { transitionSource :: !TransitionSource
+ , edgeWeight :: !EdgeWeight
+ } deriving (Eq)
+
+instance Outputable EdgeInfo where
+ ppr edgeInfo = text "weight:" <+> ppr (edgeWeight edgeInfo)
+
+-- | Convenience function, generate edge info based
+-- on weight not originating from cmm.
+mkWeightInfo :: EdgeWeight -> EdgeInfo
+mkWeightInfo = EdgeInfo AsmCodeGen
+
+-- | Adjust the weight between the blocks using the given function.
+-- If there is no such edge returns the original map.
+adjustEdgeWeight :: CFG -> (EdgeWeight -> EdgeWeight)
+ -> BlockId -> BlockId -> CFG
+adjustEdgeWeight cfg f from to
+ | Just info <- getEdgeInfo from to cfg
+ , !weight <- edgeWeight info
+ , !newWeight <- f weight
+ = addEdge from to (info { edgeWeight = newWeight}) cfg
+ | otherwise = cfg
+
+-- | Set the weight between the blocks to the given weight.
+-- If there is no such edge returns the original map.
+setEdgeWeight :: CFG -> EdgeWeight
+ -> BlockId -> BlockId -> CFG
+setEdgeWeight cfg !weight from to
+ | Just info <- getEdgeInfo from to cfg
+ = addEdge from to (info { edgeWeight = weight}) cfg
+ | otherwise = cfg
+
+
+getCfgNodes :: CFG -> [BlockId]
+getCfgNodes m =
+ mapKeys m
+
+-- | Is this block part of this graph?
+hasNode :: CFG -> BlockId -> Bool
+hasNode m node =
+ -- Check the invariant that each node must exist in the first map or not at all.
+ ASSERT( found || not (any (mapMember node) m))
+ found
+ where
+ found = mapMember node m
+
+
+
+-- | Check if the nodes in the cfg and the set of blocks are the same.
+-- In a case of a missmatch we panic and show the difference.
+sanityCheckCfg :: CFG -> LabelSet -> SDoc -> Bool
+sanityCheckCfg m blockSet msg
+ | blockSet == cfgNodes
+ = True
+ | otherwise =
+ pprPanic "Block list and cfg nodes don't match" (
+ text "difference:" <+> ppr diff $$
+ text "blocks:" <+> ppr blockSet $$
+ text "cfg:" <+> pprEdgeWeights m $$
+ msg )
+ False
+ where
+ cfgNodes = setFromList $ getCfgNodes m :: LabelSet
+ diff = (setUnion cfgNodes blockSet) `setDifference` (setIntersection cfgNodes blockSet) :: LabelSet
+
+-- | Filter the CFG with a custom function f.
+-- Paramaeters are `f from to edgeInfo`
+filterEdges :: (BlockId -> BlockId -> EdgeInfo -> Bool) -> CFG -> CFG
+filterEdges f cfg =
+ mapMapWithKey filterSources cfg
+ where
+ filterSources from m =
+ mapFilterWithKey (\to w -> f from to w) m
+
+
+{- Note [Updating the CFG during shortcutting]
+
+See Note [What is shortcutting] in the control flow optimization
+code (GHC.Cmm.ContFlowOpt) for a slightly more in depth explanation on shortcutting.
+
+In the native backend we shortcut jumps at the assembly level. ("GHC.CmmToAsm")
+This means we remove blocks containing only one jump from the code
+and instead redirecting all jumps targeting this block to the deleted
+blocks jump target.
+
+However we want to have an accurate representation of control
+flow in the CFG. So we add/remove edges accordingly to account
+for the eliminated blocks and new edges.
+
+If we shortcut A -> B -> C to A -> C:
+* We delete edges A -> B and B -> C
+* Replacing them with the edge A -> C
+
+We also try to preserve jump weights while doing so.
+
+Note that:
+* The edge B -> C can't have interesting weights since
+ the block B consists of a single unconditional jump without branching.
+* We delete the edge A -> B and add the edge A -> C.
+* The edge A -> B can be one of many edges originating from A so likely
+ has edge weights we want to preserve.
+
+For this reason we simply store the edge info from the original A -> B
+edge and apply this information to the new edge A -> C.
+
+Sometimes we have a scenario where jump target C is not represented by an
+BlockId but an immediate value. I'm only aware of this happening without
+tables next to code currently.
+
+Then we go from A ---> B - -> IMM to A - -> IMM where the dashed arrows
+are not stored in the CFG.
+
+In that case we simply delete the edge A -> B.
+
+In terms of implementation the native backend first builds a mapping
+from blocks suitable for shortcutting to their jump targets.
+Then it redirects all jump instructions to these blocks using the
+built up mapping.
+This function (shortcutWeightMap) takes the same mapping and
+applies the mapping to the CFG in the way laid out above.
+
+-}
+shortcutWeightMap :: LabelMap (Maybe BlockId) -> CFG -> CFG
+shortcutWeightMap cuts cfg =
+ foldl' applyMapping cfg $ mapToList cuts
+ where
+-- takes the tuple (B,C) from the notation in [Updating the CFG during shortcutting]
+ applyMapping :: CFG -> (BlockId,Maybe BlockId) -> CFG
+ --Shortcut immediate
+ applyMapping m (from, Nothing) =
+ mapDelete from .
+ fmap (mapDelete from) $ m
+ --Regular shortcut
+ applyMapping m (from, Just to) =
+ let updatedMap :: CFG
+ updatedMap
+ = fmap (shortcutEdge (from,to)) $
+ (mapDelete from m :: CFG )
+ --Sometimes we can shortcut multiple blocks like so:
+ -- A -> B -> C -> D -> E => A -> E
+ -- so we check for such chains.
+ in case mapLookup to cuts of
+ Nothing -> updatedMap
+ Just dest -> applyMapping updatedMap (to, dest)
+ --Redirect edge from B to C
+ shortcutEdge :: (BlockId, BlockId) -> LabelMap EdgeInfo -> LabelMap EdgeInfo
+ shortcutEdge (from, to) m =
+ case mapLookup from m of
+ Just info -> mapInsert to info $ mapDelete from m
+ Nothing -> m
+
+-- | Sometimes we insert a block which should unconditionally be executed
+-- after a given block. This function updates the CFG for these cases.
+-- So we get A -> B => A -> A' -> B
+-- \ \
+-- -> C => -> C
+--
+addImmediateSuccessor :: D.DynFlags -> BlockId -> BlockId -> CFG -> CFG
+addImmediateSuccessor dflags node follower cfg
+ = updateEdges . addWeightEdge node follower uncondWeight $ cfg
+ where
+ uncondWeight = fromIntegral . D.uncondWeight .
+ D.cfgWeightInfo $ dflags
+ targets = getSuccessorEdges cfg node
+ successors = map fst targets :: [BlockId]
+ updateEdges = addNewSuccs . remOldSuccs
+ remOldSuccs m = foldl' (flip (delEdge node)) m successors
+ addNewSuccs m =
+ foldl' (\m' (t,info) -> addEdge follower t info m') m targets
+
+-- | Adds a new edge, overwrites existing edges if present
+addEdge :: BlockId -> BlockId -> EdgeInfo -> CFG -> CFG
+addEdge from to info cfg =
+ mapAlter addFromToEdge from $
+ mapAlter addDestNode to cfg
+ where
+ -- Simply insert the edge into the edge list.
+ addFromToEdge Nothing = Just $ mapSingleton to info
+ addFromToEdge (Just wm) = Just $ mapInsert to info wm
+ -- We must add the destination node explicitly
+ addDestNode Nothing = Just $ mapEmpty
+ addDestNode n@(Just _) = n
+
+
+-- | Adds a edge with the given weight to the cfg
+-- If there already existed an edge it is overwritten.
+-- `addWeightEdge from to weight cfg`
+addWeightEdge :: BlockId -> BlockId -> EdgeWeight -> CFG -> CFG
+addWeightEdge from to weight cfg =
+ addEdge from to (mkWeightInfo weight) cfg
+
+delEdge :: BlockId -> BlockId -> CFG -> CFG
+delEdge from to m =
+ mapAlter remDest from m
+ where
+ remDest Nothing = Nothing
+ remDest (Just wm) = Just $ mapDelete to wm
+
+delNode :: BlockId -> CFG -> CFG
+delNode node cfg =
+ fmap (mapDelete node) -- < Edges to the node
+ (mapDelete node cfg) -- < Edges from the node
+
+-- | Destinations from bid ordered by weight (descending)
+getSuccEdgesSorted :: CFG -> BlockId -> [(BlockId,EdgeInfo)]
+getSuccEdgesSorted m bid =
+ let destMap = mapFindWithDefault mapEmpty bid m
+ cfgEdges = mapToList destMap
+ sortedEdges = sortWith (negate . edgeWeight . snd) cfgEdges
+ in --pprTrace "getSuccEdgesSorted" (ppr bid <+> text "map:" <+> ppr m)
+ sortedEdges
+
+-- | Get successors of a given node with edge weights.
+getSuccessorEdges :: HasDebugCallStack => CFG -> BlockId -> [(BlockId,EdgeInfo)]
+getSuccessorEdges m bid = maybe lookupError mapToList (mapLookup bid m)
+ where
+ lookupError = pprPanic "getSuccessorEdges: Block does not exist" $
+ ppr bid <+> pprEdgeWeights m
+
+getEdgeInfo :: BlockId -> BlockId -> CFG -> Maybe EdgeInfo
+getEdgeInfo from to m
+ | Just wm <- mapLookup from m
+ , Just info <- mapLookup to wm
+ = Just $! info
+ | otherwise
+ = Nothing
+
+getEdgeWeight :: CFG -> BlockId -> BlockId -> EdgeWeight
+getEdgeWeight cfg from to =
+ edgeWeight $ expectJust "Edgeweight for noexisting block" $
+ getEdgeInfo from to cfg
+
+getTransitionSource :: BlockId -> BlockId -> CFG -> TransitionSource
+getTransitionSource from to cfg = transitionSource $ expectJust "Source info for noexisting block" $
+ getEdgeInfo from to cfg
+
+reverseEdges :: CFG -> CFG
+reverseEdges cfg = mapFoldlWithKey (\cfg from toMap -> go (addNode cfg from) from toMap) mapEmpty cfg
+ where
+ -- We must preserve nodes without outgoing edges!
+ addNode :: CFG -> BlockId -> CFG
+ addNode cfg b = mapInsertWith mapUnion b mapEmpty cfg
+ go :: CFG -> BlockId -> (LabelMap EdgeInfo) -> CFG
+ go cfg from toMap = mapFoldlWithKey (\cfg to info -> addEdge to from info cfg) cfg toMap :: CFG
+
+
+-- | Returns a unordered list of all edges with info
+infoEdgeList :: CFG -> [CfgEdge]
+infoEdgeList m =
+ go (mapToList m) []
+ where
+ -- We avoid foldMap to avoid thunk buildup
+ go :: [(BlockId,LabelMap EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
+ go [] acc = acc
+ go ((from,toMap):xs) acc
+ = go' xs from (mapToList toMap) acc
+ go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [(BlockId,EdgeInfo)] -> [CfgEdge] -> [CfgEdge]
+ go' froms _ [] acc = go froms acc
+ go' froms from ((to,info):tos) acc
+ = go' froms from tos (CfgEdge from to info : acc)
+
+-- | Returns a unordered list of all edges without weights
+edgeList :: CFG -> [Edge]
+edgeList m =
+ go (mapToList m) []
+ where
+ -- We avoid foldMap to avoid thunk buildup
+ go :: [(BlockId,LabelMap EdgeInfo)] -> [Edge] -> [Edge]
+ go [] acc = acc
+ go ((from,toMap):xs) acc
+ = go' xs from (mapKeys toMap) acc
+ go' :: [(BlockId,LabelMap EdgeInfo)] -> BlockId -> [BlockId] -> [Edge] -> [Edge]
+ go' froms _ [] acc = go froms acc
+ go' froms from (to:tos) acc
+ = go' froms from tos ((from,to) : acc)
+
+-- | Get successors of a given node without edge weights.
+getSuccessors :: HasDebugCallStack => CFG -> BlockId -> [BlockId]
+getSuccessors m bid
+ | Just wm <- mapLookup bid m
+ = mapKeys wm
+ | otherwise = lookupError
+ where
+ lookupError = pprPanic "getSuccessors: Block does not exist" $
+ ppr bid <+> pprEdgeWeights m
+
+pprEdgeWeights :: CFG -> SDoc
+pprEdgeWeights m =
+ let edges = sort $ infoEdgeList m :: [CfgEdge]
+ printEdge (CfgEdge from to (EdgeInfo { edgeWeight = weight }))
+ = text "\t" <> ppr from <+> text "->" <+> ppr to <>
+ text "[label=\"" <> ppr weight <> text "\",weight=\"" <>
+ ppr weight <> text "\"];\n"
+ --for the case that there are no edges from/to this node.
+ --This should rarely happen but it can save a lot of time
+ --to immediately see it when it does.
+ printNode node
+ = text "\t" <> ppr node <> text ";\n"
+ getEdgeNodes (CfgEdge from to _) = [from,to]
+ edgeNodes = setFromList $ concatMap getEdgeNodes edges :: LabelSet
+ nodes = filter (\n -> (not . setMember n) edgeNodes) . mapKeys $ mapFilter null m
+ in
+ text "digraph {\n" <>
+ (foldl' (<>) empty (map printEdge edges)) <>
+ (foldl' (<>) empty (map printNode nodes)) <>
+ text "}\n"
+
+{-# INLINE updateEdgeWeight #-} --Allows eliminating the tuple when possible
+-- | Invariant: The edge **must** exist already in the graph.
+updateEdgeWeight :: (EdgeWeight -> EdgeWeight) -> Edge -> CFG -> CFG
+updateEdgeWeight f (from, to) cfg
+ | Just oldInfo <- getEdgeInfo from to cfg
+ = let !oldWeight = edgeWeight oldInfo
+ !newWeight = f oldWeight
+ in addEdge from to (oldInfo {edgeWeight = newWeight}) cfg
+ | otherwise
+ = panic "Trying to update invalid edge"
+
+-- from to oldWeight => newWeight
+mapWeights :: (BlockId -> BlockId -> EdgeWeight -> EdgeWeight) -> CFG -> CFG
+mapWeights f cfg =
+ foldl' (\cfg (CfgEdge from to info) ->
+ let oldWeight = edgeWeight info
+ newWeight = f from to oldWeight
+ in addEdge from to (info {edgeWeight = newWeight}) cfg)
+ cfg (infoEdgeList cfg)
+
+
+-- | Insert a block in the control flow between two other blocks.
+-- We pass a list of tuples (A,B,C) where
+-- * A -> C: Old edge
+-- * A -> B -> C : New Arc, where B is the new block.
+-- It's possible that a block has two jumps to the same block
+-- in the assembly code. However we still only store a single edge for
+-- these cases.
+-- We assign the old edge info to the edge A -> B and assign B -> C the
+-- weight of an unconditional jump.
+addNodesBetween :: D.DynFlags -> CFG -> [(BlockId,BlockId,BlockId)] -> CFG
+addNodesBetween dflags m updates =
+ foldl' updateWeight m .
+ weightUpdates $ updates
+ where
+ weight = fromIntegral . D.uncondWeight .
+ D.cfgWeightInfo $ dflags
+ -- We might add two blocks for different jumps along a single
+ -- edge. So we end up with edges: A -> B -> C , A -> D -> C
+ -- in this case after applying the first update the weight for A -> C
+ -- is no longer available. So we calculate future weights before updates.
+ weightUpdates = map getWeight
+ getWeight :: (BlockId,BlockId,BlockId) -> (BlockId,BlockId,BlockId,EdgeInfo)
+ getWeight (from,between,old)
+ | Just edgeInfo <- getEdgeInfo from old m
+ = (from,between,old,edgeInfo)
+ | otherwise
+ = pprPanic "Can't find weight for edge that should have one" (
+ text "triple" <+> ppr (from,between,old) $$
+ text "updates" <+> ppr updates $$
+ text "cfg:" <+> pprEdgeWeights m )
+ updateWeight :: CFG -> (BlockId,BlockId,BlockId,EdgeInfo) -> CFG
+ updateWeight m (from,between,old,edgeInfo)
+ = addEdge from between edgeInfo .
+ addWeightEdge between old weight .
+ delEdge from old $ m
+
+{-
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+ ~~~ Note [CFG Edge Weights] ~~~
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ Edge weights assigned do not currently represent a specific
+ cost model and rather just a ranking of which blocks should
+ be placed next to each other given their connection type in
+ the CFG.
+ This is especially relevant if we whenever two blocks will
+ jump to the same target.
+
+ A B
+ \ /
+ C
+
+ Should A or B be placed in front of C? The block layout algorithm
+ decides this based on which edge (A,C)/(B,C) is heavier. So we
+ make a educated guess on which branch should be preferred.
+
+ We rank edges in this order:
+ * Unconditional Control Transfer - They will always
+ transfer control to their target. Unless there is a info table
+ we can turn the jump into a fallthrough as well.
+ We use 20k as default, so it's easy to spot if values have been
+ modified but unlikely that we run into issues with overflow.
+ * If branches (likely) - We assume branches marked as likely
+ are taken more than 80% of the time.
+ By ranking them below unconditional jumps we make sure we
+ prefer the unconditional if there is a conditional and
+ unconditional edge towards a block.
+ * If branches (regular) - The false branch can potentially be turned
+ into a fallthrough so we prefer it slightly over the true branch.
+ * Unlikely branches - These can be assumed to be taken less than 20%
+ of the time. So we given them one of the lowest priorities.
+ * Switches - Switches at this level are implemented as jump tables
+ so have a larger number of successors. So without more information
+ we can only say that each individual successor is unlikely to be
+ jumped to and we rank them accordingly.
+ * Calls - We currently ignore calls completely:
+ * By the time we return from a call there is a good chance
+ that the address we return to has already been evicted from
+ cache eliminating a main advantage sequential placement brings.
+ * Calls always require a info table in front of their return
+ address. This reduces the chance that we return to the same
+ cache line further.
+
+-}
+-- | Generate weights for a Cmm proc based on some simple heuristics.
+getCfgProc :: D.CfgWeights -> RawCmmDecl -> CFG
+getCfgProc _ (CmmData {}) = mapEmpty
+getCfgProc weights (CmmProc _info _lab _live graph) = getCfg weights graph
+
+getCfg :: D.CfgWeights -> CmmGraph -> CFG
+getCfg weights graph =
+ foldl' insertEdge edgelessCfg $ concatMap getBlockEdges blocks
+ where
+ D.CFGWeights
+ { D.uncondWeight = uncondWeight
+ , D.condBranchWeight = condBranchWeight
+ , D.switchWeight = switchWeight
+ , D.callWeight = callWeight
+ , D.likelyCondWeight = likelyCondWeight
+ , D.unlikelyCondWeight = unlikelyCondWeight
+ -- Last two are used in other places
+ --, D.infoTablePenalty = infoTablePenalty
+ --, D.backEdgeBonus = backEdgeBonus
+ } = weights
+ -- Explicitly add all nodes to the cfg to ensure they are part of the
+ -- CFG.
+ edgelessCfg = mapFromList $ zip (map G.entryLabel blocks) (repeat mapEmpty)
+ insertEdge :: CFG -> ((BlockId,BlockId),EdgeInfo) -> CFG
+ insertEdge m ((from,to),weight) =
+ mapAlter f from m
+ where
+ f :: Maybe (LabelMap EdgeInfo) -> Maybe (LabelMap EdgeInfo)
+ f Nothing = Just $ mapSingleton to weight
+ f (Just destMap) = Just $ mapInsert to weight destMap
+ getBlockEdges :: CmmBlock -> [((BlockId,BlockId),EdgeInfo)]
+ getBlockEdges block =
+ case branch of
+ CmmBranch dest -> [mkEdge dest uncondWeight]
+ CmmCondBranch cond t f l
+ | l == Nothing ->
+ [mkEdge f condBranchWeight, mkEdge t condBranchWeight]
+ | l == Just True ->
+ [mkEdge f unlikelyCondWeight, mkEdge t likelyCondWeight]
+ | l == Just False ->
+ [mkEdge f likelyCondWeight, mkEdge t unlikelyCondWeight]
+ where
+ mkEdgeInfo = -- pprTrace "Info" (ppr branchInfo <+> ppr cond)
+ EdgeInfo (CmmSource branch branchInfo) . fromIntegral
+ mkEdge target weight = ((bid,target), mkEdgeInfo weight)
+ branchInfo =
+ foldRegsUsed
+ (panic "foldRegsDynFlags")
+ (\info r -> if r == SpLim || r == HpLim || r == BaseReg
+ then HeapStackCheck else info)
+ NoInfo cond
+
+ (CmmSwitch _e ids) ->
+ let switchTargets = switchTargetsToList ids
+ --Compiler performance hack - for very wide switches don't
+ --consider targets for layout.
+ adjustedWeight =
+ if (length switchTargets > 10) then -1 else switchWeight
+ in map (\x -> mkEdge x adjustedWeight) switchTargets
+ (CmmCall { cml_cont = Just cont}) -> [mkEdge cont callWeight]
+ (CmmForeignCall {Cmm.succ = cont}) -> [mkEdge cont callWeight]
+ (CmmCall { cml_cont = Nothing }) -> []
+ other ->
+ panic "Foo" $
+ ASSERT2(False, ppr "Unknown successor cause:" <>
+ (ppr branch <+> text "=>" <> ppr (G.successors other)))
+ map (\x -> ((bid,x),mkEdgeInfo 0)) $ G.successors other
+ where
+ bid = G.entryLabel block
+ mkEdgeInfo = EdgeInfo (CmmSource branch NoInfo) . fromIntegral
+ mkEdge target weight = ((bid,target), mkEdgeInfo weight)
+ branch = lastNode block :: CmmNode O C
+
+ blocks = revPostorder graph :: [CmmBlock]
+
+--Find back edges by BFS
+findBackEdges :: HasDebugCallStack => BlockId -> CFG -> Edges
+findBackEdges root cfg =
+ --pprTraceIt "Backedges:" $
+ map fst .
+ filter (\x -> snd x == Backward) $ typedEdges
+ where
+ edges = edgeList cfg :: [(BlockId,BlockId)]
+ getSuccs = getSuccessors cfg :: BlockId -> [BlockId]
+ typedEdges =
+ classifyEdges root getSuccs edges :: [((BlockId,BlockId),EdgeType)]
+
+optimizeCFG :: Bool -> D.CfgWeights -> RawCmmDecl -> CFG -> CFG
+optimizeCFG _ _ (CmmData {}) cfg = cfg
+optimizeCFG doStaticPred weights proc@(CmmProc _info _lab _live graph) cfg =
+ (if doStaticPred then staticPredCfg (g_entry graph) else id) $
+ optHsPatterns weights proc $ cfg
+
+-- | Modify branch weights based on educated guess on
+-- patterns GHC tends to produce and how they affect
+-- performance.
+--
+-- Most importantly we penalize jumps across info tables.
+optHsPatterns :: D.CfgWeights -> RawCmmDecl -> CFG -> CFG
+optHsPatterns _ (CmmData {}) cfg = cfg
+optHsPatterns weights (CmmProc info _lab _live graph) cfg =
+ {-# SCC optHsPatterns #-}
+ -- pprTrace "Initial:" (pprEdgeWeights cfg) $
+ -- pprTrace "Initial:" (ppr $ mkGlobalWeights (g_entry graph) cfg) $
+
+ -- pprTrace "LoopInfo:" (ppr $ loopInfo cfg (g_entry graph)) $
+ favourFewerPreds .
+ penalizeInfoTables info .
+ increaseBackEdgeWeight (g_entry graph) $ cfg
+ where
+
+ -- | Increase the weight of all backedges in the CFG
+ -- this helps to make loop jumpbacks the heaviest edges
+ increaseBackEdgeWeight :: BlockId -> CFG -> CFG
+ increaseBackEdgeWeight root cfg =
+ let backedges = findBackEdges root cfg
+ update weight
+ --Keep irrelevant edges irrelevant
+ | weight <= 0 = 0
+ | otherwise
+ = weight + fromIntegral (D.backEdgeBonus weights)
+ in foldl' (\cfg edge -> updateEdgeWeight update edge cfg)
+ cfg backedges
+
+ -- | Since we cant fall through info tables we penalize these.
+ penalizeInfoTables :: LabelMap a -> CFG -> CFG
+ penalizeInfoTables info cfg =
+ mapWeights fupdate cfg
+ where
+ fupdate :: BlockId -> BlockId -> EdgeWeight -> EdgeWeight
+ fupdate _ to weight
+ | mapMember to info
+ = weight - (fromIntegral $ D.infoTablePenalty weights)
+ | otherwise = weight
+
+ -- | If a block has two successors, favour the one with fewer
+ -- predecessors and/or the one allowing fall through.
+ favourFewerPreds :: CFG -> CFG
+ favourFewerPreds cfg =
+ let
+ revCfg =
+ reverseEdges $ filterEdges
+ (\_from -> fallthroughTarget) cfg
+
+ predCount n = length $ getSuccessorEdges revCfg n
+ nodes = getCfgNodes cfg
+
+ modifiers :: Int -> Int -> (EdgeWeight, EdgeWeight)
+ modifiers preds1 preds2
+ | preds1 < preds2 = ( 1,-1)
+ | preds1 == preds2 = ( 0, 0)
+ | otherwise = (-1, 1)
+
+ update :: CFG -> BlockId -> CFG
+ update cfg node
+ | [(s1,e1),(s2,e2)] <- getSuccessorEdges cfg node
+ , !w1 <- edgeWeight e1
+ , !w2 <- edgeWeight e2
+ --Only change the weights if there isn't already a ordering.
+ , w1 == w2
+ , (mod1,mod2) <- modifiers (predCount s1) (predCount s2)
+ = (\cfg' ->
+ (adjustEdgeWeight cfg' (+mod2) node s2))
+ (adjustEdgeWeight cfg (+mod1) node s1)
+ | otherwise
+ = cfg
+ in foldl' update cfg nodes
+ where
+ fallthroughTarget :: BlockId -> EdgeInfo -> Bool
+ fallthroughTarget to (EdgeInfo source _weight)
+ | mapMember to info = False
+ | AsmCodeGen <- source = True
+ | CmmSource { trans_cmmNode = CmmBranch {} } <- source = True
+ | CmmSource { trans_cmmNode = CmmCondBranch {} } <- source = True
+ | otherwise = False
+
+-- | Convert block-local branch weights to global weights.
+staticPredCfg :: BlockId -> CFG -> CFG
+staticPredCfg entry cfg = cfg'
+ where
+ (_, globalEdgeWeights) = {-# SCC mkGlobalWeights #-}
+ mkGlobalWeights entry cfg
+ cfg' = {-# SCC rewriteEdges #-}
+ mapFoldlWithKey
+ (\cfg from m ->
+ mapFoldlWithKey
+ (\cfg to w -> setEdgeWeight cfg (EdgeWeight w) from to )
+ cfg m )
+ cfg
+ globalEdgeWeights
+
+-- | Determine loop membership of blocks based on SCC analysis
+-- This is faster but only gives yes/no answers.
+loopMembers :: HasDebugCallStack => CFG -> LabelMap Bool
+loopMembers cfg =
+ foldl' (flip setLevel) mapEmpty sccs
+ where
+ mkNode :: BlockId -> Node BlockId BlockId
+ mkNode bid = DigraphNode bid bid (getSuccessors cfg bid)
+ nodes = map mkNode (getCfgNodes cfg)
+
+ sccs = stronglyConnCompFromEdgedVerticesOrd nodes
+
+ setLevel :: SCC BlockId -> LabelMap Bool -> LabelMap Bool
+ setLevel (AcyclicSCC bid) m = mapInsert bid False m
+ setLevel (CyclicSCC bids) m = foldl' (\m k -> mapInsert k True m) m bids
+
+loopLevels :: CFG -> BlockId -> LabelMap Int
+loopLevels cfg root = liLevels loopInfos
+ where
+ loopInfos = loopInfo cfg root
+
+data LoopInfo = LoopInfo
+ { liBackEdges :: [(Edge)] -- ^ List of back edges
+ , liLevels :: LabelMap Int -- ^ BlockId -> LoopLevel mapping
+ , liLoops :: [(Edge, LabelSet)] -- ^ (backEdge, loopBody), body includes header
+ }
+
+instance Outputable LoopInfo where
+ ppr (LoopInfo _ _lvls loops) =
+ text "Loops:(backEdge, bodyNodes)" $$
+ (vcat $ map ppr loops)
+
+{- Note [Determining the loop body]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+ Starting with the knowledge that:
+ * head dominates the loop
+ * `tail` -> `head` is a backedge
+
+ We can determine all nodes by:
+ * Deleting the loop head from the graph.
+ * Collect all blocks which are reachable from the `tail`.
+
+ We do so by performing bfs from the tail node towards the head.
+ -}
+
+-- | Determine loop membership of blocks based on Dominator analysis.
+-- This is slower but gives loop levels instead of just loop membership.
+-- However it only detects natural loops. Irreducible control flow is not
+-- recognized even if it loops. But that is rare enough that we don't have
+-- to care about that special case.
+loopInfo :: HasDebugCallStack => CFG -> BlockId -> LoopInfo
+loopInfo cfg root = LoopInfo { liBackEdges = backEdges
+ , liLevels = mapFromList loopCounts
+ , liLoops = loopBodies }
+ where
+ revCfg = reverseEdges cfg
+
+ graph = -- pprTrace "CFG - loopInfo" (pprEdgeWeights cfg) $
+ fmap (setFromList . mapKeys ) cfg :: LabelMap LabelSet
+
+
+ --TODO - This should be a no op: Export constructors? Use unsafeCoerce? ...
+ rooted = ( fromBlockId root
+ , toIntMap $ fmap toIntSet graph) :: (Int, IntMap IntSet)
+ tree = fmap toBlockId $ Dom.domTree rooted :: Tree BlockId
+
+ -- Map from Nodes to their dominators
+ domMap :: LabelMap LabelSet
+ domMap = mkDomMap tree
+
+ edges = edgeList cfg :: [(BlockId, BlockId)]
+ -- We can't recompute nodes from edges, there might be blocks not connected via edges.
+ nodes = getCfgNodes cfg :: [BlockId]
+
+ -- identify back edges
+ isBackEdge (from,to)
+ | Just doms <- mapLookup from domMap
+ , setMember to doms
+ = True
+ | otherwise = False
+
+ -- See Note [Determining the loop body]
+ -- Get the loop body associated with a back edge.
+ findBody edge@(tail, head)
+ = ( edge, setInsert head $ go (setSingleton tail) (setSingleton tail) )
+ where
+ -- See Note [Determining the loop body]
+ cfg' = delNode head revCfg
+
+ go :: LabelSet -> LabelSet -> LabelSet
+ go found current
+ | setNull current = found
+ | otherwise = go (setUnion newSuccessors found)
+ newSuccessors
+ where
+ -- Really predecessors, since we use the reversed cfg.
+ newSuccessors = setFilter (\n -> not $ setMember n found) successors :: LabelSet
+ successors = setFromList $ concatMap
+ (getSuccessors cfg')
+ -- we filter head as it's no longer part of the cfg.
+ (filter (/= head) $ setElems current) :: LabelSet
+
+ backEdges = filter isBackEdge edges
+ loopBodies = map findBody backEdges :: [(Edge, LabelSet)]
+
+ -- Block b is part of n loop bodies => loop nest level of n
+ loopCounts =
+ let bodies = map (first snd) loopBodies -- [(Header, Body)]
+ loopCount n = length $ nub . map fst . filter (setMember n . snd) $ bodies
+ in map (\n -> (n, loopCount n)) $ nodes :: [(BlockId, Int)]
+
+ toIntSet :: LabelSet -> IntSet
+ toIntSet s = IS.fromList . map fromBlockId . setElems $ s
+ toIntMap :: LabelMap a -> IntMap a
+ toIntMap m = IM.fromList $ map (\(x,y) -> (fromBlockId x,y)) $ mapToList m
+
+ mkDomMap :: Tree BlockId -> LabelMap LabelSet
+ mkDomMap root = mapFromList $ go setEmpty root
+ where
+ go :: LabelSet -> Tree BlockId -> [(Label,LabelSet)]
+ go parents (Node lbl [])
+ = [(lbl, parents)]
+ go parents (Node _ leaves)
+ = let nodes = map rootLabel leaves
+ entries = map (\x -> (x,parents)) nodes
+ in entries ++ concatMap
+ (\n -> go (setInsert (rootLabel n) parents) n)
+ leaves
+
+ fromBlockId :: BlockId -> Int
+ fromBlockId = getKey . getUnique
+
+ toBlockId :: Int -> BlockId
+ toBlockId = mkBlockId . mkUniqueGrimily
+
+-- We make the CFG a Hoopl Graph, so we can reuse revPostOrder.
+newtype BlockNode (e :: Extensibility) (x :: Extensibility) = BN (BlockId,[BlockId])
+
+instance G.NonLocal (BlockNode) where
+ entryLabel (BN (lbl,_)) = lbl
+ successors (BN (_,succs)) = succs
+
+revPostorderFrom :: HasDebugCallStack => CFG -> BlockId -> [BlockId]
+revPostorderFrom cfg root =
+ map fromNode $ G.revPostorderFrom hooplGraph root
+ where
+ nodes = getCfgNodes cfg
+ hooplGraph = foldl' (\m n -> mapInsert n (toNode n) m) mapEmpty nodes
+
+ fromNode :: BlockNode C C -> BlockId
+ fromNode (BN x) = fst x
+
+ toNode :: BlockId -> BlockNode C C
+ toNode bid =
+ BN (bid,getSuccessors cfg $ bid)
+
+
+-- | We take in a CFG which has on its edges weights which are
+-- relative only to other edges originating from the same node.
+--
+-- We return a CFG for which each edge represents a GLOBAL weight.
+-- This means edge weights are comparable across the whole graph.
+--
+-- For irreducible control flow results might be imprecise, otherwise they
+-- are reliable.
+--
+-- The algorithm is based on the Paper
+-- "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus
+-- The only big change is that we go over the nodes in the body of loops in
+-- reverse post order. Which is required for diamond control flow to work probably.
+--
+-- We also apply a few prediction heuristics (based on the same paper)
+--
+-- The returned result represents frequences.
+-- For blocks it's the expected number of executions and
+-- for edges is the number of traversals.
+
+{-# NOINLINE mkGlobalWeights #-}
+{-# SCC mkGlobalWeights #-}
+mkGlobalWeights :: HasDebugCallStack => BlockId -> CFG -> (LabelMap Double, LabelMap (LabelMap Double))
+mkGlobalWeights root localCfg
+ | null localCfg = panic "Error - Empty CFG"
+ | otherwise
+ = (blockFreqs', edgeFreqs')
+ where
+ -- Calculate fixpoints
+ (blockFreqs, edgeFreqs) = calcFreqs nodeProbs backEdges' bodies' revOrder'
+ blockFreqs' = mapFromList $ map (first fromVertex) (assocs blockFreqs) :: LabelMap Double
+ edgeFreqs' = fmap fromVertexMap $ fromVertexMap edgeFreqs
+
+ fromVertexMap :: IM.IntMap x -> LabelMap x
+ fromVertexMap m = mapFromList . map (first fromVertex) $ IM.toList m
+
+ revOrder = revPostorderFrom localCfg root :: [BlockId]
+ loopResults@(LoopInfo backedges _levels bodies) = loopInfo localCfg root
+
+ revOrder' = map toVertex revOrder
+ backEdges' = map (bimap toVertex toVertex) backedges
+ bodies' = map calcBody bodies
+
+ estimatedCfg = staticBranchPrediction root loopResults localCfg
+ -- Normalize the weights to probabilities and apply heuristics
+ nodeProbs = cfgEdgeProbabilities estimatedCfg toVertex
+
+ -- By mapping vertices to numbers in reverse post order we can bring any subset into reverse post
+ -- order simply by sorting.
+ -- TODO: The sort is redundant if we can guarantee that setElems returns elements ascending
+ calcBody (backedge, blocks) =
+ (toVertex $ snd backedge, sort . map toVertex $ (setElems blocks))
+
+ vertexMapping = mapFromList $ zip revOrder [0..] :: LabelMap Int
+ blockMapping = listArray (0,mapSize vertexMapping - 1) revOrder :: Array Int BlockId
+ -- Map from blockId to indices starting at zero
+ toVertex :: BlockId -> Int
+ toVertex blockId = expectJust "mkGlobalWeights" $ mapLookup blockId vertexMapping
+ -- Map from indices starting at zero to blockIds
+ fromVertex :: Int -> BlockId
+ fromVertex vertex = blockMapping ! vertex
+
+{- Note [Static Branch Prediction]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+The work here has been based on the paper
+"Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus.
+
+The primary differences are that if we branch on the result of a heap
+check we do not apply any of the heuristics.
+The reason is simple: They look like loops in the control flow graph
+but are usually never entered, and if at most once.
+
+Currently implemented is a heuristic to predict that we do not exit
+loops (lehPredicts) and one to predict that backedges are more likely
+than any other edge.
+
+The back edge case is special as it superceeds any other heuristic if it
+applies.
+
+Do NOT rely solely on nofib results for benchmarking this. I recommend at least
+comparing megaparsec and container benchmarks. Nofib does not seeem to have
+many instances of "loopy" Cmm where these make a difference.
+
+TODO:
+* The paper containers more benchmarks which should be implemented.
+* If we turn the likelihood on if/else branches into a probability
+ instead of true/false we could implement this as a Cmm pass.
+ + The complete Cmm code still exists and can be accessed by the heuristics
+ + There is no chance of register allocation/codegen inserting branches/blocks
+ + making the TransitionSource info wrong.
+ + potential to use this information in CmmPasses.
+ - Requires refactoring of all the code relying on the binary nature of likelihood.
+ - Requires refactoring `loopInfo` to work on both, Cmm Graphs and the backend CFG.
+-}
+
+-- | Combination of target node id and information about the branch
+-- we are looking at.
+type TargetNodeInfo = (BlockId, EdgeInfo)
+
+
+-- | Update branch weights based on certain heuristics.
+-- See Note [Static Branch Prediction]
+-- TODO: This should be combined with optimizeCFG
+{-# SCC staticBranchPrediction #-}
+staticBranchPrediction :: BlockId -> LoopInfo -> CFG -> CFG
+staticBranchPrediction _root (LoopInfo l_backEdges loopLevels l_loops) cfg =
+ -- pprTrace "staticEstimatesOn" (ppr (cfg)) $
+ foldl' update cfg nodes
+ where
+ nodes = getCfgNodes cfg
+ backedges = S.fromList $ l_backEdges
+ -- Loops keyed by their back edge
+ loops = M.fromList $ l_loops :: M.Map Edge LabelSet
+ loopHeads = S.fromList $ map snd $ M.keys loops
+
+ update :: CFG -> BlockId -> CFG
+ update cfg node
+ -- No successors, nothing to do.
+ | null successors = cfg
+
+ -- Mix of backedges and others:
+ -- Always predict the backedges.
+ | not (null m) && length m < length successors
+ -- Heap/Stack checks "loop", but only once.
+ -- So we simply exclude any case involving them.
+ , not $ any (isHeapOrStackCheck . transitionSource . snd) successors
+ = let loopChance = repeat $! pred_LBH / (fromIntegral $ length m)
+ exitChance = repeat $! (1 - pred_LBH) / fromIntegral (length not_m)
+ updates = zip (map fst m) loopChance ++ zip (map fst not_m) exitChance
+ in -- pprTrace "mix" (ppr (node,successors)) $
+ foldl' (\cfg (to,weight) -> setEdgeWeight cfg weight node to) cfg updates
+
+ -- For (regular) non-binary branches we keep the weights from the STG -> Cmm translation.
+ | length successors /= 2
+ = cfg
+
+ -- Only backedges - no need to adjust
+ | length m > 0
+ = cfg
+
+ -- A regular binary branch, we can plug addition predictors in here.
+ | [(s1,s1_info),(s2,s2_info)] <- successors
+ , not $ any (isHeapOrStackCheck . transitionSource . snd) successors
+ = -- Normalize weights to total of 1
+ let !w1 = max (edgeWeight s1_info) (0)
+ !w2 = max (edgeWeight s2_info) (0)
+ -- Of both weights are <= 0 we set both to 0.5
+ normalizeWeight w = if w1 + w2 == 0 then 0.5 else w/(w1+w2)
+ !cfg' = setEdgeWeight cfg (normalizeWeight w1) node s1
+ !cfg'' = setEdgeWeight cfg' (normalizeWeight w2) node s2
+
+ -- Figure out which heuristics apply to these successors
+ heuristics = map ($ ((s1,s1_info),(s2,s2_info)))
+ [lehPredicts, phPredicts, ohPredicts, ghPredicts, lhhPredicts, chPredicts
+ , shPredicts, rhPredicts]
+ -- Apply result of a heuristic. Argument is the likelihood
+ -- predicted for s1.
+ applyHeuristic :: CFG -> Maybe Prob -> CFG
+ applyHeuristic cfg Nothing = cfg
+ applyHeuristic cfg (Just (s1_pred :: Double))
+ | s1_old == 0 || s2_old == 0 ||
+ isHeapOrStackCheck (transitionSource s1_info) ||
+ isHeapOrStackCheck (transitionSource s2_info)
+ = cfg
+ | otherwise =
+ let -- Predictions from heuristic
+ s1_prob = EdgeWeight s1_pred :: EdgeWeight
+ s2_prob = 1.0 - s1_prob
+ -- Update
+ d = (s1_old * s1_prob) + (s2_old * s2_prob) :: EdgeWeight
+ s1_prob' = s1_old * s1_prob / d
+ !s2_prob' = s2_old * s2_prob / d
+ !cfg_s1 = setEdgeWeight cfg s1_prob' node s1
+ in -- pprTrace "Applying heuristic!" (ppr (node,s1,s2) $$ ppr (s1_prob', s2_prob')) $
+ setEdgeWeight cfg_s1 s2_prob' node s2
+ where
+ -- Old weights
+ s1_old = getEdgeWeight cfg node s1
+ s2_old = getEdgeWeight cfg node s2
+
+ in
+ -- pprTraceIt "RegularCfgResult" $
+ foldl' applyHeuristic cfg'' heuristics
+
+ -- Branch on heap/stack check
+ | otherwise = cfg
+
+ where
+ -- Chance that loops are taken.
+ pred_LBH = 0.875
+ -- successors
+ successors = getSuccessorEdges cfg node
+ -- backedges
+ (m,not_m) = partition (\succ -> S.member (node, fst succ) backedges) successors
+
+ -- Heuristics return nothing if they don't say anything about this branch
+ -- or Just (prob_s1) where prob_s1 is the likelihood for s1 to be the
+ -- taken branch. s1 is the branch in the true case.
+
+ -- Loop exit heuristic.
+ -- We are unlikely to leave a loop unless it's to enter another one.
+ pred_LEH = 0.75
+ -- If and only if no successor is a loopheader,
+ -- then we will likely not exit the current loop body.
+ lehPredicts :: (TargetNodeInfo,TargetNodeInfo) -> Maybe Prob
+ lehPredicts ((s1,_s1_info),(s2,_s2_info))
+ | S.member s1 loopHeads || S.member s2 loopHeads
+ = Nothing
+
+ | otherwise
+ = --pprTrace "lehPredict:" (ppr $ compare s1Level s2Level) $
+ case compare s1Level s2Level of
+ EQ -> Nothing
+ LT -> Just (1-pred_LEH) --s1 exits to a shallower loop level (exits loop)
+ GT -> Just (pred_LEH) --s1 exits to a deeper loop level
+ where
+ s1Level = mapLookup s1 loopLevels
+ s2Level = mapLookup s2 loopLevels
+
+ -- Comparing to a constant is unlikely to be equal.
+ ohPredicts (s1,_s2)
+ | CmmSource { trans_cmmNode = src1 } <- getTransitionSource node (fst s1) cfg
+ , CmmCondBranch cond ltrue _lfalse likely <- src1
+ , likely == Nothing
+ , CmmMachOp mop args <- cond
+ , MO_Eq {} <- mop
+ , not (null [x | x@CmmLit{} <- args])
+ = if fst s1 == ltrue then Just 0.3 else Just 0.7
+
+ | otherwise
+ = Nothing
+
+ -- TODO: These are all the other heuristics from the paper.
+ -- Not all will apply, for now we just stub them out as Nothing.
+ phPredicts = const Nothing
+ ghPredicts = const Nothing
+ lhhPredicts = const Nothing
+ chPredicts = const Nothing
+ shPredicts = const Nothing
+ rhPredicts = const Nothing
+
+-- We normalize all edge weights as probabilities between 0 and 1.
+-- Ignoring rounding errors all outgoing edges sum up to 1.
+cfgEdgeProbabilities :: CFG -> (BlockId -> Int) -> IM.IntMap (IM.IntMap Prob)
+cfgEdgeProbabilities cfg toVertex
+ = mapFoldlWithKey foldEdges IM.empty cfg
+ where
+ foldEdges = (\m from toMap -> IM.insert (toVertex from) (normalize toMap) m)
+
+ normalize :: (LabelMap EdgeInfo) -> (IM.IntMap Prob)
+ normalize weightMap
+ | edgeCount <= 1 = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) 1.0 m) IM.empty weightMap
+ | otherwise = mapFoldlWithKey (\m k _ -> IM.insert (toVertex k) (normalWeight k) m) IM.empty weightMap
+ where
+ edgeCount = mapSize weightMap
+ -- Negative weights are generally allowed but are mapped to zero.
+ -- We then check if there is at least one non-zero edge and if not
+ -- assign uniform weights to all branches.
+ minWeight = 0 :: Prob
+ weightMap' = fmap (\w -> max (weightToDouble . edgeWeight $ w) minWeight) weightMap
+ totalWeight = sum weightMap'
+
+ normalWeight :: BlockId -> Prob
+ normalWeight bid
+ | totalWeight == 0
+ = 1.0 / fromIntegral edgeCount
+ | Just w <- mapLookup bid weightMap'
+ = w/totalWeight
+ | otherwise = panic "impossible"
+
+-- This is the fixpoint algorithm from
+-- "Static Branch Prediction and Program Profile Analysis" by Y Wu, JR Larus
+-- The adaption to Haskell is my own.
+calcFreqs :: IM.IntMap (IM.IntMap Prob) -> [(Int,Int)] -> [(Int, [Int])] -> [Int]
+ -> (Array Int Double, IM.IntMap (IM.IntMap Prob))
+calcFreqs graph backEdges loops revPostOrder = runST $ do
+ visitedNodes <- newArray (0,nodeCount-1) False :: ST s (STUArray s Int Bool)
+ blockFreqs <- newArray (0,nodeCount-1) 0.0 :: ST s (STUArray s Int Double)
+ edgeProbs <- newSTRef graph
+ edgeBackProbs <- newSTRef graph
+
+ -- let traceArray a = do
+ -- vs <- forM [0..nodeCount-1] $ \i -> readArray a i >>= (\v -> return (i,v))
+ -- trace ("array: " ++ show vs) $ return ()
+
+ let -- See #1600, we need to inline or unboxing makes perf worse.
+ -- {-# INLINE getFreq #-}
+ {-# INLINE visited #-}
+ visited b = unsafeRead visitedNodes b
+ getFreq b = unsafeRead blockFreqs b
+ -- setFreq :: forall s. Int -> Double -> ST s ()
+ setFreq b f = unsafeWrite blockFreqs b f
+ -- setVisited :: forall s. Node -> ST s ()
+ setVisited b = unsafeWrite visitedNodes b True
+ -- Frequency/probability that edge is taken.
+ getProb' arr b1 b2 = readSTRef arr >>=
+ (\graph ->
+ return .
+ fromMaybe (error "getFreq 1") .
+ IM.lookup b2 .
+ fromMaybe (error "getFreq 2") $
+ (IM.lookup b1 graph)
+ )
+ setProb' arr b1 b2 prob = do
+ g <- readSTRef arr
+ let !m = fromMaybe (error "Foo") $ IM.lookup b1 g
+ !m' = IM.insert b2 prob m
+ writeSTRef arr $! (IM.insert b1 m' g)
+
+ getEdgeFreq b1 b2 = getProb' edgeProbs b1 b2
+ setEdgeFreq b1 b2 = setProb' edgeProbs b1 b2
+ getProb b1 b2 = fromMaybe (error "getProb") $ do
+ m' <- IM.lookup b1 graph
+ IM.lookup b2 m'
+
+ getBackProb b1 b2 = getProb' edgeBackProbs b1 b2
+ setBackProb b1 b2 = setProb' edgeBackProbs b1 b2
+
+
+ let -- calcOutFreqs :: Node -> ST s ()
+ calcOutFreqs bhead block = do
+ !f <- getFreq block
+ forM (successors block) $ \bi -> do
+ let !prob = getProb block bi
+ let !succFreq = f * prob
+ setEdgeFreq block bi succFreq
+ -- traceM $ "SetOut: " ++ show (block, bi, f, prob, succFreq)
+ when (bi == bhead) $ setBackProb block bi succFreq
+
+
+ let propFreq block head = do
+ -- traceM ("prop:" ++ show (block,head))
+ -- traceShowM block
+
+ !v <- visited block
+ if v then
+ return () --Dont look at nodes twice
+ else if block == head then
+ setFreq block 1.0 -- Loop header frequency is always 1
+ else do
+ let preds = IS.elems $ predecessors block
+ irreducible <- (fmap or) $ forM preds $ \bp -> do
+ !bp_visited <- visited bp
+ let bp_backedge = isBackEdge bp block
+ return (not bp_visited && not bp_backedge)
+
+ if irreducible
+ then return () -- Rare we don't care
+ else do
+ setFreq block 0
+ !cycleProb <- sum <$> (forM preds $ \pred -> do
+ if isBackEdge pred block
+ then
+ getBackProb pred block
+ else do
+ !f <- getFreq block
+ !prob <- getEdgeFreq pred block
+ setFreq block $! f + prob
+ return 0)
+ -- traceM $ "cycleProb:" ++ show cycleProb
+ let limit = 1 - 1/512 -- Paper uses 1 - epsilon, but this works.
+ -- determines how large likelyhoods in loops can grow.
+ !cycleProb <- return $ min cycleProb limit -- <- return $ if cycleProb > limit then limit else cycleProb
+ -- traceM $ "cycleProb:" ++ show cycleProb
+
+ !f <- getFreq block
+ setFreq block (f / (1.0 - cycleProb))
+
+ setVisited block
+ calcOutFreqs head block
+
+ -- Loops, by nesting, inner to outer
+ forM_ loops $ \(head, body) -> do
+ forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i True) -- Mark all nodes as visited.
+ forM_ body (\i -> unsafeWrite visitedNodes i False) -- Mark all blocks reachable from head as not visited
+ forM_ body $ \block -> propFreq block head
+
+ -- After dealing with all loops, deal with non-looping parts of the CFG
+ forM_ [0 .. nodeCount - 1] (\i -> unsafeWrite visitedNodes i False) -- Everything in revPostOrder is reachable
+ forM_ revPostOrder $ \block -> propFreq block (head revPostOrder)
+
+ -- trace ("Final freqs:") $ return ()
+ -- let freqString = pprFreqs freqs
+ -- trace (unlines freqString) $ return ()
+ -- trace (pprFre) $ return ()
+ graph' <- readSTRef edgeProbs
+ freqs' <- unsafeFreeze blockFreqs
+
+ return (freqs', graph')
+ where
+ -- How can these lookups fail? Consider the CFG [A -> B]
+ predecessors :: Int -> IS.IntSet
+ predecessors b = fromMaybe IS.empty $ IM.lookup b revGraph
+ successors :: Int -> [Int]
+ successors b = fromMaybe (lookupError "succ" b graph)$ IM.keys <$> IM.lookup b graph
+ lookupError s b g = pprPanic ("Lookup error " ++ s) $
+ ( text "node" <+> ppr b $$
+ text "graph" <+>
+ vcat (map (\(k,m) -> ppr (k,m :: IM.IntMap Double)) $ IM.toList g)
+ )
+
+ nodeCount = IM.foldl' (\count toMap -> IM.foldlWithKey' countTargets count toMap) (IM.size graph) graph
+ where
+ countTargets = (\count k _ -> countNode k + count )
+ countNode n = if IM.member n graph then 0 else 1
+
+ isBackEdge from to = S.member (from,to) backEdgeSet
+ backEdgeSet = S.fromList backEdges
+
+ revGraph :: IntMap IntSet
+ revGraph = IM.foldlWithKey' (\m from toMap -> addEdges m from toMap) IM.empty graph
+ where
+ addEdges m0 from toMap = IM.foldlWithKey' (\m k _ -> addEdge m from k) m0 toMap
+ addEdge m0 from to = IM.insertWith IS.union to (IS.singleton from) m0
diff --git a/compiler/GHC/CmmToAsm/CFG/Dominators.hs b/compiler/GHC/CmmToAsm/CFG/Dominators.hs
new file mode 100644
index 0000000..bb28e87
--- /dev/null
+++ b/compiler/GHC/CmmToAsm/CFG/Dominators.hs
@@ -0,0 +1,597 @@
+{-# LANGUAGE RankNTypes, BangPatterns, FlexibleContexts, Strict #-}
+
+{- |
+ Module : Dominators
+ Copyright : (c) Matt Morrow 2009
+ License : BSD3
+ Maintainer : <morrow@moonpatio.com>
+ Stability : experimental
+ Portability : portable
+
+ Taken from the dom-lt package.
+
+ The Lengauer-Tarjan graph dominators algorithm.
+
+ \[1\] Lengauer, Tarjan,
+ /A Fast Algorithm for Finding Dominators in a Flowgraph/, 1979.
+
+ \[2\] Muchnick,
+ /Advanced Compiler Design and Implementation/, 1997.
+
+ \[3\] Brisk, Sarrafzadeh,
+ /Interference Graphs for Procedures in Static Single/
+ /Information Form are Interval Graphs/, 2007.
+
+ Originally taken from the dom-lt package.
+-}
+
+module GHC.CmmToAsm.CFG.Dominators (
+ Node,Path,Edge
+ ,Graph,Rooted
+ ,idom,ipdom
+ ,domTree,pdomTree
+ ,dom,pdom
+ ,pddfs,rpddfs
+ ,fromAdj,fromEdges
+ ,toAdj,toEdges
+ ,asTree,asGraph
+ ,parents,ancestors
+) where
+
+import GHC.Prelude
+
+import Data.Bifunctor
+import Data.Tuple (swap)
+
+import Data.Tree
+import Data.IntMap(IntMap)
+import Data.IntSet(IntSet)
+import qualified Data.IntMap.Strict as IM
+import qualified Data.IntSet as IS
+
+import Control.Monad
+import Control.Monad.ST.Strict
+
+import Data.Array.ST
+import Data.Array.Base hiding ((!))
+ -- (unsafeNewArray_
+ -- ,unsafeWrite,unsafeRead
+ -- ,readArray,writeArray)
+
+import GHC.Utils.Misc (debugIsOn)
+
+-----------------------------------------------------------------------------
+
+type Node = Int
+type Path = [Node]
+type Edge = (Node,Node)
+type Graph = IntMap IntSet
+type Rooted = (Node, Graph)
+
+-----------------------------------------------------------------------------
+
+-- | /Dominators/.
+-- Complexity as for @idom@
+dom :: Rooted -> [(Node, Path)]
+dom = ancestors . domTree
+
+-- | /Post-dominators/.
+-- Complexity as for @idom@.
+pdom :: Rooted -> [(Node, Path)]
+pdom = ancestors . pdomTree
+
+-- | /Dominator tree/.
+-- Complexity as for @idom@.
+domTree :: Rooted -> Tree Node
+domTree a@(r,_) =
+ let is = filter ((/=r).fst) (idom a)
+ tg = fromEdges (fmap swap is)
+ in asTree (r,tg)
+
+-- | /Post-dominator tree/.
+-- Complexity as for @idom@.
+pdomTree :: Rooted -> Tree Node
+pdomTree a@(r,_) =
+ let is = filter ((/=r).fst) (ipdom a)
+ tg = fromEdges (fmap swap is)
+ in asTree (r,tg)
+
+-- | /Immediate dominators/.
+-- /O(|E|*alpha(|E|,|V|))/, where /alpha(m,n)/ is
+-- \"a functional inverse of Ackermann's function\".
+--
+-- This Complexity bound assumes /O(1)/ indexing. Since we're
+-- using @IntMap@, it has an additional /lg |V|/ factor
+-- somewhere in there. I'm not sure where.
+idom :: Rooted -> [(Node,Node)]
+idom rg = runST (evalS idomM =<< initEnv (pruneReach rg))
+
+-- | /Immediate post-dominators/.
+-- Complexity as for @idom@.
+ipdom :: Rooted -> [(Node,Node)]
+ipdom rg = runST (evalS idomM =<< initEnv (pruneReach (second predG rg)))
+
+-----------------------------------------------------------------------------
+
+-- | /Post-dominated depth-first search/.
+pddfs :: Rooted -> [Node]
+pddfs = reverse . rpddfs
+
+-- | /Reverse post-dominated depth-first search/.
+rpddfs :: Rooted -> [Node]
+rpddfs = concat . levels . pdomTree
+
+-----------------------------------------------------------------------------
+
+type Dom s a = S s (Env s) a
+type NodeSet = IntSet
+type NodeMap a = IntMap a
+data Env s = Env
+ {succE :: !Graph
+ ,predE :: !Graph
+ ,bucketE :: !Graph
+ ,dfsE :: {-# UNPACK #-}!Int
+ ,zeroE :: {-# UNPACK #-}!Node
+ ,rootE :: {-# UNPACK #-}!Node
+ ,labelE :: {-# UNPACK #-}!(Arr s Node)
+ ,parentE :: {-# UNPACK #-}!(Arr s Node)
+ ,ancestorE :: {-# UNPACK #-}!(Arr s Node)
+ ,childE :: {-# UNPACK #-}!(Arr s Node)
+ ,ndfsE :: {-# UNPACK #-}!(Arr s Node)
+ ,dfnE :: {-# UNPACK #-}!(Arr s Int)
+ ,sdnoE :: {-# UNPACK #-}!(Arr s Int)
+ ,sizeE :: {-# UNPACK #-}!(Arr s Int)
+ ,domE :: {-# UNPACK #-}!(Arr s Node)
+ ,rnE :: {-# UNPACK #-}!(Arr s Node)}
+
+-----------------------------------------------------------------------------
+
+idomM :: Dom s [(Node,Node)]
+idomM = do
+ dfsDom =<< rootM
+ n <- gets dfsE
+ forM_ [n,n-1..1] (\i-> do
+ w <- ndfsM i
+ sw <- sdnoM w
+ ps <- predsM w
+ forM_ ps (\v-> do
+ u <- eval v
+ su <- sdnoM u
+ when (su < sw)
+ (store sdnoE w su))
+ z <- ndfsM =<< sdnoM w
+ modify(\e->e{bucketE=IM.adjust
+ (w`IS.insert`)
+ z (bucketE e)})
+ pw <- parentM w
+ link pw w
+ bps <- bucketM pw
+ forM_ bps (\v-> do
+ u <- eval v
+ su <- sdnoM u
+ sv <- sdnoM v
+ let dv = case su < sv of
+ True-> u
+ False-> pw
+ store domE v dv))
+ forM_ [1..n] (\i-> do
+ w <- ndfsM i
+ j <- sdnoM w
+ z <- ndfsM j
+ dw <- domM w
+ when (dw /= z)
+ (do ddw <- domM dw
+ store domE w ddw))
+ fromEnv
+
+-----------------------------------------------------------------------------
+
+eval :: Node -> Dom s Node
+eval v = do
+ n0 <- zeroM
+ a <- ancestorM v
+ case a==n0 of
+ True-> labelM v
+ False-> do
+ compress v
+ a <- ancestorM v
+ l <- labelM v
+ la <- labelM a
+ sl <- sdnoM l
+ sla <- sdnoM la
+ case sl <= sla of
+ True-> return l
+ False-> return la
+
+compress :: Node -> Dom s ()
+compress v = do
+ n0 <- zeroM
+ a <- ancestorM v
+ aa <- ancestorM a
+ when (aa /= n0) (do
+ compress a
+ a <- ancestorM v
+ aa <- ancestorM a
+ l <- labelM v
+ la <- labelM a
+ sl <- sdnoM l
+ sla <- sdnoM la
+ when (sla < sl)
+ (store labelE v la)
+ store ancestorE v aa)
+
+-----------------------------------------------------------------------------
+
+link :: Node -> Node -> Dom s ()
+link v w = do
+ n0 <- zeroM
+ lw <- labelM w
+ slw <- sdnoM lw
+ let balance s = do
+ c <- childM s
+ lc <- labelM c
+ slc <- sdnoM lc
+ case slw < slc of
+ False-> return s
+ True-> do
+ zs <- sizeM s
+ zc <- sizeM c
+ cc <- childM c
+ zcc <- sizeM cc
+ case 2*zc <= zs+zcc of
+ True-> do
+ store ancestorE c s
+ store childE s cc
+ balance s
+ False-> do
+ store sizeE c zs
+ store ancestorE s c
+ balance c
+ s <- balance w
+ lw <- labelM w
+ zw <- sizeM w
+ store labelE s lw
+ store sizeE v . (+zw) =<< sizeM v
+ let follow s = do
+ when (s /= n0) (do
+ store ancestorE s v
+ follow =<< childM s)
+ zv <- sizeM v
+ follow =<< case zv < 2*zw of
+ False-> return s
+ True-> do
+ cv <- childM v
+ store childE v s
+ return cv
+
+-----------------------------------------------------------------------------
+
+dfsDom :: Node -> Dom s ()
+dfsDom i = do
+ _ <- go i
+ n0 <- zeroM
+ r <- rootM
+ store parentE r n0
+ where go i = do
+ n <- nextM
+ store dfnE i n
+ store sdnoE i n
+ store ndfsE n i
+ store labelE i i
+ ss <- succsM i
+ forM_ ss (\j-> do
+ s <- sdnoM j
+ case s==0 of
+ False-> return()
+ True-> do
+ store parentE j i
+ go j)
+
+-----------------------------------------------------------------------------
+
+initEnv :: Rooted -> ST s (Env s)
+initEnv (r0,g0) = do
+ let (g,rnmap) = renum 1 g0
+ pred = predG g
+ r = rnmap IM.! r0
+ n = IM.size g
+ ns = [0..n]
+ m = n+1
+
+ let bucket = IM.fromList
+ (zip ns (repeat mempty))
+
+ rna <- newI m
+ writes rna (fmap swap
+ (IM.toList rnmap))
+
+ doms <- newI m
+ sdno <- newI m
+ size <- newI m
+ parent <- newI m
+ ancestor <- newI m
+ child <- newI m
+ label <- newI m
+ ndfs <- newI m
+ dfn <- newI m
+
+ forM_ [0..n] (doms.=0)
+ forM_ [0..n] (sdno.=0)
+ forM_ [1..n] (size.=1)
+ forM_ [0..n] (ancestor.=0)
+ forM_ [0..n] (child.=0)
+
+ (doms.=r) r
+ (size.=0) 0
+ (label.=0) 0
+
+ return (Env
+ {rnE = rna
+ ,dfsE = 0
+ ,zeroE = 0
+ ,rootE = r
+ ,labelE = label
+ ,parentE = parent
+ ,ancestorE = ancestor
+ ,childE = child
+ ,ndfsE = ndfs
+ ,dfnE = dfn
+ ,sdnoE = sdno
+ ,sizeE = size
+ ,succE = g
+ ,predE = pred
+ ,bucketE = bucket
+ ,domE = doms})
+
+fromEnv :: Dom s [(Node,Node)]
+fromEnv = do
+ dom <- gets domE
+ rn <- gets rnE
+ -- r <- gets rootE
+ (_,n) <- st (getBounds dom)
+ forM [1..n] (\i-> do
+ j <- st(rn!:i)
+ d <- st(dom!:i)
+ k <- st(rn!:d)
+ return (j,k))
+
+-----------------------------------------------------------------------------
+
+zeroM :: Dom s Node
+zeroM = gets zeroE
+domM :: Node -> Dom s Node
+domM = fetch domE
+rootM :: Dom s Node
+rootM = gets rootE
+succsM :: Node -> Dom s [Node]
+succsM i = gets (IS.toList . (! i) . succE)
+predsM :: Node -> Dom s [Node]
+predsM i = gets (IS.toList . (! i) . predE)
+bucketM :: Node -> Dom s [Node]
+bucketM i = gets (IS.toList . (! i) . bucketE)
+sizeM :: Node -> Dom s Int
+sizeM = fetch sizeE
+sdnoM :: Node -> Dom s Int
+sdnoM = fetch sdnoE
+-- dfnM :: Node -> Dom s Int
+-- dfnM = fetch dfnE
+ndfsM :: Int -> Dom s Node
+ndfsM = fetch ndfsE
+childM :: Node -> Dom s Node
+childM = fetch childE
+ancestorM :: Node -> Dom s Node
+ancestorM = fetch ancestorE
+parentM :: Node -> Dom s Node
+parentM = fetch parentE
+labelM :: Node -> Dom s Node
+labelM = fetch labelE
+nextM :: Dom s Int
+nextM = do
+ n <- gets dfsE
+ let n' = n+1
+ modify(\e->e{dfsE=n'})
+ return n'
+
+-----------------------------------------------------------------------------
+
+type A = STUArray
+type Arr s a = A s Int a
+
+infixl 9 !:
+infixr 2 .=
+
+(.=) :: (MArray (A s) a (ST s))
+ => Arr s a -> a -> Int -> ST s ()
+(v .= x) i
+ | debugIsOn = writeArray v i x
+ | otherwise = unsafeWrite v i x
+
+(!:) :: (MArray (A s) a (ST s))
+ => A s Int a -> Int -> ST s a
+a !: i
+ | debugIsOn = do
+ o <- readArray a i
+ return $! o
+ | otherwise = do
+ o <- unsafeRead a i
+ return $! o
+
+new :: (MArray (A s) a (ST s))
+ => Int -> ST s (Arr s a)
+new n = unsafeNewArray_ (0,n-1)
+
+newI :: Int -> ST s (Arr s Int)
+newI = new
+
+-- newD :: Int -> ST s (Arr s Double)
+-- newD = new
+
+-- dump :: (MArray (A s) a (ST s)) => Arr s a -> ST s [a]
+-- dump a = do
+-- (m,n) <- getBounds a
+-- forM [m..n] (\i -> a!:i)
+
+writes :: (MArray (A s) a (ST s))
+ => Arr s a -> [(Int,a)] -> ST s ()
+writes a xs = forM_ xs (\(i,x) -> (a.=x) i)
+
+-- arr :: (MArray (A s) a (ST s)) => [a] -> ST s (Arr s a)
+-- arr xs = do
+-- let n = length xs
+-- a <- new n
+-- go a n 0 xs
+-- return a
+-- where go _ _ _ [] = return ()
+-- go a n i (x:xs)
+-- | i <= n = (a.=x) i >> go a n (i+1) xs
+-- | otherwise = return ()
+
+-----------------------------------------------------------------------------
+
+(!) :: Monoid a => IntMap a -> Int -> a
+(!) g n = maybe mempty id (IM.lookup n g)
+
+fromAdj :: [(Node, [Node])] -> Graph
+fromAdj = IM.fromList . fmap (second IS.fromList)
+
+fromEdges :: [Edge] -> Graph
+fromEdges = collectI IS.union fst (IS.singleton . snd)
+
+toAdj :: Graph -> [(Node, [Node])]
+toAdj = fmap (second IS.toList) . IM.toList
+
+toEdges :: Graph -> [Edge]
+toEdges = concatMap (uncurry (fmap . (,))) . toAdj
+
+predG :: Graph -> Graph
+predG g = IM.unionWith IS.union (go g) g0
+ where g0 = fmap (const mempty) g
+ f :: IntMap IntSet -> Int -> IntSet -> IntMap IntSet
+ f m i a = foldl' (\m p -> IM.insertWith mappend p
+ (IS.singleton i) m)
+ m
+ (IS.toList a)
+ go :: IntMap IntSet -> IntMap IntSet
+ go = flip IM.foldlWithKey' mempty f
+
+pruneReach :: Rooted -> Rooted
+pruneReach (r,g) = (r,g2)
+ where is = reachable
+ (maybe mempty id
+ . flip IM.lookup g) $ r
+ g2 = IM.fromList
+ . fmap (second (IS.filter (`IS.member`is)))
+ . filter ((`IS.member`is) . fst)
+ . IM.toList $ g
+
+tip :: Tree a -> (a, [Tree a])
+tip (Node a ts) = (a, ts)
+
+parents :: Tree a -> [(a, a)]
+parents (Node i xs) = p i xs
+ ++ concatMap parents xs
+ where p i = fmap (flip (,) i . rootLabel)
+
+ancestors :: Tree a -> [(a, [a])]
+ancestors = go []
+ where go acc (Node i xs)
+ = let acc' = i:acc
+ in p acc' xs ++ concatMap (go acc') xs
+ p is = fmap (flip (,) is . rootLabel)
+
+asGraph :: Tree Node -> Rooted
+asGraph t@(Node a _) = let g = go t in (a, fromAdj g)
+ where go (Node a ts) = let as = (fst . unzip . fmap tip) ts
+ in (a, as) : concatMap go ts
+
+asTree :: Rooted -> Tree Node
+asTree (r,g) = let go a = Node a (fmap go ((IS.toList . f) a))
+ f = (g !)
+ in go r
+
+reachable :: (Node -> NodeSet) -> (Node -> NodeSet)
+reachable f a = go (IS.singleton a) a
+ where go seen a = let s = f a
+ as = IS.toList (s `IS.difference` seen)
+ in foldl' go (s `IS.union` seen) as
+
+collectI :: (c -> c -> c)
+ -> (a -> Int) -> (a -> c) -> [a] -> IntMap c
+collectI (<>) f g
+ = foldl' (\m a -> IM.insertWith (<>)
+ (f a)
+ (g a) m) mempty
+
+-- collect :: (Ord b) => (c -> c -> c)
+-- -> (a -> b) -> (a -> c) -> [a] -> Map b c
+-- collect (<>) f g
+-- = foldl' (\m a -> SM.insertWith (<>)
+-- (f a)
+-- (g a) m) mempty
+
+-- (renamed, old -> new)
+renum :: Int -> Graph -> (Graph, NodeMap Node)
+renum from = (\(_,m,g)->(g,m))
+ . IM.foldlWithKey'
+ f (from,mempty,mempty)
+ where
+ f :: (Int, NodeMap Node, IntMap IntSet) -> Node -> IntSet
+ -> (Int, NodeMap Node, IntMap IntSet)
+ f (!n,!env,!new) i ss =
+ let (j,n2,env2) = go n env i
+ (n3,env3,ss2) = IS.fold
+ (\k (!n,!env,!new)->
+ case go n env k of
+ (l,n2,env2)-> (n2,env2,l `IS.insert` new))
+ (n2,env2,mempty) ss
+ new2 = IM.insertWith IS.union j ss2 new
+ in (n3,env3,new2)
+ go :: Int
+ -> NodeMap Node
+ -> Node
+ -> (Node,Int,NodeMap Node)
+ go !n !env i =
+ case IM.lookup i env of
+ Just j -> (j,n,env)
+ Nothing -> (n,n+1,IM.insert i n env)
+
+-----------------------------------------------------------------------------
+
+newtype S z s a = S {unS :: forall o. (a -> s -> ST z o) -> s -> ST z o}
+instance Functor (S z s) where
+ fmap f (S g) = S (\k -> g (k . f))
+instance Monad (S z s) where
+ return = pure
+ S g >>= f = S (\k -> g (\a -> unS (f a) k))
+instance Applicative (S z s) where
+ pure a = S (\k -> k a)
+ (<*>) = ap
+-- get :: S z s s
+-- get = S (\k s -> k s s)
+gets :: (s -> a) -> S z s a
+gets f = S (\k s -> k (f s) s)
+-- set :: s -> S z s ()
+-- set s = S (\k _ -> k () s)
+modify :: (s -> s) -> S z s ()
+modify f = S (\k -> k () . f)
+-- runS :: S z s a -> s -> ST z (a, s)
+-- runS (S g) = g (\a s -> return (a,s))
+evalS :: S z s a -> s -> ST z a
+evalS (S g) = g ((return .) . const)
+-- execS :: S z s a -> s -> ST z s
+-- execS (S g) = g ((return .) . flip const)
+st :: ST z a -> S z s a
+st m = S (\k s-> do
+ a <- m
+ k a s)
+store :: (MArray (A z) a (ST z))
+ => (s -> Arr z a) -> Int -> a -> S z s ()
+store f i x = do
+ a <- gets f
+ st ((a.=x) i)
+fetch :: (MArray (A z) a (ST z))
+ => (s -> Arr z a) -> Int -> S z s a
+fetch f i = do
+ a <- gets f
+ st (a!:i)
+
diff --git a/compiler/nativeGen/CPrim.hs b/compiler/GHC/CmmToAsm/CPrim.hs
index 399d646..826a6e2 100644
--- a/compiler/nativeGen/CPrim.hs
+++ b/compiler/GHC/CmmToAsm/CPrim.hs
@@ -1,23 +1,25 @@
-- | Generating C symbol names emitted by the compiler.
-module CPrim
+module GHC.CmmToAsm.CPrim
( atomicReadLabel
, atomicWriteLabel
, atomicRMWLabel
, cmpxchgLabel
+ , xchgLabel
, popCntLabel
, pdepLabel
, pextLabel
, bSwapLabel
+ , bRevLabel
, clzLabel
, ctzLabel
, word2FloatLabel
) where
-import GhcPrelude
+import GHC.Prelude
-import CmmType
-import CmmMachOp
-import Outputable
+import GHC.Cmm.Type
+import GHC.Cmm.MachOp
+import GHC.Utils.Outputable
popCntLabel :: Width -> String
popCntLabel w = "hs_popcnt" ++ pprWidth w
@@ -54,6 +56,15 @@ bSwapLabel w = "hs_bswap" ++ pprWidth w
pprWidth W64 = "64"
pprWidth w = pprPanic "bSwapLabel: Unsupported word width " (ppr w)
+bRevLabel :: Width -> String
+bRevLabel w = "hs_bitrev" ++ pprWidth w
+ where
+ pprWidth W8 = "8"
+ pprWidth W16 = "16"
+ pprWidth W32 = "32"
+ pprWidth W64 = "64"
+ pprWidth w = pprPanic "bRevLabel: Unsupported word width " (ppr w)
+
clzLabel :: Width -> String
clzLabel w = "hs_clz" ++ pprWidth w
where
@@ -95,6 +106,15 @@ atomicRMWLabel w amop = "hs_atomic_" ++ pprFunName amop ++ pprWidth w
pprFunName AMO_Or = "or"
pprFunName AMO_Xor = "xor"
+xchgLabel :: Width -> String
+xchgLabel w = "hs_xchg" ++ pprWidth w
+ where
+ pprWidth W8 = "8"
+ pprWidth W16 = "16"
+ pprWidth W32 = "32"
+ pprWidth W64 = "64"
+ pprWidth w = pprPanic "xchgLabel: Unsupported word width " (ppr w)
+
cmpxchgLabel :: Width -> String
cmpxchgLabel w = "hs_cmpxchg" ++ pprWidth w
where
diff --git a/compiler/nativeGen/Dwarf.hs b/compiler/GHC/CmmToAsm/Dwarf.hs
index 0e645a2..c0da697 100644
--- a/compiler/nativeGen/Dwarf.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf.hs
@@ -1,23 +1,23 @@
-module Dwarf (
+module GHC.CmmToAsm.Dwarf (
dwarfGen
) where
-import GhcPrelude
+import GHC.Prelude
-import CLabel
-import CmmExpr ( GlobalReg(..) )
-import Config ( cProjectName, cProjectVersion )
-import CoreSyn ( Tickish(..) )
-import Debug
-import DynFlags
-import Module
-import Outputable
-import Platform
-import Unique
-import UniqSupply
+import GHC.Cmm.CLabel
+import GHC.Cmm.Expr ( GlobalReg(..) )
+import GHC.Settings.Config ( cProjectName, cProjectVersion )
+import GHC.Core ( Tickish(..) )
+import GHC.Cmm.DebugBlock
+import GHC.Driver.Session
+import GHC.Unit.Module
+import GHC.Utils.Outputable
+import GHC.Platform
+import GHC.Types.Unique
+import GHC.Types.Unique.Supply
-import Dwarf.Constants
-import Dwarf.Types
+import GHC.CmmToAsm.Dwarf.Constants
+import GHC.CmmToAsm.Dwarf.Types
import Control.Arrow ( first )
import Control.Monad ( mfilter )
@@ -28,14 +28,15 @@ import qualified Data.Map as Map
import System.FilePath
import System.Directory ( getCurrentDirectory )
-import qualified Hoopl.Label as H
-import qualified Hoopl.Collections as H
+import qualified GHC.Cmm.Dataflow.Label as H
+import qualified GHC.Cmm.Dataflow.Collections as H
-- | Generate DWARF/debug information
dwarfGen :: DynFlags -> ModLocation -> UniqSupply -> [DebugBlock]
-> IO (SDoc, UniqSupply)
dwarfGen _ _ us [] = return (empty, us)
dwarfGen df modLoc us blocks = do
+ let platform = targetPlatform df
-- Convert debug data structures to DWARF info records
-- We strip out block information when running with -g0 or -g1.
@@ -64,33 +65,33 @@ dwarfGen df modLoc us blocks = do
haveSrc = any haveSrcIn procs
-- .debug_abbrev section: Declare the format we're using
- let abbrevSct = pprAbbrevDecls haveSrc
+ let abbrevSct = pprAbbrevDecls platform haveSrc
-- .debug_info section: Information records on procedures and blocks
let -- unique to identify start and end compilation unit .debug_inf
(unitU, us') = takeUniqFromSupply us
infoSct = vcat [ ptext dwarfInfoLabel <> colon
- , dwarfInfoSection
- , compileUnitHeader unitU
- , pprDwarfInfo haveSrc dwarfUnit
+ , dwarfInfoSection platform
+ , compileUnitHeader platform unitU
+ , pprDwarfInfo platform haveSrc dwarfUnit
, compileUnitFooter unitU
]
-- .debug_line section: Generated mainly by the assembler, but we
-- need to label it
- let lineSct = dwarfLineSection $$
+ let lineSct = dwarfLineSection platform $$
ptext dwarfLineLabel <> colon
-- .debug_frame section: Information about the layout of the GHC stack
let (framesU, us'') = takeUniqFromSupply us'
- frameSct = dwarfFrameSection $$
+ frameSct = dwarfFrameSection platform $$
ptext dwarfFrameLabel <> colon $$
- pprDwarfFrame (debugFrame framesU procs)
+ pprDwarfFrame platform (debugFrame framesU procs)
-- .aranges section: Information about the bounds of compilation units
let aranges' | gopt Opt_SplitSections df = map mkDwarfARange procs
| otherwise = [DwarfARange lowLabel highLabel]
- let aranges = dwarfARangesSection $$ pprDwarfARanges aranges' unitU
+ let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU
return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')
@@ -106,17 +107,17 @@ mkDwarfARange proc = DwarfARange start end
-- | Header for a compilation unit, establishing global format
-- parameters
-compileUnitHeader :: Unique -> SDoc
-compileUnitHeader unitU = sdocWithPlatform $ \plat ->
+compileUnitHeader :: Platform -> Unique -> SDoc
+compileUnitHeader platform unitU =
let cuLabel = mkAsmTempLabel unitU -- sits right before initialLength field
length = ppr (mkAsmTempEndLabel cuLabel) <> char '-' <> ppr cuLabel
<> text "-4" -- length of initialLength field
in vcat [ ppr cuLabel <> colon
, text "\t.long " <> length -- compilation unit size
, pprHalf 3 -- DWARF version
- , sectionOffset (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
+ , sectionOffset platform (ptext dwarfAbbrevLabel) (ptext dwarfAbbrevLabel)
-- abbrevs offset
- , text "\t.byte " <> ppr (platformWordSize plat) -- word size
+ , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size
]
-- | Compilation unit footer, mainly establishing size of debug sections
@@ -176,7 +177,7 @@ parent, B.
-- | Generate DWARF info for a procedure debug block
procToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
procToDwarf df prc
- = DwarfSubprogram { dwChildren = map (blockToDwarf df) (dblBlocks prc)
+ = DwarfSubprogram { dwChildren = map blockToDwarf (dblBlocks prc)
, dwName = case dblSourceTick prc of
Just s@SourceNote{} -> sourceName s
_otherwise -> showSDocDump df $ ppr $ dblLabel prc
@@ -195,10 +196,10 @@ procToDwarf df prc
goodParent _ = True
-- | Generate DWARF info for a block
-blockToDwarf :: DynFlags -> DebugBlock -> DwarfInfo
-blockToDwarf df blk
- = DwarfBlock { dwChildren = concatMap (tickToDwarf df) (dblTicks blk)
- ++ map (blockToDwarf df) (dblBlocks blk)
+blockToDwarf :: DebugBlock -> DwarfInfo
+blockToDwarf blk
+ = DwarfBlock { dwChildren = concatMap tickToDwarf (dblTicks blk)
+ ++ map blockToDwarf (dblBlocks blk)
, dwLabel = dblCLabel blk
, dwMarker = marker
}
@@ -207,9 +208,9 @@ blockToDwarf df blk
| Just _ <- dblPosition blk = Just $ mkAsmTempLabel $ dblLabel blk
| otherwise = Nothing -- block was optimized out
-tickToDwarf :: DynFlags -> Tickish () -> [DwarfInfo]
-tickToDwarf _ (SourceNote ss _) = [DwarfSrcNote ss]
-tickToDwarf _ _ = []
+tickToDwarf :: Tickish () -> [DwarfInfo]
+tickToDwarf (SourceNote ss _) = [DwarfSrcNote ss]
+tickToDwarf _ = []
-- | Generates the data for the debug frame section, which encodes the
-- desired stack unwind behaviour for the debugger
@@ -245,7 +246,7 @@ procToFrame initUws blk
-- | If the current procedure has an info table, then we also say that
-- its first block has one to ensure that it gets the necessary -1
-- offset applied to its start address.
- -- See Note [Info Offset] in Dwarf.Types.
+ -- See Note [Info Offset] in "GHC.CmmToAsm.Dwarf.Types".
setHasInfo :: [(DebugBlock, [UnwindPoint])]
-> [(DebugBlock, [UnwindPoint])]
setHasInfo [] = []
diff --git a/compiler/nativeGen/Dwarf/Constants.hs b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
index 687a4f8..67137e1 100644
--- a/compiler/nativeGen/Dwarf/Constants.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf/Constants.hs
@@ -1,17 +1,18 @@
-- | Constants describing the DWARF format. Most of this simply
--- mirrors /usr/include/dwarf.h.
+-- mirrors \/usr\/include\/dwarf.h.
-module Dwarf.Constants where
+module GHC.CmmToAsm.Dwarf.Constants where
-import GhcPrelude
+import GHC.Prelude
-import AsmUtils
-import FastString
-import Platform
-import Outputable
+import GHC.Utils.Asm
+import GHC.Data.FastString
+import GHC.Platform
+import GHC.Utils.Outputable
-import Reg
-import X86.Regs
+import GHC.Platform.Reg
+import GHC.CmmToAsm.X86.Regs
+import GHC.CmmToAsm.PPC.Regs (toRegNo)
import Data.Word
@@ -144,20 +145,20 @@ dW_OP_call_frame_cfa = 0x9c
-- * Dwarf section declarations
dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,
- dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: SDoc
-dwarfInfoSection = dwarfSection "info"
-dwarfAbbrevSection = dwarfSection "abbrev"
-dwarfLineSection = dwarfSection "line"
-dwarfFrameSection = dwarfSection "frame"
-dwarfGhcSection = dwarfSection "ghc"
-dwarfARangesSection = dwarfSection "aranges"
-
-dwarfSection :: String -> SDoc
-dwarfSection name = sdocWithPlatform $ \plat ->
- case platformOS plat of
+ dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc
+dwarfInfoSection platform = dwarfSection platform "info"
+dwarfAbbrevSection platform = dwarfSection platform "abbrev"
+dwarfLineSection platform = dwarfSection platform "line"
+dwarfFrameSection platform = dwarfSection platform "frame"
+dwarfGhcSection platform = dwarfSection platform "ghc"
+dwarfARangesSection platform = dwarfSection platform "aranges"
+
+dwarfSection :: Platform -> String -> SDoc
+dwarfSection platform name =
+ case platformOS platform of
os | osElfTarget os
-> text "\t.section .debug_" <> text name <> text ",\"\","
- <> sectionType "progbits"
+ <> sectionType platform "progbits"
| osMachOTarget os
-> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"
| otherwise
@@ -215,6 +216,7 @@ dwarfRegNo p r = case platformArch p of
| r == xmm13 -> 30
| r == xmm14 -> 31
| r == xmm15 -> 32
+ ArchPPC_64 _ -> fromIntegral $ toRegNo r
_other -> error "dwarfRegNo: Unsupported platform or unknown register!"
-- | Virtual register number to use for return address.
@@ -226,4 +228,5 @@ dwarfReturnRegNo p
= case platformArch p of
ArchX86 -> 8 -- eip
ArchX86_64 -> 16 -- rip
+ ArchPPC_64 ELF_V2 -> 65 -- lr (link register)
_other -> error "dwarfReturnRegNo: Unsupported platform!"
diff --git a/compiler/nativeGen/Dwarf/Types.hs b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
index 71eee55..8efdbab 100644
--- a/compiler/nativeGen/Dwarf/Types.hs
+++ b/compiler/GHC/CmmToAsm/Dwarf/Types.hs
@@ -1,4 +1,4 @@
-module Dwarf.Types
+module GHC.CmmToAsm.Dwarf.Types
( -- * Dwarf information
DwarfInfo(..)
, pprDwarfInfo
@@ -22,22 +22,23 @@ module Dwarf.Types
)
where
-import GhcPrelude
+import GHC.Prelude
-import Debug
-import CLabel
-import CmmExpr ( GlobalReg(..) )
-import Encoding
-import FastString
-import Outputable
-import Platform
-import Unique
-import Reg
-import SrcLoc
-import Util
+import GHC.Cmm.DebugBlock
+import GHC.Cmm.CLabel
+import GHC.Cmm.Expr ( GlobalReg(..) )
+import GHC.Utils.Encoding
+import GHC.Data.FastString
+import GHC.Utils.Outputable
+import GHC.Platform
+import GHC.Types.Unique
+import GHC.Platform.Reg
+import GHC.Types.SrcLoc
+import GHC.Utils.Misc
-import Dwarf.Constants
+import GHC.CmmToAsm.Dwarf.Constants
+import qualified Data.ByteString as BS
import qualified Control.Monad.Trans.State.Strict as S
import Control.Monad (zipWithM, join)
import Data.Bits
@@ -45,7 +46,7 @@ import qualified Data.Map as Map
import Data.Word
import Data.Char
-import CodeGen.Platform
+import GHC.Platform.Regs
-- | Individual dwarf records. Each one will be encoded as an entry in
-- the @.debug_info@ section.
@@ -89,8 +90,8 @@ pprAbbrev = pprLEBWord . fromIntegral . fromEnum
-- | Abbreviation declaration. This explains the binary encoding we
-- use for representing 'DwarfInfo'. Be aware that this must be updated
-- along with 'pprDwarfInfo'.
-pprAbbrevDecls :: Bool -> SDoc
-pprAbbrevDecls haveDebugLine =
+pprAbbrevDecls :: Platform -> Bool -> SDoc
+pprAbbrevDecls platform haveDebugLine =
let mkAbbrev abbr tag chld flds =
let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form
in pprAbbrev abbr $$ pprLEBWord tag $$ pprByte chld $$
@@ -105,7 +106,7 @@ pprAbbrevDecls haveDebugLine =
, (dW_AT_high_pc, dW_FORM_addr)
, (dW_AT_frame_base, dW_FORM_block1)
]
- in dwarfAbbrevSection $$
+ in dwarfAbbrevSection platform $$
ptext dwarfAbbrevLabel <> colon $$
mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes
([(dW_AT_name, dW_FORM_string)
@@ -141,8 +142,8 @@ pprAbbrevDecls haveDebugLine =
pprByte 0
-- | Generate assembly for DWARF data
-pprDwarfInfo :: Bool -> DwarfInfo -> SDoc
-pprDwarfInfo haveSrc d
+pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc
+pprDwarfInfo platform haveSrc d
= case d of
DwarfCompileUnit {} -> hasChildren
DwarfSubprogram {} -> hasChildren
@@ -150,36 +151,42 @@ pprDwarfInfo haveSrc d
DwarfSrcNote {} -> noChildren
where
hasChildren =
- pprDwarfInfoOpen haveSrc d $$
- vcat (map (pprDwarfInfo haveSrc) (dwChildren d)) $$
+ pprDwarfInfoOpen platform haveSrc d $$
+ vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$
pprDwarfInfoClose
- noChildren = pprDwarfInfoOpen haveSrc d
+ noChildren = pprDwarfInfoOpen platform haveSrc d
+
+-- | Print a CLabel name in a ".stringz \"LABEL\""
+pprLabelString :: Platform -> CLabel -> SDoc
+pprLabelString platform label =
+ pprString' -- we don't need to escape the string as labels don't contain exotic characters
+ $ withPprStyle (mkCodeStyle CStyle) -- force CStyle (foreign labels may be printed differently in AsmStyle)
+ $ pprCLabel_NCG platform label
-- | Prints assembler data corresponding to DWARF info records. Note
-- that the binary format of this is parameterized in @abbrevDecls@ and
-- has to be kept in synch.
-pprDwarfInfoOpen :: Bool -> DwarfInfo -> SDoc
-pprDwarfInfoOpen haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
+pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc
+pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel
highLabel lineLbl) =
pprAbbrev DwAbbrCompileUnit
$$ pprString name
$$ pprString producer
$$ pprData4 dW_LANG_Haskell
$$ pprString compDir
- $$ pprWord (ppr lowLabel)
- $$ pprWord (ppr highLabel)
+ $$ pprWord platform (ppr lowLabel)
+ $$ pprWord platform (ppr highLabel)
$$ if haveSrc
- then sectionOffset (ptext lineLbl) (ptext dwarfLineLabel)
+ then sectionOffset platform (ptext lineLbl) (ptext dwarfLineLabel)
else empty
-pprDwarfInfoOpen _ (DwarfSubprogram _ name label
- parent) = sdocWithDynFlags $ \df ->
+pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev abbrev
$$ pprString name
- $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
+ $$ pprLabelString platform label
$$ pprFlag (externallyVisibleCLabel label)
- $$ pprWord (ppr label)
- $$ pprWord (ppr $ mkAsmTempEndLabel label)
+ $$ pprWord platform (ppr label)
+ $$ pprWord platform (ppr $ mkAsmTempEndLabel label)
$$ pprByte 1
$$ pprByte dW_OP_call_frame_cfa
$$ parentValue
@@ -187,18 +194,18 @@ pprDwarfInfoOpen _ (DwarfSubprogram _ name label
abbrev = case parent of Nothing -> DwAbbrSubprogram
Just _ -> DwAbbrSubprogramWithParent
parentValue = maybe empty pprParentDie parent
- pprParentDie sym = sectionOffset (ppr sym) (ptext dwarfInfoLabel)
-pprDwarfInfoOpen _ (DwarfBlock _ label Nothing) = sdocWithDynFlags $ \df ->
+ pprParentDie sym = sectionOffset platform (ppr sym) (ptext dwarfInfoLabel)
+pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlockWithoutCode
- $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
-pprDwarfInfoOpen _ (DwarfBlock _ label (Just marker)) = sdocWithDynFlags $ \df ->
+ $$ pprLabelString platform label
+pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =
ppr (mkAsmTempDieLabel label) <> colon
$$ pprAbbrev DwAbbrBlock
- $$ pprString (renderWithStyle df (ppr label) (mkCodeStyle CStyle))
- $$ pprWord (ppr marker)
- $$ pprWord (ppr $ mkAsmTempEndLabel marker)
-pprDwarfInfoOpen _ (DwarfSrcNote ss) =
+ $$ pprLabelString platform label
+ $$ pprWord platform (ppr marker)
+ $$ pprWord platform (ppr $ mkAsmTempEndLabel marker)
+pprDwarfInfoOpen _ _ (DwarfSrcNote ss) =
pprAbbrev DwAbbrGhcSrcNote
$$ pprString' (ftext $ srcSpanFile ss)
$$ pprData4 (fromIntegral $ srcSpanStartLine ss)
@@ -221,9 +228,9 @@ data DwarfARange
-- | Print assembler directives corresponding to a DWARF @.debug_aranges@
-- address table entry.
-pprDwarfARanges :: [DwarfARange] -> Unique -> SDoc
-pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
- let wordSize = platformWordSize plat
+pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc
+pprDwarfARanges platform arngs unitU =
+ let wordSize = platformWordSizeInBytes platform
paddingSize = 4 :: Int
-- header is 12 bytes long.
-- entry is 8 bytes (32-bit platform) or 16 bytes (64-bit platform).
@@ -233,19 +240,19 @@ pprDwarfARanges arngs unitU = sdocWithPlatform $ \plat ->
initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize
in pprDwWord (ppr initialLength)
$$ pprHalf 2
- $$ sectionOffset (ppr $ mkAsmTempLabel $ unitU)
- (ptext dwarfInfoLabel)
+ $$ sectionOffset platform (ppr $ mkAsmTempLabel $ unitU)
+ (ptext dwarfInfoLabel)
$$ pprByte (fromIntegral wordSize)
$$ pprByte 0
$$ pad paddingSize
-- body
- $$ vcat (map pprDwarfARange arngs)
+ $$ vcat (map (pprDwarfARange platform) arngs)
-- terminus
- $$ pprWord (char '0')
- $$ pprWord (char '0')
+ $$ pprWord platform (char '0')
+ $$ pprWord platform (char '0')
-pprDwarfARange :: DwarfARange -> SDoc
-pprDwarfARange arng = pprWord (ppr $ dwArngStartLabel arng) $$ pprWord length
+pprDwarfARange :: Platform -> DwarfARange -> SDoc
+pprDwarfARange platform arng = pprWord platform (ppr $ dwArngStartLabel arng) $$ pprWord platform length
where
length = ppr (dwArngEndLabel arng)
<> char '-' <> ppr (dwArngStartLabel arng)
@@ -283,23 +290,22 @@ instance Outputable DwarfFrameBlock where
ppr (DwarfFrameBlock hasInfo unwinds) = braces $ ppr hasInfo <+> ppr unwinds
-- | Header for the @.debug_frame@ section. Here we emit the "Common
--- Information Entry" record that etablishes general call frame
+-- Information Entry" record that establishes general call frame
-- parameters and the default stack layout.
-pprDwarfFrame :: DwarfFrame -> SDoc
-pprDwarfFrame DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}
- = sdocWithPlatform $ \plat ->
- let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")
+pprDwarfFrame :: Platform -> DwarfFrame -> SDoc
+ppr