ghc-lib 9.4.8.20231111 → 9.6.1.20230312

raw patch · 369 files changed

+52092/−35059 lines, 369 filesdep ~basedep ~bytestringdep ~deepseqPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: base, bytestring, deepseq, ghc-lib-parser, ghc-prim

API changes (from Hackage documentation)

Files

• compiler/Bytecodes.h +2/−0
• compiler/ClosureTypes.h +2/−1
• compiler/CodeGen.Platform.h +72/−1
• compiler/GHC.hs +38/−77
• compiler/GHC/Builtin/Names/TH.hs +13/−8
• compiler/GHC/Builtin/Types/Literals.hs +2/−2
• compiler/GHC/ByteCode/Asm.hs +18/−14
• compiler/GHC/ByteCode/Instr.hs +20/−19
• compiler/GHC/ByteCode/Linker.hs +2/−1
• compiler/GHC/Cmm/CallConv.hs +0/−1
• compiler/GHC/Cmm/CommonBlockElim.hs +14/−26
• compiler/GHC/Cmm/Config.hs +1/−0
• compiler/GHC/Cmm/ContFlowOpt.hs +9/−7
• compiler/GHC/Cmm/Dataflow.hs +1/−1
• compiler/GHC/Cmm/DebugBlock.hs +24/−13
• compiler/GHC/Cmm/Dominators.hs +213/−0
• compiler/GHC/Cmm/Info/Build.hs +95/−58
• compiler/GHC/Cmm/Lint.hs +11/−16
• compiler/GHC/Cmm/Liveness.hs +1/−2
• compiler/GHC/Cmm/Parser.y +22/−30
• compiler/GHC/Cmm/Parser/Config.hs +24/−0
• compiler/GHC/Cmm/Parser/Monad.hs +8/−5
• compiler/GHC/Cmm/Pipeline.hs +26/−18
• compiler/GHC/Cmm/Ppr.hs +0/−319
• compiler/GHC/Cmm/Ppr/Decl.hs +0/−172
• compiler/GHC/Cmm/Ppr/Expr.hs +0/−299
• compiler/GHC/Cmm/ProcPoint.hs +0/−3
• compiler/GHC/Cmm/Reducibility.hs +224/−0
• compiler/GHC/Cmm/Sink.hs +4/−4
• compiler/GHC/Cmm/ThreadSanitizer.hs +285/−0
• compiler/GHC/Cmm/Utils.hs +5/−50
• compiler/GHC/CmmToAsm.hs +64/−63
• compiler/GHC/CmmToAsm/AArch64.hs +7/−5
• compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +61/−246
• compiler/GHC/CmmToAsm/AArch64/Cond.hs +2/−8
• compiler/GHC/CmmToAsm/AArch64/Instr.hs +11/−4
• compiler/GHC/CmmToAsm/AArch64/Ppr.hs +184/−175
• compiler/GHC/CmmToAsm/AArch64/Regs.hs +4/−9
• compiler/GHC/CmmToAsm/BlockLayout.hs +38/−40
• compiler/GHC/CmmToAsm/CFG.hs +9/−14
• compiler/GHC/CmmToAsm/CFG/Dominators.hs +3/−3
• compiler/GHC/CmmToAsm/CPrim.hs +1/−1
• compiler/GHC/CmmToAsm/Dwarf.hs +32/−33
• compiler/GHC/CmmToAsm/Dwarf/Constants.hs +27/−4
• compiler/GHC/CmmToAsm/Dwarf/Types.hs +108/−83
• compiler/GHC/CmmToAsm/Instr.hs +2/−1
• compiler/GHC/CmmToAsm/Monad.hs +54/−53
• compiler/GHC/CmmToAsm/PIC.hs +19/−17
• compiler/GHC/CmmToAsm/PPC.hs +2/−1
• compiler/GHC/CmmToAsm/PPC/CodeGen.hs +5/−6
• compiler/GHC/CmmToAsm/PPC/Instr.hs +13/−11
• compiler/GHC/CmmToAsm/PPC/Ppr.hs +138/−142
• compiler/GHC/CmmToAsm/PPC/Regs.hs +4/−3
• compiler/GHC/CmmToAsm/Ppr.hs +32/−30
• compiler/GHC/CmmToAsm/Reg/Graph.hs +2/−2
• compiler/GHC/CmmToAsm/Reg/Graph/Base.hs +164/−0
• compiler/GHC/CmmToAsm/Reg/Graph/Coalesce.hs +99/−0
• compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +1/−2
• compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +1/−2
• compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +2/−2
• compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +7/−1
• compiler/GHC/CmmToAsm/Reg/Graph/X86.hs +161/−0
• compiler/GHC/CmmToAsm/Reg/Linear.hs +4/−2
• compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs +1/−1
• compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +2/−0
• compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +4/−3
• compiler/GHC/CmmToAsm/Reg/Liveness.hs +6/−8
• compiler/GHC/CmmToAsm/Reg/Target.hs +10/−0
• compiler/GHC/CmmToAsm/Wasm.hs +56/−0
• compiler/GHC/CmmToAsm/Wasm/Asm.hs +538/−0
• compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +1686/−0
• compiler/GHC/CmmToAsm/Wasm/Types.hs +475/−0
• compiler/GHC/CmmToAsm/Wasm/Utils.hs +29/−0
• compiler/GHC/CmmToAsm/X86.hs +3/−2
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +9/−24
• compiler/GHC/CmmToAsm/X86/Instr.hs +4/−3
• compiler/GHC/CmmToAsm/X86/Ppr.hs +127/−151
• compiler/GHC/CmmToAsm/X86/Regs.hs +4/−4
• compiler/GHC/CmmToC.hs +60/−67
• compiler/GHC/CmmToLlvm.hs +5/−5
• compiler/GHC/CmmToLlvm/Base.hs +15/−67
• compiler/GHC/CmmToLlvm/CodeGen.hs +11/−22
• compiler/GHC/CmmToLlvm/Config.hs +0/−31
• compiler/GHC/CmmToLlvm/Data.hs +0/−3
• compiler/GHC/CmmToLlvm/Ppr.hs +1/−1
• compiler/GHC/Core/LateCC.hs +5/−5
• compiler/GHC/Core/Opt/CSE.hs +50/−46
• compiler/GHC/Core/Opt/CallArity.hs +7/−8
• compiler/GHC/Core/Opt/CprAnal.hs +6/−3
• compiler/GHC/Core/Opt/DmdAnal.hs +2572/−2252
• compiler/GHC/Core/Opt/Exitify.hs +6/−6
• compiler/GHC/Core/Opt/FloatIn.hs +13/−24
• compiler/GHC/Core/Opt/FloatOut.hs +6/−12
• compiler/GHC/Core/Opt/LiberateCase.hs +34/−16
• compiler/GHC/Core/Opt/Pipeline.hs +65/−577
• compiler/GHC/Core/Opt/SetLevels.hs +119/−141
• compiler/GHC/Core/Opt/Simplify.hs +0/−4317
• compiler/GHC/Core/Opt/Simplify/Env.hs +0/−1069
• compiler/GHC/Core/Opt/Simplify/Monad.hs +0/−297
• compiler/GHC/Core/Opt/Simplify/Utils.hs +0/−2600
• compiler/GHC/Core/Opt/SpecConstr.hs +586/−381
• compiler/GHC/Core/Opt/Specialise.hs +3450/−3104
• compiler/GHC/Core/Opt/StaticArgs.hs +7/−4
• compiler/GHC/Core/Opt/WorkWrap.hs +67/−49
• compiler/GHC/Core/Opt/WorkWrap/Utils.hs +261/−185
• compiler/GHC/CoreToStg.hs +88/−85
• compiler/GHC/CoreToStg/Prep.hs +121/−145
• compiler/GHC/Data/Graph/Collapse.hs +264/−0
• compiler/GHC/Data/Graph/Color.hs +2/−3
• compiler/GHC/Data/Graph/Inductive/Graph.hs +643/−0
• compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs +346/−0
• compiler/GHC/Data/Graph/Ops.hs +4/−4
• compiler/GHC/Driver/Backpack.hs +944/−0
• compiler/GHC/Driver/CodeOutput.hs +44/−31
• compiler/GHC/Driver/Config/Cmm.hs +4/−3
• compiler/GHC/Driver/Config/Cmm/Parser.hs +25/−0
• compiler/GHC/Driver/Config/CmmToAsm.hs +1/−1
• compiler/GHC/Driver/Config/CmmToLlvm.hs +9/−5
• compiler/GHC/Driver/Config/Core/Lint/Interactive.hs +35/−0
• compiler/GHC/Driver/Config/Core/Opt/Arity.hs +15/−0
• compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs +15/−0
• compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +91/−0
• compiler/GHC/Driver/Config/Core/Opt/WorkWrap.hs +21/−0
• compiler/GHC/Driver/Config/Core/Rules.hs +23/−0
• compiler/GHC/Driver/Config/CoreToStg.hs +16/−0
• compiler/GHC/Driver/Config/CoreToStg/Prep.hs +34/−0
• compiler/GHC/Driver/Config/HsToCore/Ticks.hs +28/−0
• compiler/GHC/Driver/Config/HsToCore/Usage.hs +14/−0
• compiler/GHC/Driver/Config/Linker.hs +13/−0
• compiler/GHC/Driver/Config/StgToCmm.hs +13/−12
• compiler/GHC/Driver/Config/StgToJS.hs +32/−0
• compiler/GHC/Driver/Config/Tidy.hs +1/−5
• compiler/GHC/Driver/GenerateCgIPEStub.hs +23/−22
• compiler/GHC/Driver/Main.hs +419/−161
• compiler/GHC/Driver/Make.hs +382/−139
• compiler/GHC/Driver/MakeFile.hs +454/−0
• compiler/GHC/Driver/Pipeline.hs +165/−113
• compiler/GHC/Driver/Pipeline.hs-boot +2/−1
• compiler/GHC/Driver/Pipeline/Execute.hs +222/−283
• compiler/GHC/Hs/Stats.hs +4/−4
• compiler/GHC/Hs/Syn/Type.hs +16/−19
• compiler/GHC/HsToCore.hs +77/−52
• compiler/GHC/HsToCore/Arrows.hs +54/−47
• compiler/GHC/HsToCore/Binds.hs +128/−86
• compiler/GHC/HsToCore/Breakpoints.hs +54/−0
• compiler/GHC/HsToCore/Coverage.hs +129/−1358
• compiler/GHC/HsToCore/Docs.hs +8/−7
• compiler/GHC/HsToCore/Expr.hs +67/−300
• compiler/GHC/HsToCore/Foreign/C.hs +632/−0
• compiler/GHC/HsToCore/Foreign/Call.hs +9/−12
• compiler/GHC/HsToCore/Foreign/Decl.hs +24/−674
• compiler/GHC/HsToCore/Foreign/JavaScript.hs +683/−0
• compiler/GHC/HsToCore/Foreign/Prim.hs +45/−0
• compiler/GHC/HsToCore/Foreign/Utils.hs +105/−0
• compiler/GHC/HsToCore/GuardedRHSs.hs +1/−1
• compiler/GHC/HsToCore/ListComp.hs +22/−25
• compiler/GHC/HsToCore/Match.hs +22/−17
• compiler/GHC/HsToCore/Match/Constructor.hs +10/−11
• compiler/GHC/HsToCore/Match/Literal.hs +18/−11
• compiler/GHC/HsToCore/Monad.hs +16/−13
• compiler/GHC/HsToCore/Pmc.hs +1/−1
• compiler/GHC/HsToCore/Pmc/Desugar.hs +37/−6
• compiler/GHC/HsToCore/Pmc/Solver.hs +135/−31
• compiler/GHC/HsToCore/Pmc/Utils.hs +3/−3
• compiler/GHC/HsToCore/Quote.hs +208/−161
• compiler/GHC/HsToCore/Ticks.hs +1249/−0
• compiler/GHC/HsToCore/Types.hs +1/−1
• compiler/GHC/HsToCore/Usage.hs +51/−41
• compiler/GHC/HsToCore/Utils.hs +24/−25
• compiler/GHC/Iface/Binary.hs +70/−106
• compiler/GHC/Iface/Errors.hs +1/−1
• compiler/GHC/Iface/Ext/Ast.hs +88/−70
• compiler/GHC/Iface/Ext/Binary.hs +5/−6
• compiler/GHC/Iface/Ext/Types.hs +25/−25
• compiler/GHC/Iface/Ext/Utils.hs +10/−9
• compiler/GHC/Iface/Load.hs +17/−9
• compiler/GHC/Iface/Make.hs +38/−26
• compiler/GHC/Iface/Recomp.hs +35/−22
• compiler/GHC/Iface/Rename.hs +6/−14
• compiler/GHC/Iface/Tidy.hs +171/−68
• compiler/GHC/Iface/Tidy/StaticPtrTable.hs +12/−6
• compiler/GHC/IfaceToCore.hs +108/−49
• compiler/GHC/JS/Make.hs +715/−0
• compiler/GHC/JS/Ppr.hs +294/−0
• compiler/GHC/JS/Syntax.hs +392/−0
• compiler/GHC/JS/Transform.hs +264/−0
• compiler/GHC/Linker.hs +36/−0
• compiler/GHC/Linker/Config.hs +13/−0
• compiler/GHC/Linker/Dynamic.hs +10/−3
• compiler/GHC/Linker/ExtraObj.hs +7/−7
• compiler/GHC/Linker/Loader.hs +45/−11
• compiler/GHC/Linker/MacOS.hs +13/−12
• compiler/GHC/Linker/Static.hs +26/−27
• compiler/GHC/Linker/Unit.hs +15/−15
• compiler/GHC/Llvm/Ppr.hs +2/−2
• compiler/GHC/Llvm/Types.hs +1/−1
• compiler/GHC/Plugins.hs +5/−1
• compiler/GHC/Rename/Bind.hs +73/−45
• compiler/GHC/Rename/Env.hs +25/−47
• compiler/GHC/Rename/Expr.hs +158/−121
• compiler/GHC/Rename/Expr.hs-boot +1/−9
• compiler/GHC/Rename/Fixity.hs +1/−1
• compiler/GHC/Rename/HsType.hs +46/−32
• compiler/GHC/Rename/Module.hs +263/−57
• compiler/GHC/Rename/Names.hs +102/−90
• compiler/GHC/Rename/Pat.hs +37/−34
• compiler/GHC/Rename/Splice.hs +166/−148
• compiler/GHC/Rename/Splice.hs-boot +4/−5
• compiler/GHC/Rename/Unbound.hs +3/−6
• compiler/GHC/Rename/Utils.hs +66/−26
• compiler/GHC/Runtime/Debugger.hs +271/−0
• compiler/GHC/Runtime/Eval.hs +25/−22
• compiler/GHC/Runtime/Heap/Inspect.hs +29/−21
• compiler/GHC/Runtime/Loader.hs +46/−12
• compiler/GHC/Settings/IO.hs +0/−4
• compiler/GHC/Stg/BcPrep.hs +1/−1
• compiler/GHC/Stg/CSE.hs +11/−4
• compiler/GHC/Stg/Debug.hs +1/−1
• compiler/GHC/Stg/InferTags.hs +3/−3
• compiler/GHC/Stg/InferTags/Rewrite.hs +73/−56
• compiler/GHC/Stg/Lift/Analysis.hs +1/−1
• compiler/GHC/Stg/Lift/Monad.hs +2/−2
• compiler/GHC/Stg/Lint.hs +21/−23
• compiler/GHC/Stg/Pipeline.hs +9/−8
• compiler/GHC/Stg/Subst.hs +7/−1
• compiler/GHC/Stg/Unarise.hs +17/−21
• compiler/GHC/Stg/Utils.hs +2/−3
• compiler/GHC/StgToByteCode.hs +101/−118
• compiler/GHC/StgToCmm.hs +4/−3
• compiler/GHC/StgToCmm/Bind.hs +45/−6
• compiler/GHC/StgToCmm/CgUtils.hs +4/−7
• compiler/GHC/StgToCmm/Closure.hs +10/−112
• compiler/GHC/StgToCmm/Env.hs +4/−3
• compiler/GHC/StgToCmm/Expr.hs +22/−15
• compiler/GHC/StgToCmm/Foreign.hs +7/−23
• compiler/GHC/StgToCmm/Heap.hs +15/−19
• compiler/GHC/StgToCmm/InfoTableProv.hs +20/−7
• compiler/GHC/StgToCmm/Layout.hs +2/−2
• compiler/GHC/StgToCmm/Lit.hs +2/−2
• compiler/GHC/StgToCmm/Monad.hs +6/−8
• compiler/GHC/StgToCmm/Prim.hs +121/−220
• compiler/GHC/StgToCmm/Prof.hs +1/−1
• compiler/GHC/StgToCmm/Sequel.hs +0/−1
• compiler/GHC/StgToCmm/TagCheck.hs +6/−7
• compiler/GHC/StgToCmm/Ticky.hs +2/−3
• compiler/GHC/StgToCmm/Utils.hs +6/−6
• compiler/GHC/StgToJS.hs +216/−0
• compiler/GHC/StgToJS/Apply.hs +1152/−0
• compiler/GHC/StgToJS/Arg.hs +285/−0
• compiler/GHC/StgToJS/Closure.hs +156/−0
• compiler/GHC/StgToJS/CodeGen.hs +367/−0
• compiler/GHC/StgToJS/CoreUtils.hs +282/−0
• compiler/GHC/StgToJS/DataCon.hs +124/−0
• compiler/GHC/StgToJS/Deps.hs +191/−0
• compiler/GHC/StgToJS/Expr.hs +1045/−0
• compiler/GHC/StgToJS/ExprCtx.hs +172/−0
• compiler/GHC/StgToJS/FFI.hs +352/−0
• compiler/GHC/StgToJS/Heap.hs +155/−0
• compiler/GHC/StgToJS/Ids.hs +238/−0
• compiler/GHC/StgToJS/Linker/Linker.hs +945/−0
• compiler/GHC/StgToJS/Linker/Types.hs +101/−0
• compiler/GHC/StgToJS/Linker/Utils.hs +308/−0
• compiler/GHC/StgToJS/Literal.hs +109/−0
• compiler/GHC/StgToJS/Monad.hs +183/−0
• compiler/GHC/StgToJS/Object.hs +622/−0
• compiler/GHC/StgToJS/Prim.hs +1502/−0
• compiler/GHC/StgToJS/Printer.hs +218/−0
• compiler/GHC/StgToJS/Profiling.hs +178/−0
• compiler/GHC/StgToJS/Regs.hs +142/−0
• compiler/GHC/StgToJS/Rts/Rts.hs +661/−0
• compiler/GHC/StgToJS/Rts/Types.hs +78/−0
• compiler/GHC/StgToJS/Sinker.hs +180/−0
• compiler/GHC/StgToJS/Stack.hs +373/−0
• compiler/GHC/StgToJS/StaticPtr.hs +28/−0
• compiler/GHC/StgToJS/StgUtils.hs +266/−0
• compiler/GHC/StgToJS/Symbols.hs +89/−0
• compiler/GHC/StgToJS/Types.hs +430/−0
• compiler/GHC/StgToJS/Utils.hs +57/−0
• compiler/GHC/SysTools.hs +0/−45
• compiler/GHC/SysTools/Ar.hs +9/−8
• compiler/GHC/SysTools/Cpp.hs +233/−0
• compiler/GHC/SysTools/Elf.hs +1/−1
• compiler/GHC/SysTools/Info.hs +1/−1
• compiler/GHC/SysTools/Tasks.hs +35/−45
• compiler/GHC/Tc/Deriv.hs +25/−20
• compiler/GHC/Tc/Deriv/Functor.hs +5/−5
• compiler/GHC/Tc/Deriv/Generate.hs +36/−37
• compiler/GHC/Tc/Deriv/Generics.hs +22/−13
• compiler/GHC/Tc/Deriv/Infer.hs +53/−61
• compiler/GHC/Tc/Deriv/Utils.hs +24/−18
• compiler/GHC/Tc/Errors.hs +198/−198
• compiler/GHC/Tc/Errors/Hole.hs +14/−18
• compiler/GHC/Tc/Gen/Annotation.hs +1/−1
• compiler/GHC/Tc/Gen/App.hs +111/−318
• compiler/GHC/Tc/Gen/Arrow.hs +9/−8
• compiler/GHC/Tc/Gen/Bind.hs +187/−151
• compiler/GHC/Tc/Gen/Default.hs +8/−7
• compiler/GHC/Tc/Gen/Export.hs +16/−16
• compiler/GHC/Tc/Gen/Expr.hs +582/−378
• compiler/GHC/Tc/Gen/Foreign.hs +75/−69
• compiler/GHC/Tc/Gen/Head.hs +471/−165
• compiler/GHC/Tc/Gen/HsType.hs +161/−233
• compiler/GHC/Tc/Gen/Match.hs +20/−24
• compiler/GHC/Tc/Gen/Pat.hs +256/−160
• compiler/GHC/Tc/Gen/Rule.hs +15/−13
• compiler/GHC/Tc/Gen/Sig.hs +33/−47
• compiler/GHC/Tc/Gen/Splice.hs +2833/−2628
• compiler/GHC/Tc/Gen/Splice.hs-boot +5/−5
• compiler/GHC/Tc/Instance/Class.hs +129/−80
• compiler/GHC/Tc/Instance/Family.hs +7/−9
• compiler/GHC/Tc/Instance/FunDeps.hs +84/−67
• compiler/GHC/Tc/Instance/Typeable.hs +29/−23
• compiler/GHC/Tc/Module.hs +88/−67
• compiler/GHC/Tc/Plugin.hs +194/−0
• compiler/GHC/Tc/Solver.hs +76/−24
• compiler/GHC/Tc/Solver/Canonical.hs +3417/−3141
• compiler/GHC/Tc/Solver/Interact.hs +517/−277
• compiler/GHC/Tc/Solver/Monad.hs +101/−80
• compiler/GHC/Tc/Solver/Rewrite.hs +53/−33
• compiler/GHC/Tc/TyCl.hs +283/−252
• compiler/GHC/Tc/TyCl/Build.hs +19/−18
• compiler/GHC/Tc/TyCl/Class.hs +24/−112
• compiler/GHC/Tc/TyCl/Instance.hs +170/−165
• compiler/GHC/Tc/TyCl/PatSyn.hs +56/−65
• compiler/GHC/Tc/TyCl/Utils.hs +76/−48
• compiler/GHC/Tc/Utils/Backpack.hs +37/−35
• compiler/GHC/Tc/Utils/Concrete.hs +7/−7
• compiler/GHC/Tc/Utils/Env.hs +14/−17
• compiler/GHC/Tc/Utils/Instantiate.hs +89/−76
• compiler/GHC/Tc/Utils/Monad.hs +36/−30
• compiler/GHC/Tc/Utils/TcMType.hs +64/−110
• compiler/GHC/Tc/Utils/Unify.hs +121/−99
• compiler/GHC/Tc/Utils/Zonk.hs +24/−66
• compiler/GHC/Tc/Validity.hs +310/−314
• compiler/GHC/ThToHs.hs +206/−196
• compiler/GHC/Types/TyThing/Ppr.hs +4/−3
• compiler/GHC/Utils/Asm.hs +3/−2
• compiler/GHC/Wasm/ControlFlow.hs +49/−0
• compiler/GHC/Wasm/ControlFlow/FromCmm.hs +360/−0
• compiler/MachRegs.h +86/−0
• compiler/ghc-llvm-version.h +2/−2
• ghc-lib.cabal +133/−19
• ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-code-size.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +8/−0
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +122/−109
• ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +4/−0
• ghc-lib/stage0/compiler/build/primop-list.hs-incl +8/−0
• ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +8/−0
• ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +10/−2
• ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +5/−0
• ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1314/−1306
• ghc-lib/stage0/lib/llvm-passes +3/−3
• ghc-lib/stage0/lib/llvm-targets +39/−35
• ghc-lib/stage0/lib/settings +1/−3
• ghc-lib/stage0/libraries/ghc-boot/build/GHC/Platform/Host.hs +12/−0
• ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +34/−13
• ghc-lib/stage0/rts/build/include/ghcautoconf.h +18/−12
• libraries/ghc-boot/GHC/HandleEncoding.hs +32/−0
• libraries/ghc-boot/GHC/Settings/Utils.hs +0/−72
• libraries/ghci/GHCi/CreateBCO.hs +211/−0
• libraries/ghci/GHCi/InfoTable.hsc +419/−0
• libraries/ghci/GHCi/ObjLink.hs +195/−0
• libraries/ghci/GHCi/Run.hs +398/−0
• libraries/ghci/GHCi/Signals.hs +47/−0
• libraries/ghci/GHCi/StaticPtrTable.hs +25/−0
• libraries/ghci/GHCi/TH.hs +273/−0
• libraries/template-haskell/Language/Haskell/TH/CodeDo.hs +22/−0
• libraries/template-haskell/Language/Haskell/TH/Quote.hs +57/−0

@@ -34,6 +34,7 @@ #define bci_PUSH16_W                    9 #define bci_PUSH32_W                    10 #define bci_PUSH_G                      11+#define bci_PUSH_ALTS                   12 #define bci_PUSH_ALTS_P                 13 #define bci_PUSH_ALTS_N                 14 #define bci_PUSH_ALTS_F                 15@@ -80,6 +81,7 @@ #define bci_CCALL                       56 #define bci_SWIZZLE                     57 #define bci_ENTER                       58+#define bci_RETURN                      59 #define bci_RETURN_P                    60 #define bci_RETURN_N                    61 #define bci_RETURN_F                    62

@@ -87,4 +87,5 @@ #define SMALL_MUT_ARR_PTRS_FROZEN_DIRTY 61 #define SMALL_MUT_ARR_PTRS_FROZEN_CLEAN 62 #define COMPACT_NFDATA                63-#define N_CLOSURE_TYPES               64+#define CONTINUATION                  64+#define N_CLOSURE_TYPES               65

@@ -377,6 +377,74 @@ # define ft10 62 # define ft11 63 +#elif defined(MACHREGS_loongarch64)++# define zero 0+# define ra   1+# define tp   2+# define sp   3+# define a0   4+# define a1   5+# define a2   6+# define a3   7+# define a4   8+# define a5   9+# define a6  10+# define a7  11+# define t0  12+# define t1  13+# define t2  14+# define t3  15+# define t4  16+# define t5  17+# define t6  18+# define t7  19+# define t8  20+# define u0  21+# define fp  22+# define s0  23+# define s1  24+# define s2  25+# define s3  26+# define s4  27+# define s5  28+# define s6  29+# define s7  30+# define s8  31++# define fa0  32+# define fa1  33+# define fa2  34+# define fa3  35+# define fa4  36+# define fa5  37+# define fa6  38+# define fa7  39+# define ft0  40+# define ft1  41+# define ft2  42+# define ft3  43+# define ft4  44+# define ft5  45+# define ft6  46+# define ft7  47+# define ft8  48+# define ft9  49+# define ft10 50+# define ft11 51+# define ft12 52+# define ft13 53+# define ft14 54+# define ft15 55+# define fs0  56+# define fs1  57+# define fs2  58+# define fs3  59+# define fs4  60+# define fs5  61+# define fs6  62+# define fs7  63+ #endif  callerSaves :: GlobalReg -> Bool@@ -664,7 +732,10 @@ #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \     || defined(MACHREGS_powerpc) \     || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \-    || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64)+    || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) \+    || defined(MACHREGS_wasm32) \+    || defined(MACHREGS_loongarch64)+ # if defined(REG_Base) globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base) # endif

@@ -27,7 +27,8 @@         handleSourceError,          -- * Flags and settings-        DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,+        DynFlags(..), GeneralFlag(..), Severity(..), Backend, gopt,+        ncgBackend, llvmBackend, viaCBackend, interpreterBackend, noBackend,         GhcMode(..), GhcLink(..),         parseDynamicFlags, parseTargetFiles,         getSessionDynFlags,@@ -96,12 +97,12 @@         modInfoSafe,         lookupGlobalName,         findGlobalAnns,-        mkPrintUnqualifiedForModule,+        mkNamePprCtxForModule,         ModIface, ModIface_(..),         SafeHaskellMode(..),          -- * Printing-        PrintUnqualified, alwaysQualify,+        NamePprCtx, alwaysQualify,          -- * Interactive evaluation @@ -118,7 +119,7 @@         setGHCiMonad, getGHCiMonad,          -- ** Inspecting the current context-        getBindings, getInsts, getPrintUnqual,+        getBindings, getInsts, getNamePprCtx,         findModule, lookupModule,         findQualifiedModule, lookupQualifiedModule,         renamePkgQualM, renameRawPkgQualM,@@ -175,7 +176,6 @@          -- ** Modules         Module, mkModule, pprModule, moduleName, moduleUnit,-        ModuleName, mkModuleName, moduleNameString,          -- ** Names         Name,@@ -197,7 +197,7 @@         TyCon,         tyConTyVars, tyConDataCons, tyConArity,         isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,-        isPrimTyCon, isFunTyCon,+        isPrimTyCon,         isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,         tyConClass_maybe,         synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,@@ -352,9 +352,6 @@ import GHC.Tc.Instance.Family  import GHC.Utils.TmpFs-import GHC.SysTools-import GHC.SysTools.BaseDir- import GHC.Utils.Error import GHC.Utils.Monad import GHC.Utils.Misc@@ -370,8 +367,7 @@ 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.FamInstEnv ( FamInst, famInstEnvElts, orphNamesOfFamInst ) import GHC.Core.InstEnv import GHC.Core @@ -561,57 +557,16 @@ -- <http://hackage.haskell.org/package/ghc-paths>.  initGhcMonad :: GhcMonad m => Maybe FilePath -> m ()-initGhcMonad mb_top_dir-  = do { -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds.-         -- So we can't use assertM here.-         -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why.-         !keep_cafs <- liftIO $ c_keepCAFsForGHCi-       ; massert keep_cafs-       ; env <- liftIO $-                do { top_dir <- findTopDir mb_top_dir-                   ; mySettings <- initSysTools top_dir-                   ; myLlvmConfig <- lazyInitLlvmConfig top_dir-                   ; dflags <- initDynFlags (defaultDynFlags mySettings myLlvmConfig)-                   ; hsc_env <- newHscEnv dflags-                   ; checkBrokenTablesNextToCode (hsc_logger hsc_env) dflags-                   ; setUnsafeGlobalDynFlags dflags-                      -- c.f. DynFlags.parseDynamicFlagsFull, which-                      -- creates DynFlags and sets the UnsafeGlobalDynFlags-                   ; return hsc_env }-       ; setSession env }---- | The binutils linker on ARM emits unnecessary R_ARM_COPY relocations which--- breaks tables-next-to-code in dynamically linked modules. This--- 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://gitlab.haskell.org/ghc/ghc/issues/4210#note_78333-checkBrokenTablesNextToCode :: MonadIO m => Logger -> DynFlags -> m ()-checkBrokenTablesNextToCode logger dflags-  = do { broken <- checkBrokenTablesNextToCode' logger dflags-       ; when broken-         $ do { _ <- liftIO $ throwIO $ mkApiErr dflags invalidLdErr-              ; liftIO $ fail "unsupported linker"-              }-       }-  where-    invalidLdErr = text "Tables-next-to-code not supported on ARM" <+>-                   text "when using binutils ld (please see:" <+>-                   text "https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"--checkBrokenTablesNextToCode' :: MonadIO m => Logger -> DynFlags -> m Bool-checkBrokenTablesNextToCode' logger dflags-  | not (isARM arch)               = return False-  | ways dflags `hasNotWay` WayDyn = return False-  | not tablesNextToCode           = return False-  | otherwise                      = do-    linkerInfo <- liftIO $ getLinkerInfo logger dflags-    case linkerInfo of-      GnuLD _  -> return True-      _        -> return False-  where platform = targetPlatform dflags-        arch = platformArch platform-        tablesNextToCode = platformTablesNextToCode platform+initGhcMonad mb_top_dir = setSession =<< liftIO ( do+    -- The call to c_keepCAFsForGHCi must not be optimized away. Even in non-debug builds.+    -- So we can't use assertM here.+    -- See Note [keepCAFsForGHCi] in keepCAFsForGHCi.c for details about why.+-- #if MIN_VERSION_GLASGOW_HASKELL(9,7,0,0)+    !keep_cafs <- c_keepCAFsForGHCi+    massert keep_cafs+-- #endif+    initHscEnv mb_top_dir+  )  -- %************************************************************************ -- %*                                                                      *@@ -640,7 +595,7 @@ -- 'setSessionDynFlags' sets both @DynFlags@, and 'getSessionDynFlags' -- retrieves the program @DynFlags@ (for backwards compatibility). --- This is a compatability function which sets dynflags for the top session+-- This is a compatibility function which sets dynflags for the top session -- as well as the unit. setSessionDynFlags :: (HasCallStack, GhcMonad m) => DynFlags -> m () setSessionDynFlags dflags0 = do@@ -651,7 +606,7 @@   case S.toList all_uids of     [uid] -> do       setUnitDynFlagsNoCheck uid dflags-      modifySession (hscSetActiveUnitId (homeUnitId_ dflags))+      modifySession (hscUpdateLoggerFlags . hscSetActiveUnitId (homeUnitId_ dflags))       dflags' <- getDynFlags       setTopSessionDynFlags dflags'     [] -> panic "nohue"@@ -983,7 +938,8 @@   -- See Note [DynFlags consistency]   let (dflags', warnings) = makeDynFlagsConsistent dflags   let diag_opts = initDiagOpts dflags-  liftIO $ handleFlagWarnings logger diag_opts (map (Warn WarningWithoutFlag) warnings)+      print_config = initPrintConfig dflags+  liftIO $ handleFlagWarnings logger print_config diag_opts (map (Warn WarningWithoutFlag) warnings)   return dflags'  checkNewInteractiveDynFlags :: MonadIO m => Logger -> DynFlags -> m DynFlags@@ -993,7 +949,8 @@   if xopt LangExt.StaticPointers dflags0   then do     let diag_opts = initDiagOpts dflags0-    liftIO $ printOrThrowDiagnostics logger diag_opts $ singleMessage+        print_config = initPrintConfig dflags0+    liftIO $ printOrThrowDiagnostics logger print_config diag_opts $ singleMessage       $ fmap GhcDriverMessage       $ mkPlainMsgEnvelope diag_opts interactiveSrcSpan DriverStaticPointersNotSupported     return $ xopt_unset dflags0 LangExt.StaticPointers@@ -1174,7 +1131,7 @@ instance DesugaredMod DesugaredModule where   coreModule m = dm_core_module m -type ParsedSource      = Located HsModule+type ParsedSource      = Located (HsModule GhcPs) type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],                           Maybe (LHsDoc GhcRn)) type TypecheckedSource = LHsBinds GhcTc@@ -1398,9 +1355,9 @@     let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)     in return (instEnvElts inst_env, fam_env) -getPrintUnqual :: GhcMonad m => m PrintUnqualified-getPrintUnqual = withSession $ \hsc_env -> do-  return $ icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_env)+getNamePprCtx :: GhcMonad m => m NamePprCtx+getNamePprCtx = withSession $ \hsc_env -> do+  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)  -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo {@@ -1494,12 +1451,14 @@ modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) -mkPrintUnqualifiedForModule :: GhcMonad m =>-                               ModuleInfo-                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X-mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do-  let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env)-  return (fmap mk_print_unqual (minf_rdr_env minf))+mkNamePprCtxForModule ::+  GhcMonad m =>+  ModuleInfo ->+  m (Maybe NamePprCtx) -- XXX: returns a Maybe X+mkNamePprCtxForModule minf = withSession $ \hsc_env -> do+  let mk_name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env)+      ptc = initPromotionTickContext (hsc_dflags hsc_env)+  return (fmap mk_name_ppr_ctx (minf_rdr_env minf))  modInfoLookupName :: GhcMonad m =>                      ModuleInfo -> Name@@ -1835,7 +1794,7 @@ parser :: String         -- ^ Haskell module source text (full Unicode is supported)        -> DynFlags       -- ^ the flags        -> FilePath       -- ^ the filename (for source locations)-       -> (WarningMessages, Either ErrorMessages (Located HsModule))+       -> (WarningMessages, Either ErrorMessages (Located (HsModule GhcPs)))  parser str dflags filename =    let@@ -2000,5 +1959,7 @@ mkApiErr :: DynFlags -> SDoc -> GhcApiError mkApiErr dflags msg = GhcApiError (showSDoc dflags msg) +-- foreign import ccall unsafe "keepCAFsForGHCi"     c_keepCAFsForGHCi   :: IO Bool+

@@ -10,7 +10,6 @@  import GHC.Builtin.Names( mk_known_key_name ) import GHC.Unit.Types-import GHC.Unit.Module.Name import GHC.Types.Name( Name ) import GHC.Types.Name.Occurrence( tcName, clsName, dataName, varName ) import GHC.Types.Name.Reader( RdrName, nameRdrName )@@ -18,6 +17,8 @@ import GHC.Builtin.Uniques import GHC.Data.FastString +import Language.Haskell.Syntax.Module.Name+ -- To add a name, do three things -- --  1) Allocate a key@@ -31,7 +32,7 @@ templateHaskellNames = [     returnQName, bindQName, sequenceQName, newNameName, liftName, liftTypedName,     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName, mkNameLName,-    mkNameSName,+    mkNameSName, mkNameQName,     mkModNameName,     liftStringName,     unTypeName, unTypeCodeName,@@ -68,7 +69,7 @@     -- Stmt     bindSName, letSName, noBindSName, parSName, recSName,     -- Dec-    funDName, valDName, dataDName, newtypeDName, tySynDName,+    funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName,     classDName, instanceWithOverlapDName,     standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,     pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,@@ -215,7 +216,7 @@ returnQName, bindQName, sequenceQName, newNameName, liftName,     mkNameName, mkNameG_vName, mkNameG_dName, mkNameG_tcName,     mkNameLName, mkNameSName, liftStringName, unTypeName, unTypeCodeName,-    unsafeCodeCoerceName, liftTypedName, mkModNameName :: Name+    unsafeCodeCoerceName, liftTypedName, mkModNameName, mkNameQName :: Name returnQName    = thFun (fsLit "returnQ")   returnQIdKey bindQName      = thFun (fsLit "bindQ")     bindQIdKey sequenceQName  = thFun (fsLit "sequenceQ") sequenceQIdKey@@ -227,6 +228,7 @@ mkNameG_dName  = thFun (fsLit "mkNameG_d")  mkNameG_dIdKey mkNameG_tcName = thFun (fsLit "mkNameG_tc") mkNameG_tcIdKey mkNameLName    = thFun (fsLit "mkNameL")    mkNameLIdKey+mkNameQName    = thFun (fsLit "mkNameQ")    mkNameQIdKey mkNameSName    = thFun (fsLit "mkNameS")    mkNameSIdKey mkModNameName  = thFun (fsLit "mkModName")  mkModNameIdKey unTypeName     = thFun (fsLit "unType")     unTypeIdKey@@ -353,7 +355,7 @@ recSName    = libFun (fsLit "recS")    recSIdKey  -- data Dec = ...-funDName, valDName, dataDName, newtypeDName, tySynDName, classDName,+funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,     instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,     pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,@@ -365,6 +367,7 @@ valDName                         = libFun (fsLit "valD")                         valDIdKey dataDName                        = libFun (fsLit "dataD")                        dataDIdKey newtypeDName                     = libFun (fsLit "newtypeD")                     newtypeDIdKey+typeDataDName                    = libFun (fsLit "typeDataD")                    typeDataDIdKey tySynDName                       = libFun (fsLit "tySynD")                       tySynDIdKey classDName                       = libFun (fsLit "classD")                       classDIdKey instanceWithOverlapDName         = libFun (fsLit "instanceWithOverlapD")         instanceWithOverlapDIdKey@@ -740,7 +743,7 @@ returnQIdKey, bindQIdKey, sequenceQIdKey, liftIdKey, newNameIdKey,     mkNameIdKey, mkNameG_vIdKey, mkNameG_dIdKey, mkNameG_tcIdKey,     mkNameLIdKey, mkNameSIdKey, unTypeIdKey, unTypeCodeIdKey,-    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey :: Unique+    unsafeCodeCoerceIdKey, liftTypedIdKey, mkModNameIdKey, mkNameQIdKey :: Unique returnQIdKey        = mkPreludeMiscIdUnique 200 bindQIdKey          = mkPreludeMiscIdUnique 201 sequenceQIdKey      = mkPreludeMiscIdUnique 202@@ -757,6 +760,7 @@ liftTypedIdKey        = mkPreludeMiscIdUnique 214 mkModNameIdKey        = mkPreludeMiscIdUnique 215 unsafeCodeCoerceIdKey = mkPreludeMiscIdUnique 216+mkNameQIdKey         = mkPreludeMiscIdUnique 217   -- data Lit = ...@@ -887,7 +891,7 @@     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,     patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,-    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey :: Unique+    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique funDIdKey                         = mkPreludeMiscIdUnique 320 valDIdKey                         = mkPreludeMiscIdUnique 321 dataDIdKey                        = mkPreludeMiscIdUnique 322@@ -922,7 +926,8 @@ implicitParamBindDIdKey           = mkPreludeMiscIdUnique 351 kiSigDIdKey                       = mkPreludeMiscIdUnique 352 defaultDIdKey                     = mkPreludeMiscIdUnique 353-pragOpaqueDIdKey                   = mkPreludeMiscIdUnique 354+pragOpaqueDIdKey                  = mkPreludeMiscIdUnique 354+typeDataDIdKey                    = mkPreludeMiscIdUnique 355  -- type Cxt = ... cxtIdKey :: Unique

@@ -29,12 +29,12 @@  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.Core.TyCo.Compare   ( tcEqType ) import GHC.Types.Name          ( Name, BuiltInSyntax(..) ) import GHC.Types.Unique.FM import GHC.Builtin.Types@@ -630,7 +630,7 @@          | tc1 == promotedGTDataCon -> return GT          | otherwise                -> Nothing -known :: (Integer -> Bool) -> TcType -> Bool+known :: (Integer -> Bool) -> Type -> Bool known p x = case isNumLitTy x of               Just a  -> p a               Nothing -> False

@@ -315,7 +315,7 @@           words = concatMap expand ops           expand (SmallOp w) = [w]           expand (LabelOp w) = expand (Op (e w))-          expand (Op w) = if largeOps then largeArg platform w else [fromIntegral w]+          expand (Op w) = if largeOps then largeArg platform (fromIntegral 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)@@ -358,7 +358,7 @@ largeArgInstr :: Word16 -> Word16 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci -largeArg :: Platform -> Word -> [Word16]+largeArg :: Platform -> Word64 -> [Word16] largeArg platform w = case platformWordSize platform of    PW8 -> [fromIntegral (w `shiftR` 48),            fromIntegral (w `shiftR` 32),@@ -395,7 +395,10 @@   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 pk+  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 platform proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  emit (push_alts pk) [Op p]@@ -501,7 +504,8 @@   SWIZZLE   stkoff n       -> emit bci_SWIZZLE [SmallOp stkoff, SmallOp n]   JMP       l              -> emit bci_JMP [LabelOp l]   ENTER                    -> emit bci_ENTER []-  RETURN rep               -> emit (return_non_tuple rep) []+  RETURN                   -> emit bci_RETURN []+  RETURN_UNLIFTED rep      -> emit (return_unlifted rep) []   RETURN_TUPLE             -> emit bci_RETURN_T []   CCALL off m_addr i       -> do np <- addr m_addr                                  emit bci_CCALL [SmallOp off, Op np, SmallOp i]@@ -570,16 +574,16 @@ push_alts V32 = error "push_alts: vector" push_alts V64 = error "push_alts: vector" -return_non_tuple :: ArgRep -> Word16-return_non_tuple V   = bci_RETURN_V-return_non_tuple P   = bci_RETURN_P-return_non_tuple N   = bci_RETURN_N-return_non_tuple L   = bci_RETURN_L-return_non_tuple F   = bci_RETURN_F-return_non_tuple D   = bci_RETURN_D-return_non_tuple V16 = error "return_non_tuple: vector"-return_non_tuple V32 = error "return_non_tuple: vector"-return_non_tuple V64 = error "return_non_tuple: vector"+return_unlifted :: ArgRep -> Word16+return_unlifted V   = bci_RETURN_V+return_unlifted P   = bci_RETURN_P+return_unlifted N   = bci_RETURN_N+return_unlifted L   = bci_RETURN_L+return_unlifted F   = bci_RETURN_F+return_unlifted D   = bci_RETURN_D+return_unlifted V16 = error "return_unlifted: vector"+return_unlifted V32 = error "return_unlifted: vector"+return_unlifted V64 = error "return_unlifted: vector"  {-   we can only handle up to a fixed number of words on the stack,

@@ -1,6 +1,5 @@  {-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE LambdaCase #-} {-# OPTIONS_GHC -funbox-strict-fields #-} -- --  (c) The University of Glasgow 2002-2006@@ -71,12 +70,12 @@    | PUSH16 !Word16    | PUSH32 !Word16 -   -- Push the specifiec local as a 8, 16, 32 bit value onto the stack, but the+   -- Push the specified 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 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-   -- the ones used for PACK (i.e., actually constracting new data types, in+   -- the ones used for PACK (i.e., actually constructing new data types, in    -- which case we use PUSH{8,16,32})    | PUSH8_W  !Word16    | PUSH16_W !Word16@@ -88,7 +87,8 @@    | PUSH_BCO     (ProtoBCO Name)     -- Push an alt continuation-   | PUSH_ALTS          (ProtoBCO Name) ArgRep+   | PUSH_ALTS          (ProtoBCO Name)+   | PUSH_ALTS_UNLIFTED (ProtoBCO Name) ArgRep    | PUSH_ALTS_TUPLE    (ProtoBCO Name) -- continuation                         !NativeCallInfo                         (ProtoBCO Name) -- tuple return BCO@@ -196,10 +196,9 @@     -- To Infinity And Beyond    | ENTER-   | RETURN ArgRep -- return a non-tuple value, here's its rep; see-                   -- Note [Return convention for non-tuple values] in GHC.StgToByteCode-   | RETURN_TUPLE  -- return an unboxed tuple (info already on stack); see-                   -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode+   | RETURN                 -- return a lifted value+   | RETURN_UNLIFTED ArgRep -- return an unlifted value, here's its rep+   | RETURN_TUPLE           -- return an unboxed tuple (info already on stack)     -- Breakpoints    | BRK_FUN          Word16 Unique (RemotePtr CostCentre)@@ -274,7 +273,8 @@                                                <> ppr op    ppr (PUSH_BCO bco)        = hang (text "PUSH_BCO") 2 (ppr bco) -   ppr (PUSH_ALTS bco pk)    = hang (text "PUSH_ALTS" <+> ppr pk) 2 (ppr bco)+   ppr (PUSH_ALTS bco)       = hang (text "PUSH_ALTS") 2 (ppr bco)+   ppr (PUSH_ALTS_UNLIFTED bco pk) = hang (text "PUSH_ALTS_UNLIFTED" <+> ppr pk) 2 (ppr bco)    ppr (PUSH_ALTS_TUPLE bco call_info tuple_bco) =                                hang (text "PUSH_ALTS_TUPLE" <+> ppr call_info)                                     2@@ -340,9 +340,9 @@    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab    ppr CASEFAIL              = text "CASEFAIL"    ppr (JMP lab)             = text "JMP"      <+> ppr lab-   ppr (CCALL off marshall_addr flags) = text "CCALL   " <+> ppr off-                                                <+> text "marshall code at"-                                               <+> text (show marshall_addr)+   ppr (CCALL off marshal_addr flags) = text "CCALL   " <+> ppr off+                                                <+> text "marshal code at"+                                               <+> text (show marshal_addr)                                                <+> (case flags of                                                       0x1 -> text "(interruptible)"                                                       0x2 -> text "(unsafe)"@@ -351,12 +351,10 @@    ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff                                                <+> text "by" <+> ppr n    ppr ENTER                 = text "ENTER"-   ppr (RETURN pk)           = text "RETURN  " <+> ppr pk+   ppr RETURN                = text "RETURN"+   ppr (RETURN_UNLIFTED pk)  = text "RETURN_UNLIFTED  " <+> ppr pk    ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"-   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> mb_uniq <+> text "<cc>"-     where mb_uniq = sdocOption sdocSuppressUniques $ \case-             True  -> text "<uniq>"-             False -> ppr uniq+   ppr (BRK_FUN index uniq _cc) = text "BRK_FUN" <+> ppr index <+> ppr uniq <+> text "<cc>"   @@ -387,8 +385,10 @@ bciStackUse PUSH_G{}              = 1 bciStackUse PUSH_PRIMOP{}         = 1 bciStackUse PUSH_BCO{}            = 1-bciStackUse (PUSH_ALTS bco _)     = 2 {- profiling only, restore CCCS -} ++bciStackUse (PUSH_ALTS bco)       = 2 {- profiling only, restore CCCS -} +                                     3 + protoBCOStackUse bco+bciStackUse (PUSH_ALTS_UNLIFTED bco _) = 2 {- profiling only, restore CCCS -} ++                                         4 + protoBCOStackUse bco bciStackUse (PUSH_ALTS_TUPLE bco info _) =    -- (tuple_bco, call_info word, cont_bco, stg_ctoi_t)    -- tuple@@ -448,7 +448,8 @@ bciStackUse CASEFAIL{}            = 0 bciStackUse JMP{}                 = 0 bciStackUse ENTER{}               = 0-bciStackUse RETURN{}              = 1 -- pushes stg_ret_X for some X+bciStackUse RETURN{}              = 0+bciStackUse RETURN_UNLIFTED{}     = 1 -- pushes stg_ret_X for some X bciStackUse RETURN_TUPLE{}        = 1 -- pushes stg_ret_t header bciStackUse CCALL{}               = 0 bciStackUse PRIMCALL{}            = 1 -- pushes stg_primcall

@@ -28,7 +28,6 @@ import GHC.Builtin.Names  import GHC.Unit.Types-import GHC.Unit.Module.Name  import GHC.Data.FastString import GHC.Data.SizedSeq@@ -41,6 +40,8 @@  import GHC.Types.Name import GHC.Types.Name.Env++import Language.Haskell.Syntax.Module.Name  -- Standard libraries import Data.Array.Unboxed

@@ -12,7 +12,6 @@ import GHC.Cmm.Expr import GHC.Runtime.Heap.Layout import GHC.Cmm (Convention(..))-import GHC.Cmm.Ppr () -- For Outputable instances  import GHC.Platform import GHC.Platform.Profile

@@ -18,16 +18,17 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Collections+import Data.Functor.Classes (liftEq) import Data.Maybe (mapMaybe) import qualified Data.List as List import Data.Word import qualified Data.Map as M-import GHC.Utils.Outputable-import GHC.Utils.Panic import qualified GHC.Data.TrieMap as TM import GHC.Types.Unique.FM import GHC.Types.Unique import Control.Arrow (first, second)+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE  -- ----------------------------------------------------------------------------- -- Eliminate common blocks@@ -81,7 +82,7 @@     | mapNull new_substs = subst     | otherwise = iterate subst' updated_blocks   where-    grouped_blocks :: [[(Key, [DistinctBlocks])]]+    grouped_blocks :: [[(Key, NonEmpty DistinctBlocks)]]     grouped_blocks = map groupByLabel blocks      merged_blocks :: [[(Key, DistinctBlocks)]]@@ -106,9 +107,8 @@         -- This block is not a duplicate, keep it.         Nothing -> second (b:) $ go bs -mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)-mergeBlockList _ [] = pprPanic "mergeBlockList" empty-mergeBlockList subst (b:bs) = go mapEmpty b bs+mergeBlockList :: Subst -> NonEmpty DistinctBlocks -> (Subst, DistinctBlocks)+mergeBlockList subst (b:|bs) = go mapEmpty b bs   where     go !new_subst1 b [] = (new_subst1, b)     go !new_subst1 b1 (b2:bs) = go new_subst b bs@@ -214,7 +214,7 @@   = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2 eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)                    (CmmUnsafeForeignCall t2 r2 a2)-  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2+  = t1 == t2 && r1 == r2 && liftEq (eqExprWith eqBid) a1 a2 eqMiddleWith _ _ _ = False  eqExprWith :: (BlockId -> BlockId -> Bool)@@ -225,12 +225,10 @@   CmmLoad e1 t1 a1   `eq` CmmLoad e2 t2 a2   = t1 `cmmEqType` t2 && e1 `eq` e2 && a1==a2   CmmReg r1          `eq` CmmReg r2          = r1==r2   CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2-  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2+  CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && liftEq eq es1 es2   CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2   _e1                `eq` _e2                = False -  xs `eqs` ys = eqListWith eq xs ys-   eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2   eqLit l1 l2 = l1 == l2 @@ -252,7 +250,7 @@         (_,m',l') = blockSplit block'         nodes'    = filter (not . dont_care) (blockToList m') -        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&+        equal = liftEq (eqMiddleWith eqBid) nodes nodes' &&                 eqLastWith eqBid l l'  @@ -261,21 +259,11 @@ eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =   c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2 eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =-  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2+  t1 == t2 && liftEq eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2 eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =   e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2 eqLastWith _ _ _ = False -eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool-eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'-eqMaybeWith _ Nothing Nothing = True-eqMaybeWith _ _ _ = False--eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool-eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs-eqListWith _ []       []       = True-eqListWith _ _        _        = False- -- | Given a block map, ensure that all "target" blocks are covered by -- the same ticks as the respective "source" blocks. This not only -- means copying ticks, but also adjusting tick scopes where@@ -301,15 +289,15 @@  -- Group by [Label] -- See Note [Compressed TrieMap] in GHC.Core.Map.Expr about the usage of GenMap.-groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, [DistinctBlocks])]+groupByLabel :: [(Key, DistinctBlocks)] -> [(Key, NonEmpty DistinctBlocks)] groupByLabel =-  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, [DistinctBlocks]))+  go (TM.emptyTM :: TM.ListMap (TM.GenMap LabelMap) (Key, NonEmpty DistinctBlocks))     where       go !m [] = TM.foldTM (:) m []       go !m ((k,v) : entries) = go (TM.alterTM k adjust m) entries         where --k' = map (getKey . getUnique) k-              adjust Nothing       = Just (k,[v])-              adjust (Just (_,vs)) = Just (k,v:vs)+              adjust Nothing       = Just (k, pure v)+              adjust (Just (_,vs)) = Just (k, v NE.<| vs)  groupByInt :: (a -> Int) -> [a] -> [[a]] groupByInt f xs = nonDetEltsUFM $ List.foldl' go emptyUFM xs

@@ -19,6 +19,7 @@   , cmmDoLinting           :: !Bool    -- ^ Do Cmm Linting Optimization or not   , cmmOptElimCommonBlks   :: !Bool    -- ^ Eliminate common blocks or not   , cmmOptSink             :: !Bool    -- ^ Perform sink after stack layout or not+  , cmmOptThreadSanitizer  :: !Bool    -- ^ Instrument memory accesses for ThreadSanitizer   , cmmGenStackUnwindInstr :: !Bool    -- ^ Generate stack unwinding instructions (for debugging)   , cmmExternalDynamicRefs :: !Bool    -- ^ Generate code to link against dynamic libraries   , cmmDoCmmSwitchPlans    :: !Bool    -- ^ Should the Cmm pass replace Stg switch statements

@@ -1,7 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Cmm.ContFlowOpt     ( cmmCfgOpts     , cmmCfgOptsProc@@ -21,8 +19,10 @@ import GHC.Cmm.Utils import GHC.Cmm.Switch (mapSwitchTargets, switchTargetsToList) import GHC.Data.Maybe-import GHC.Utils.Panic+import GHC.Platform import GHC.Utils.Misc+import GHC.Utils.Outputable+import GHC.Utils.Panic  import Control.Monad @@ -334,7 +334,7 @@   In this case we could assume that we will end up with a jump for BOTH   branches. In this case it might be best to put the likely path in the true   branch especially if there are large numbers of predecessors as this saves-  us the jump thats not taken. However I haven't tested this and as of early+  us the jump that's not taken. However I haven't tested this and as of early   2018 we almost never generate cmm where this would apply. -} @@ -422,9 +422,9 @@     add_preds block env = foldr add env (successors block)       where add lbl env = mapInsertWith (+) lbl 1 env --- Removing unreachable blocks-removeUnreachableBlocksProc :: CmmDecl -> CmmDecl-removeUnreachableBlocksProc proc@(CmmProc info lbl live g)+-- Remove unreachable blocks from procs+removeUnreachableBlocksProc :: Platform -> CmmDecl -> CmmDecl+removeUnreachableBlocksProc _ proc@(CmmProc info lbl live g)    | used_blocks `lengthLessThan` mapSize (toBlockMap g)    = CmmProc info' lbl live g'    | otherwise@@ -446,3 +446,5 @@       used_lbls :: LabelSet      used_lbls = setFromList $ map entryLabel used_blocks+removeUnreachableBlocksProc platform data'@(CmmData _ _) =+    pprPanic "removeUnreachableBlocksProc: passed data declaration instead of procedure" (pdoc platform data')

@@ -87,7 +87,7 @@     Block n C C -> FactBase f -> FactBase f  --- | Function for rewrtiting and analysis combined. To be used with+-- | Function for rewriting and analysis combined. To be used with -- @rewriteCmm@. -- -- Currently set to work with @UniqSM@ monad, but we could probably abstract

@@ -29,7 +29,8 @@    -- * Unwinding information   UnwindTable, UnwindPoint(..),-  UnwindExpr(..), toUnwindExpr+  UnwindExpr(..), toUnwindExpr,+  pprUnwindTable   ) where  import GHC.Prelude@@ -38,12 +39,12 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm+import GHC.Cmm.Reg ( pprGlobalReg ) import GHC.Cmm.Utils import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Cmm.Ppr.Expr ( pprExpr ) import GHC.Types.SrcLoc import GHC.Types.Tickish import GHC.Utils.Misc      ( seqList )@@ -78,7 +79,7 @@   , dblBlocks     :: ![DebugBlock] -- ^ Nested blocks   } -instance OutputableP env CLabel => OutputableP env DebugBlock where+instance OutputableP Platform DebugBlock where   pdoc env blk =             (if | dblProcedure blk == dblLabel blk                 -> text "proc"@@ -86,7 +87,7 @@                 -> text "pp-blk"                 | otherwise                 -> text "blk") <+>-            ppr (dblLabel blk) <+> parens (pdoc env (dblCLabel blk)) <+>+            ppr (dblLabel blk) <+> parens (pprAsmLabel env (dblCLabel blk)) <+>             (maybe empty ppr (dblSourceTick blk)) <+>             (maybe (text "removed") ((text "pos " <>) . ppr)                    (dblPosition blk)) <+>@@ -122,7 +123,7 @@                    | otherwise                   = panic "findP impossible" #endif -      scopeMap = foldr (uncurry insertMulti) Map.empty childScopes+      scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope acc) Map.empty childScopes        -- This allows us to recover ticks that we lost by flattening       -- the graph. Basically, if the parent is A but the child is@@ -496,9 +497,9 @@ -- | A label associated with an 'UnwindTable' data UnwindPoint = UnwindPoint !CLabel !UnwindTable -instance OutputableP env CLabel => OutputableP env UnwindPoint where+instance OutputableP Platform UnwindPoint where   pdoc env (UnwindPoint lbl uws) =-      braces $ pdoc env lbl <> colon+      braces $ pprAsmLabel env lbl <> colon       <+> hsep (punctuate comma $ map pprUw $ Map.toList uws)     where       pprUw (g, expr) = ppr g <> char '=' <> pdoc env expr@@ -520,16 +521,24 @@                 | UwTimes UnwindExpr UnwindExpr                 deriving (Eq) -instance OutputableP env CLabel => OutputableP env UnwindExpr where+instance OutputableP Platform UnwindExpr where   pdoc = pprUnwindExpr 0 -pprUnwindExpr :: OutputableP env CLabel => Rational -> env -> UnwindExpr -> SDoc+pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc+pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Map.toList u))))+  where print_entry (reg, Nothing) =+          parens (sep [pprGlobalReg reg, text "Nothing"])+        print_entry (reg, Just x)  =+          parens (sep [pprGlobalReg reg, text "Just" <+> pprUnwindExpr 0 platform x])+  -- Follow instance Outputable (Map.Map GlobalReg (Maybe UnwindExpr))++pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc pprUnwindExpr p env = \case-  UwConst i     -> ppr i-  UwReg g 0     -> ppr g+  UwConst i     -> int i+  UwReg g 0     -> pprGlobalReg g   UwReg g x     -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x))   UwDeref e     -> char '*' <> pprUnwindExpr 3 env e-  UwLabel l     -> pdoc env l+  UwLabel l     -> pprAsmLabel env l   UwPlus e0 e1    | p <= 0     -> pprUnwindExpr 0 env e0 <> char '+' <> pprUnwindExpr 0 env e1   UwMinus e0 e1@@ -537,6 +546,8 @@   UwTimes e0 e1    | p <= 1     -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1   other         -> parens (pprUnwindExpr 0 env other)+{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-}+{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as@@ -559,6 +570,6 @@     (MO_Sub{}, u1,        u2       ) -> UwMinus u1 u2     (MO_Mul{}, u1,        u2       ) -> UwTimes u1 u2     _otherwise -> pprPanic "Unsupported operator in unwind expression!"-                           (pprExpr platform e)+                           (pdoc platform e) toUnwindExpr platform e   = pprPanic "Unsupported unwind expression!" (pdoc platform e)

@@ -0,0 +1,213 @@+{-# LANGUAGE GADTs #-}++module GHC.Cmm.Dominators+  (+  -- * Dominator analysis and representation of results+    DominatorSet(..)+  , GraphWithDominators(..)+  , RPNum+  , graphWithDominators++  -- * Utility functions on graphs or graphs-with-dominators+  , graphMap+  , gwdRPNumber+  , gwdDominatorsOf+  , gwdDominatorTree++  -- * Utility functions on dominator sets+  , dominatorsMember+  , intersectDominators+  )+where++import GHC.Prelude++import Data.Array.IArray+import Data.Foldable()+import qualified Data.Tree as Tree++import qualified Data.IntMap.Strict as IM+import qualified Data.IntSet as IS++import qualified GHC.CmmToAsm.CFG.Dominators as LT++import GHC.Cmm.Dataflow+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.Utils.Outputable( Outputable(..), text, int, hcat, (<+>))+import GHC.Utils.Misc+import GHC.Utils.Panic+++-- | =Dominator sets+--+-- Node X dominates node Y if and only if every path from the entry to+-- Y includes X.  Node Y technically dominates itself, but it is+-- never included in the *representation* of its dominator set.+--+-- A dominator set is represented as a linked list in which each node+-- points to its *immediate* dominator, which is its parent in the+-- dominator tree.  In many circumstances the immediate dominator+-- will be the only dominator of interest.++data DominatorSet = ImmediateDominator { ds_label  :: Label -- ^ Label of the immediate dominator.+                                       , ds_parent :: DominatorSet -- ^ Set of nodes dominating the immediate dominator.+                                       }+                  | EntryNode+  deriving (Eq)++instance Outputable DominatorSet where+  ppr EntryNode = text "entry"+  ppr (ImmediateDominator l parent) = ppr l <+> text "->" <+> ppr parent++++-- | Reverse postorder number of a node in a CFG+newtype RPNum = RPNum Int+  deriving (Eq, Ord)+-- in reverse postorder, nodes closer to the entry have smaller numbers++instance Show RPNum where+  show (RPNum i) = "RP" ++ show i++instance Outputable RPNum where+  ppr (RPNum i) = hcat [text "RP", int i]+   -- using `(<>)` would conflict with Semigroup++++dominatorsMember :: Label -> DominatorSet -> Bool+-- ^ Use to tell if the given label is in the given+-- dominator set.  Which is to say, does the bloc+-- with with given label _properly_ and _non-vacuously_+-- dominate the node whose dominator set this is?+--+-- Takes linear time in the height of the dominator tree,+-- but uses space efficiently.+dominatorsMember lbl (ImmediateDominator l p) = l == lbl || dominatorsMember lbl p+dominatorsMember _   EntryNode = False+++-- | Intersect two dominator sets to produce a third dominator set.+-- This function takes time linear in the size of the sets.+-- As such it is inefficient and should be used only for things+-- like visualizations or linters.+intersectDominators :: DominatorSet -> DominatorSet -> DominatorSet+intersectDominators ds ds' = commonPrefix (revDoms ds []) (revDoms ds' []) EntryNode+  where revDoms EntryNode prev = prev+        revDoms (ImmediateDominator lbl doms) prev = revDoms doms (lbl:prev)+        commonPrefix (a:as) (b:bs) doms+            | a == b = commonPrefix as bs (ImmediateDominator a doms)+        commonPrefix _ _ doms = doms+++-- | The result of dominator analysis.  Also includes a reverse+-- postorder numbering, which is needed for dominator analysis+-- and for other (downstream) analyses.+--+-- Invariant: Dominators, graph, and RP numberings include only *reachable* blocks.+data GraphWithDominators node =+    GraphWithDominators { gwd_graph :: GenCmmGraph node+                        , gwd_dominators :: LabelMap DominatorSet+                        , gwd_rpnumbering :: LabelMap RPNum+                        }+++-- | Call this function with a `CmmGraph` to get back the results of a+-- dominator analysis of that graph (as well as a reverse postorder+-- numbering).  The result also includes the subgraph of the original+-- graph that contains only the reachable blocks.+graphWithDominators :: forall node .+       (NonLocal node, HasDebugCallStack)+       => GenCmmGraph node+       -> GraphWithDominators node++-- The implementation uses the Lengauer-Tarjan algorithm from the x86+-- back end.++graphWithDominators g = GraphWithDominators (reachable rpblocks g) dmap rpmap+      where rpblocks = revPostorderFrom (graphMap g) (g_entry g)+            rplabels' = map entryLabel rpblocks+            rplabels :: Array Int Label+            rplabels = listArray bounds rplabels'++            rpmap :: LabelMap RPNum+            rpmap = mapFromList $ zipWith kvpair rpblocks [0..]+              where kvpair block i = (entryLabel block, RPNum i)++            labelIndex :: Label -> Int+            labelIndex = flip findLabelIn imap+              where imap :: LabelMap Int+                    imap = mapFromList $ zip rplabels' [0..]+            blockIndex = labelIndex . entryLabel++            bounds = (0, length rpblocks - 1)++            ltGraph :: [Block node C C] -> LT.Graph+            ltGraph [] = IM.empty+            ltGraph (block:blocks) =+                IM.insert+                      (blockIndex block)+                      (IS.fromList $ map labelIndex $ successors block)+                      (ltGraph blocks)++            idom_array :: Array Int LT.Node+            idom_array = array bounds $ LT.idom (0, ltGraph rpblocks)++            domSet 0 = EntryNode+            domSet i = ImmediateDominator (rplabels ! d) (doms ! d)+                where d = idom_array ! i+            doms = tabulate bounds domSet++            dmap = mapFromList $ zipWith (\lbl i -> (lbl, domSet i)) rplabels' [0..]++reachable :: NonLocal node => [Block node C C] -> GenCmmGraph node -> GenCmmGraph node+reachable blocks g = g { g_graph = GMany NothingO blockmap NothingO }+  where blockmap = mapFromList [(entryLabel b, b) | b <- blocks]+++-- | =Utility functions++-- | Call `graphMap` to get the mapping from `Label` to `Block` that+-- is embedded in every `CmmGraph`.+graphMap :: GenCmmGraph n -> LabelMap (Block n C C)+graphMap (CmmGraph { g_graph = GMany NothingO blockmap NothingO }) = blockmap++-- | Use `gwdRPNumber` on the result of the dominator analysis to get+-- a mapping from the `Label` of each reachable block to the reverse+-- postorder number of that block.+gwdRPNumber :: HasDebugCallStack => GraphWithDominators node -> Label -> RPNum+gwdRPNumber g l = findLabelIn l (gwd_rpnumbering g)++findLabelIn :: HasDebugCallStack => Label -> LabelMap a -> a+findLabelIn lbl = mapFindWithDefault failed lbl+  where failed =+            pprPanic "label not found in result of analysis" (ppr lbl)++-- | Use `gwdDominatorsOf` on the result of the dominator analysis to get+-- a mapping from the `Label` of each reachable block to the dominator+-- set (and the immediate dominator) of that block.  The+-- implementation is space-efficient: intersecting dominator+-- sets share the representation of their intersection.++gwdDominatorsOf :: HasDebugCallStack => GraphWithDominators node -> Label -> DominatorSet+gwdDominatorsOf g lbl = findLabelIn lbl (gwd_dominators g)++gwdDominatorTree :: GraphWithDominators node -> Tree.Tree Label+gwdDominatorTree gwd = subtreeAt (g_entry (gwd_graph gwd))+  where subtreeAt label = Tree.Node label $ map subtreeAt $ children label+        children l = mapFindWithDefault [] l child_map+        child_map :: LabelMap [Label]+        child_map = mapFoldlWithKey addParent mapEmpty $ gwd_dominators gwd+          where addParent cm _ EntryNode = cm+                addParent cm lbl (ImmediateDominator p _) =+                    mapInsertWith (++) p [lbl] cm+++-- | Turn a function into an array.  Inspired by SML's `Array.tabulate`+tabulate :: (Ix i) => (i, i) -> (i -> e) -> Array i e+tabulate b f = listArray b $ map f $ range b

@@ -1,6 +1,6 @@ {-# LANGUAGE GADTs, BangPatterns, RecordWildCards,     GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,-    ScopedTypeVariables, OverloadedStrings, LambdaCase #-}+    ScopedTypeVariables, OverloadedStrings, LambdaCase, EmptyCase #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE StandaloneDeriving #-}@@ -113,55 +113,70 @@ - Static thunks (THUNK), ie. CAFs - Continuations (RET_SMALL, etc.) -In each case, the info table points to the SRT.  There are three ways which we-may encode the location of the SRT in the info table, described below.+In each case, the info table points to the SRT, if there is one. -USE_SRT_OFFSET----------------In this case we use the info->srt to encode whether or not there is an-SRT and if so encode the offset to its location in info->f.srt_offset:+- info->srt is 0 if there's no SRT+- otherwise, there are three ways which we may encode the location of the SRT in+  the info table, described below. -- info->srt is 0 if there's no SRT, otherwise,-- info->srt == 1 and info->f.srt_offset points to the SRT+USE_SRT_POINTER+---------------+Most general implementation. Can always be used, but other ways are more efficient. -e.g. for a FUN with an SRT:+- info->srt is a pointer -StgFunInfoTable       +------+-  info->f.srt_offset  |  ------------> offset to SRT object-StgStdInfoTable       +------++We encode an **absolute pointer** to the SRT in info->srt. e.g. for a FUN+with an SRT:++StgInfoTable          +------+   info->layout.ptrs   | ...  |   info->layout.nptrs  | ...  |-  info->srt           |  1   |+  info->srt           |  ------------> pointer to SRT object   info->type          | ...  |                       |------| -USE_SRT_POINTER-----------------When tables-next-to-code isn't in use we rather encode an absolute pointer to-the SRT in info->srt. e.g. for a FUN with an SRT:+USE_SRT_OFFSET+--------------+Requires:+  - tables-next-to-code enabled +In this case we use the info->srt to encode whether or not there is an SRT and+if so encode the offset to its location in info->f.srt_offset:++- info->srt is a half-word+- info->f.srt_offset is a 32-bit int+- info->srt is 0 if there's no SRT, otherwise,+- info->srt == 1 and info->f.srt_offset is a offset to the SRT, relative to the+field address itself++e.g. for a FUN with an SRT:+ StgFunInfoTable       +------+-  info->f.srt_offset  |  ------------> pointer to SRT object-StgStdInfoTable       +------++  info->f.srt_offset  |  ------------> offset to SRT object+StgInfoTable          +------+   info->layout.ptrs   | ...  |   info->layout.nptrs  | ...  |   info->srt           |  1   |   info->type          | ...  |                       |------|+ USE_INLINE_SRT_FIELD ---------------------When using TNTC on x86_64 (and other platforms using the small memory model),-we optimise the info table representation further.  The offset to the SRT can+Requires:+  - tables-next-to-code enabled+  - 64-bit architecture+  - small memory model++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 a half-word+- info->srt is 0 if there's no SRT, otherwise: - info->srt is an offset from the info pointer to the SRT object -StgStdInfoTable       +------++StgInfoTable          +------+   info->layout.ptrs   |      |   info->layout.nptrs  |      |   info->srt           |  ------------> offset to SRT object@@ -561,7 +576,7 @@   -> CAFSet cafAnalData platform st = case st of    CmmStaticsRaw _lbl _data           -> Set.empty-   CmmStatics _lbl _itbl _ccs payload ->+   CmmStatics _lbl _itbl _ccs payload _extras ->        foldl' analyzeStatic Set.empty payload      where        analyzeStatic s lit =@@ -726,7 +741,9 @@ getLabelledBlocks :: Platform -> CmmDecl -> [(SomeLabel, CAFfyLabel)] getLabelledBlocks platform decl = case decl of    CmmData _ (CmmStaticsRaw _ _)    -> []-   CmmData _ (CmmStatics lbl _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl) ]+   CmmData _ (CmmStatics lbl info _ _ _) -> [ (DeclLabel lbl, mkCAFfyLabel platform lbl)+                                            | not (isThunkRep (cit_rep info))+                                            ]    CmmProc top_info _ _ _           -> [ (BlockLabel blockId, caf_lbl)                                        | (blockId, info) <- mapToList (info_tbls top_info)                                        , let rep = cit_rep info@@ -771,29 +788,49 @@   graph :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]   graph = stronglyConnCompFromEdgedVerticesOrd nodes --- | Get @(Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.--- The @Set CafLabel@ represents the set of CAFfy things which this CAF's code+-- | Get @(Maybe Label, CAFfyLabel, Set CAFfyLabel)@ for each CAF block.+-- The @Set CAFfyLabel@ represents the set of CAFfy things which this CAF's code -- depends upon. ----- CAFs are treated differently from other labelled blocks:+--  - The 'Label' represents the entry code of the closure. This may be+--    'Nothing' if it is a standard closure type (e.g. @stg_unpack_cstring@; see+--    Note [unpack_cstring closures] in StgStdThunks.cmm).+--  - The 'CAFLabel' is the label of the CAF closure.+--  - The @Set CAFLabel@ is the set of CAFfy closures which should be included+--    in the closure's SRT. --+-- Note that CAFs 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, CAFfyLabel, Set CAFfyLabel)]-getCAFs platform cafEnv decls =-  [ (g_entry g, mkCAFfyLabel 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]-  ]+getCAFs :: Platform -> CAFEnv -> [CmmDecl] -> [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]+getCAFs platform cafEnv = mapMaybe getCAFLabel+  where+    getCAFLabel :: CmmDecl -> Maybe (Maybe Label, CAFfyLabel, Set CAFfyLabel) +    getCAFLabel (CmmProc top_info top_lbl _ g)+      | 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+      = Just (Just (g_entry g), mkCAFfyLabel platform top_lbl, cafs) +      | otherwise+      = Nothing++    getCAFLabel (CmmData _ (CmmStatics top_lbl info _ccs _payload _extras))+      | isThunkRep (cit_rep info)+      = Just (Nothing, mkCAFfyLabel platform top_lbl, Set.empty)++      | otherwise+      = Nothing++    getCAFLabel (CmmData _ (CmmStaticsRaw _lbl _payload))+      = Nothing+ -- | 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]@@ -847,7 +884,7 @@   :: CmmConfig   -> ModuleSRTInfo   -> [(CAFEnv, [CmmDecl])]   -- ^ 'CAFEnv's and 'CmmDecl's for code blocks-  -> [(CAFSet, CmmDecl)]     -- ^ static data decls and their 'CAFSet's+  -> [(CAFSet, CmmDataDecl)]     -- ^ static data decls and their 'CAFSet's   -> IO (ModuleSRTInfo, [CmmDeclSRTs])  doSRTs cfg moduleSRTInfo procs data_ = do@@ -863,16 +900,15 @@         flip map data_ $         \(set, decl) ->           case decl of-            CmmProc{} ->-              pprPanic "doSRTs" (text "Proc in static data list:" <+> pdoc platform decl)+            CmmProc void _ _ _ -> case void of             CmmData _ static ->               case static of-                CmmStatics lbl _ _ _ -> (lbl, set)+                CmmStatics lbl _ _ _ _ -> (lbl, set)                 CmmStaticsRaw lbl _ -> (lbl, set)        (proc_envs, procss) = unzip procs       cafEnv = mapUnions proc_envs-      decls = map snd data_ ++ concat procss+      decls = map (cmmDataDeclCmmDecl . snd) data_ ++ concat procss       staticFuns = mapFromList (getStaticFuns decls)        platform = cmmPlatform cfg@@ -887,7 +923,7 @@     sccs :: [SCC (SomeLabel, CAFfyLabel, Set CAFfyLabel)]     sccs = {-# SCC depAnalSRTs #-} depAnalSRTs platform cafEnv static_data_env decls -    cafsWithSRTs :: [(Label, CAFfyLabel, Set CAFfyLabel)]+    cafsWithSRTs :: [(Maybe Label, CAFfyLabel, Set CAFfyLabel)]     cafsWithSRTs = getCAFs platform cafEnv decls    srtTraceM "doSRTs" (text "data:"            <+> pdoc platform data_ $$@@ -910,7 +946,7 @@         flip runStateT moduleSRTInfo $ do           nonCAFs <- mapM (doSCC cfg staticFuns static_data_env) sccs           cAFs <- forM cafsWithSRTs $ \(l, cafLbl, cafs) ->-            oneSRT cfg staticFuns [BlockLabel l] [cafLbl]+            oneSRT cfg staticFuns (map BlockLabel (maybeToList l)) [cafLbl]                    True{-is a CAF-} cafs static_data_env           return (nonCAFs ++ cAFs) @@ -943,8 +979,7 @@                       | otherwise ->                           -- Not an IdLabel, ignore                           srtMap-                    CmmProc{} ->-                      pprPanic "doSRTs" (text "Found Proc in static data list:" <+> pdoc platform decl))+                    CmmProc void _ _ _ -> case void of)                (moduleSRTMap moduleSRTInfo') data_    return (moduleSRTInfo'{ moduleSRTMap = srtMap_w_raws }, srt_decls ++ decls')@@ -1137,7 +1172,8 @@           not (labelDynamic this_mod platform (cmmExternalDynamicRefs cfg) 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.+          -- all, so we are always forced to build a singleton SRT in this case+          -- (cf #15169)             && (not (osMachOTarget $ platformOS $ profilePlatform profile)                || isLocalCLabel this_mod lbl) -> do @@ -1205,15 +1241,15 @@         ( [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+    ([], _) -> panic "buildSRT: empty"     (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)+    (this:these,those) -> do+      (rest, rest_lbl) <- buildSRTChain profile (this : those)+      (decl,lbl) <- buildSRT profile (rest_lbl : these)       return (decl:rest, lbl)   where     mAX_SRT_SIZE = 16@@ -1232,6 +1268,7 @@         [] -- no padding         [mkIntCLit platform 0] -- link field         [] -- no saved info+        [] -- no extras   return (mkDataLits (Section Data lbl) lbl fields, SRTEntry lbl)  -- | Update info tables with references to their SRTs. Also generate@@ -1247,10 +1284,10 @@ updInfoSRTs _ _ _ _ (CmmData s (CmmStaticsRaw lbl statics))   = [CmmData s (CmmStaticsRaw lbl statics)] -updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload))+updInfoSRTs profile _ _ caffy (CmmData s (CmmStatics lbl itbl ccs payload extras))   = [CmmData s (CmmStaticsRaw lbl (map CmmStaticLit field_lits))]   where-    field_lits = mkStaticClosureFields profile itbl ccs caffy payload+    field_lits = mkStaticClosureFields profile itbl ccs caffy payload extras  updInfoSRTs profile srt_env funSRTEnv caffy (CmmProc top_info top_l live g)   | Just (_,closure) <- maybeStaticClosure = [ proc, closure ]@@ -1280,7 +1317,7 @@             Just srtEntries -> srtTrace "maybeStaticFun" (pdoc (profilePlatform profile) res)               (info_tbl { cit_rep = new_rep }, res)               where res = [ CmmLabel lbl | SRTEntry lbl <- srtEntries ]-          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries+          fields = mkStaticClosureFields profile info_tbl ccs caffy srtEntries []           new_rep = case cit_rep of              HeapRep sta ptrs nptrs ty ->                HeapRep sta (ptrs + length srtEntries) nptrs ty

@@ -6,6 +6,7 @@ -- ----------------------------------------------------------------------------- {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} module GHC.Cmm.Lint (@@ -21,13 +22,15 @@ 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.Cmm.CLabel (pprDebugCLabel) import GHC.Utils.Outputable -import Control.Monad (ap, unless)+import Control.Monad (unless)+import Control.Monad.Trans.Except (ExceptT (..), Except)+import Control.Monad.Trans.Reader (ReaderT (..))+import Data.Functor.Identity (Identity (..))  -- Things to check: --     - invariant on CmmBlock in GHC.Cmm.Expr (see comment there)@@ -47,7 +50,8 @@ runCmmLint :: OutputableP Platform a => Platform -> (a -> CmmLint b) -> a -> Maybe SDoc runCmmLint platform l p =    case unCL (l p) platform of-     Left err -> Just (vcat [text "Cmm lint error:",+     Left err -> Just (withPprStyle defaultDumpStyle $ vcat+                            [text "Cmm lint error:",                              nest 2 err,                              text "Program was:",                              nest 2 (pdoc platform p)])@@ -57,7 +61,7 @@ lintCmmDecl (CmmProc _ lbl _ g)   = do     platform <- getPlatform-    addLintInfo (text "in proc " <> pdoc platform lbl) $ lintCmmGraph g+    addLintInfo (text "in proc " <> pprDebugCLabel platform lbl) $ lintCmmGraph g lintCmmDecl (CmmData {})   = return () @@ -274,17 +278,8 @@ -- just a basic error monad:  newtype CmmLint a = CmmLint { unCL :: Platform -> Either SDoc a }-    deriving (Functor)--instance Applicative CmmLint where-      pure a = CmmLint (\_ -> Right a)-      (<*>) = ap--instance Monad CmmLint where-  CmmLint m >>= k = CmmLint $ \platform ->-                                case m platform of-                                Left e -> Left e-                                Right a -> unCL (k a) platform+  deriving stock (Functor)+  deriving (Applicative, Monad) via ReaderT Platform (Except SDoc)  getPlatform :: CmmLint Platform getPlatform = CmmLint $ \platform -> Right platform

@@ -20,7 +20,6 @@ import GHC.Platform 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@@ -104,7 +103,7 @@ ----------------------------------------------------------------------------- -- | Specialization that only retains the keys for local variables. ----- Local variablas are mostly glorified Ints, and some parts of the compiler+-- Local variables are mostly glorified Ints, and some parts of the compiler -- really don't care about anything but the Int part. So we can avoid some -- overhead by computing a IntSet instead of a Set LocalReg which (unsurprisingly) -- is quite a bit faster.

@@ -221,16 +221,11 @@ { {-# LANGUAGE TupleSections #-} -module GHC.Cmm.Parser ( parseCmmFile ) where+module GHC.Cmm.Parser ( parseCmmFile, CmmParserConfig(..) ) where  import GHC.Prelude import qualified Prelude -- for happy-generated code -import GHC.Driver.Session-import GHC.Driver.Ppr-import GHC.Driver.Config.Parser (initParserOpts)-import GHC.Driver.Config.StgToCmm- import GHC.Platform import GHC.Platform.Profile @@ -261,6 +256,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.Lexer import GHC.Cmm.CLabel+import GHC.Cmm.Parser.Config import GHC.Cmm.Parser.Monad hiding (getPlatform, getProfile) import qualified GHC.Cmm.Parser.Monad as PD import GHC.Cmm.CallConv@@ -464,7 +460,7 @@                         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) [] [] [] } }+                        dontCareCCS (map getLit lits) [] [] [] [] } }         -- arrays of closures required for the CHARLIKE & INTLIKE arrays  lits    :: { [CmmParse CmmExpr] }@@ -479,7 +475,7 @@                          platform <- getPlatform;                          ctx      <- getContext;                          formals <- sequence (fromMaybe [] $3);-                         withName (renderWithContext ctx (pdoc platform entry_ret_label))+                         withName (showSDocOneLine ctx (pprCLabel platform entry_ret_label))                            $4;                          return (entry_ret_label, info, stk_formals, formals) }                      let do_layout = isJust $3@@ -522,15 +518,14 @@                                              , 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+        | 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'+                -- ptrs, nptrs, closure type, description, type, arity, fun type                 {% do                       home_unit_id <- getHomeUnitId                       liftP $ pure $ do                         profile <- getProfile                         let prof = profilingInfo profile $11 $13-                            ty   = Fun 0 (ArgSpec (fromIntegral $15))-                                  -- Arity zero, arg_type $15+                            ty   = Fun (fromIntegral $15) (ArgSpec (fromIntegral $17))                             rep = mkRTSRep (fromIntegral $9) $                                       mkHeapRep profile False (fromIntegral $5)                                                       (fromIntegral $7) ty@@ -540,7 +535,7 @@                                              , cit_prof = prof, cit_srt = Nothing, cit_clo = Nothing },                                 []) }                 -- we leave most of the fields zero here.  This is only used-                -- to generate the BCO info table in the RTS at the moment.+                -- to generate the BCO and CONTINUATION info tables in the RTS at the moment.          | 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'                 -- ptrs, nptrs, tag, closure type, description, type@@ -978,8 +973,9 @@  exprOp :: FastString -> [CmmParse CmmExpr] -> PD (CmmParse CmmExpr) exprOp name args_code = do-  profile     <- PD.getProfile-  align_check <- gopt Opt_AlignmentSanitisation <$> getDynFlags+  pdc     <- PD.getPDConfig+  let profile = PD.pdProfile pdc+  let align_check = PD.pdSanitizeAlignment pdc   case lookupUFM (exprMacros profile align_check) name of      Just f  -> return $ do         args <- sequence args_code@@ -1014,7 +1010,6 @@         ( "ne",         MO_Ne ),         ( "mul",        MO_Mul ),         ( "mulmayoflo",  MO_S_MulMayOflo ),-        ( "mulmayoflou", MO_U_MulMayOflo ),         ( "neg",        MO_S_Neg ),         ( "quot",       MO_S_Quot ),         ( "rem",        MO_S_Rem ),@@ -1296,7 +1291,7 @@ staticClosure :: UnitId -> FastString -> FastString -> [CmmLit] -> CmmParse () staticClosure pkg cl_label info payload   = do profile <- getProfile-       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] []+       let lits = mkStaticClosure profile (mkCmmInfoLabel pkg info) dontCareCCS payload [] [] [] []        code $ emitDataLits (mkCmmDataLabel pkg (NeedExternDecl True) cl_label) lits  foreignCall@@ -1547,43 +1542,40 @@   ]   where platform = profilePlatform profile --parseCmmFile :: DynFlags+parseCmmFile :: CmmParserConfig              -> Module              -> HomeUnit              -> FilePath              -> IO (Messages PsMessage, Messages PsMessage, Maybe (CmmGroup, [InfoProvEnt]))-parseCmmFile dflags this_mod home_unit filename = do+parseCmmFile cmmpConfig this_mod home_unit filename = do   buf <- hGetStringBuffer filename   let         init_loc = mkRealSrcLoc (mkFastString filename) 1 1-        opts       = initParserOpts dflags-        init_state = (initParserState opts buf init_loc) { lex_state = [0] }+        init_state = (initParserState (cmmpParserOpts cmmpConfig) buf init_loc) { lex_state = [0] }                 -- reset the lex_state: the Lexer monad leaves some stuff                 -- in there we don't want.-  case unPD cmmParse dflags home_unit init_state of+        pdConfig = cmmpPDConfig cmmpConfig+  case unPD cmmParse pdConfig home_unit init_state of     PFailed pst -> do         let (warnings,errors) = getPsMessages pst         return (warnings, errors, Nothing)     POk pst code -> do         st <- initC-        let fstate = F.initFCodeState (profilePlatform $ targetProfile dflags)-        let config = initStgToCmmConfig dflags no_module+        let fstate = F.initFCodeState (profilePlatform $ pdProfile pdConfig)         let fcode = do-              ((), cmm) <- getCmm $ unEC code "global" (initEnv (targetProfile dflags)) [] >> return ()+              ((), cmm) <- getCmm $ unEC code "global" (initEnv (pdProfile pdConfig)) [] >> return ()               -- See Note [Mapping Info Tables to Source Positions] (IPE Maps)               let used_info                     | do_ipe    = map (cmmInfoTableToInfoProvEnt this_mod) (mapMaybe topInfoTable cmm)                     | otherwise = []                     where-                      do_ipe = stgToCmmInfoTableMap config+                      do_ipe = stgToCmmInfoTableMap $ cmmpStgToCmmConfig cmmpConfig               ((), cmm2) <- getCmm $ emitIpeBufferListNode this_mod used_info               return (cmm ++ cmm2, used_info)-            (cmm, _) = runC config fstate st fcode+            (cmm, _) = runC (cmmpStgToCmmConfig cmmpConfig) fstate st fcode             (warnings,errors) = getPsMessages pst         if not (isEmptyMessages errors)          then return (warnings, errors, Nothing)          else return (warnings, errors, Just cmm)-  where-        no_module = panic "parseCmmFile: no module"+ }

@@ -0,0 +1,24 @@+module GHC.Cmm.Parser.Config (+    PDConfig(..)+  , CmmParserConfig(..)+) where++import GHC.Prelude++import GHC.Platform.Profile++import GHC.StgToCmm.Config++import GHC.Parser.Lexer+++data PDConfig = PDConfig+  { pdProfile :: !Profile+  , pdSanitizeAlignment :: !Bool -- ^ Insert alignment checks (cf @-falignment-sanitisation@)+  }++data CmmParserConfig = CmmParserConfig+  { cmmpParserOpts :: !ParserOpts+  , cmmpPDConfig :: !PDConfig+  , cmmpStgToCmmConfig :: !StgToCmmConfig+  }

@@ -11,19 +11,22 @@     PD(..)   , liftP   , failMsgPD+  , getPDConfig   , getProfile   , getPlatform   , getHomeUnitId+  , PDConfig(..)   ) where  import GHC.Prelude +import GHC.Cmm.Parser.Config+ import GHC.Platform import GHC.Platform.Profile  import Control.Monad -import GHC.Driver.Session import GHC.Parser.Lexer import GHC.Parser.Errors.Types import GHC.Types.Error ( MsgEnvelope )@@ -31,7 +34,7 @@ import GHC.Unit.Types import GHC.Unit.Home -newtype PD a = PD { unPD :: DynFlags -> HomeUnit -> PState -> ParseResult a }+newtype PD a = PD { unPD :: PDConfig -> HomeUnit -> PState -> ParseResult a }  instance Functor PD where   fmap = liftM@@ -58,11 +61,11 @@                 POk s1 a   -> unPD (k a) d hu s1                 PFailed s1 -> PFailed s1 -instance HasDynFlags PD where-   getDynFlags = PD $ \d _ s -> POk s d+getPDConfig :: PD PDConfig+getPDConfig = PD $ \pdc _ s -> POk s pdc  getProfile :: PD Profile-getProfile = targetProfile <$> getDynFlags+getProfile = PD $ \pdc _ s -> POk s (pdProfile pdc)  getPlatform :: PD Platform getPlatform = profilePlatform <$> getProfile

@@ -1,14 +1,13 @@ {-# LANGUAGE BangPatterns #-}  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 GHC.Prelude +import GHC.Driver.Flags+ import GHC.Cmm import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt@@ -20,39 +19,41 @@ import GHC.Cmm.ProcPoint import GHC.Cmm.Sink import GHC.Cmm.Switch.Implement+import GHC.Cmm.ThreadSanitizer  import GHC.Types.Unique.Supply-import GHC.Driver.Session-import GHC.Driver.Config.Cmm+ import GHC.Utils.Error import GHC.Utils.Logger-import GHC.Driver.Env-import Control.Monad import GHC.Utils.Outputable+ import GHC.Platform++import Control.Monad import Data.Either (partitionEithers)  ----------------------------------------------------------------------------- -- | Top level driver for C-- 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- :: HscEnv -- Compilation env including-           -- dynamic flags: -dcmm-lint -ddump-cmm-cps+ :: Logger+ -> CmmConfig  -> ModuleSRTInfo        -- Info about SRTs generated so far  -> CmmGroup             -- Input C-- with Procedures  -> IO (ModuleSRTInfo, CmmGroupSRTs) -- Output CPS transformed C-- -cmmPipeline hsc_env srtInfo prog = do-  let logger    = hsc_logger hsc_env-  let cmmConfig = initCmmConfig (hsc_dflags hsc_env)+cmmPipeline logger cmm_config srtInfo prog = do   let forceRes (info, group) = info `seq` foldr seq () group-  let platform = cmmPlatform cmmConfig+  let platform = cmmPlatform cmm_config   withTimingSilent logger (text "Cmm pipeline") forceRes $ do-     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmmConfig) prog+     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog       let (procs, data_) = partitionEithers tops-     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmmConfig srtInfo procs data_+     (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_      dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms)       return (srtInfo, cmms)@@ -66,8 +67,8 @@ --     [SRTs]. -- --   - in the case of a `CmmData`, the unmodified 'CmmDecl' and a 'CAFSet' containing-cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDecl))-cpsTop _logger platform _ p@(CmmData _ statics) = return (Right (cafAnalData platform statics, p))+cpsTop :: Logger -> Platform -> CmmConfig -> CmmDecl -> IO (Either (CAFEnv, [CmmDecl]) (CAFSet, CmmDataDecl))+cpsTop _logger platform _ (CmmData section statics) = return (Right (cafAnalData platform statics, CmmData section statics)) cpsTop logger platform cfg proc =     do       ----------- Control-flow optimisations ----------------------------------@@ -98,6 +99,13 @@              else pure g       dump Opt_D_dump_cmm_switch "Post switch plan" g +      ----------- ThreadSanitizer instrumentation -----------------------------+      g <- {-# SCC "annotateTSAN" #-}+          if cmmOptThreadSanitizer cfg+          then runUniqSM $ annotateTSAN platform g+          else return g+      dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g+       ----------- Proc points -------------------------------------------------       let         call_pps :: ProcPointSet -- LabelMap@@ -156,7 +164,7 @@            return $ if cmmOptControlFlow cfg                     then map (cmmCfgOptsProc splitting_proc_points) g                     else g-      g <- return (map removeUnreachableBlocksProc g)+      g <- return $ map (removeUnreachableBlocksProc platform) g            -- See Note [unreachable blocks]       dumps Opt_D_dump_cmm_cfg "Post control-flow optimisations" g 

@@ -1,319 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE LambdaCase #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}------------------------------------------------------------------------------------ Pretty-printing of Cmm as (a superset of) C-------- (c) The University of Glasgow 2004-2006--------------------------------------------------------------------------------------- This is where we walk over CmmNode emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:---      1) if a value has wordRep type, the type is not appended in the---      output.---      2) MachOps that operate over wordRep type are printed in a---      C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs--module GHC.Cmm.Ppr-  ( module GHC.Cmm.Ppr.Decl-  , module GHC.Cmm.Ppr.Expr-  )-where--import GHC.Prelude hiding (succ)--import GHC.Platform-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.Constants (debugIsOn)--import GHC.Types.Basic-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Graph------------------------------------------------------ Outputable instances-instance OutputableP Platform InfoProvEnt where-  pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel--instance Outputable CmmStackInfo where-    ppr = pprStackInfo--instance OutputableP Platform CmmTopInfo where-    pdoc = pprTopInfo---instance OutputableP Platform (CmmNode e x) where-    pdoc = pprNode--instance Outputable Convention where-    ppr = pprConvention--instance Outputable ForeignConvention where-    ppr = pprForeignConvention--instance OutputableP Platform ForeignTarget where-    pdoc = pprForeignTarget--instance Outputable CmmReturnInfo where-    ppr = pprReturnInfo--instance OutputableP Platform (Block CmmNode C C) where-    pdoc = pprBlock-instance OutputableP Platform (Block CmmNode C O) where-    pdoc = pprBlock-instance OutputableP Platform (Block CmmNode O C) where-    pdoc = pprBlock-instance OutputableP Platform (Block CmmNode O O) where-    pdoc = pprBlock--instance OutputableP Platform (Graph CmmNode e x) where-    pdoc = pprGraph--instance OutputableP Platform CmmGraph where-    pdoc = pprCmmGraph--------------------------------------------------------------- Outputting types Cmm contains--pprStackInfo :: CmmStackInfo -> SDoc-pprStackInfo (StackInfo {arg_space=arg_space}) =-  text "arg_space: " <> ppr arg_space--pprTopInfo :: Platform -> CmmTopInfo -> SDoc-pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =-  vcat [text "info_tbls: " <> pdoc platform info_tbl,-        text "stack_info: " <> ppr stack_info]--------------------------------------------------------------- Outputting blocks and graphs--pprBlock :: IndexedCO x SDoc SDoc ~ SDoc-         => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc-pprBlock platform block-    = foldBlockNodesB3 ( ($$) . pdoc platform-                       , ($$) . (nest 4) . pdoc platform-                       , ($$) . (nest 4) . pdoc platform-                       )-                       block-                       empty--pprGraph :: Platform -> Graph CmmNode e x -> SDoc-pprGraph platform = \case-   GNil                  -> empty-   GUnit block           -> pdoc platform block-   GMany entry body exit ->-         text "{"-      $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit)-      $$ text "}"-      where pprMaybeO :: OutputableP Platform (Block CmmNode e x)-                      => MaybeO ex (Block CmmNode e x) -> SDoc-            pprMaybeO NothingO = empty-            pprMaybeO (JustO block) = pdoc platform block--pprCmmGraph :: Platform -> CmmGraph -> SDoc-pprCmmGraph platform g-   = text "{" <> text "offset"-  $$ nest 2 (vcat $ map (pdoc platform) blocks)-  $$ text "}"-  where blocks = revPostorder g-    -- revPostorder has the side-effect of discarding unreachable code,-    -- so pretty-printed Cmm will omit any unreachable blocks.  This can-    -- sometimes be confusing.-------------------------------------------------- Outputting CmmNode and types which it contains--pprConvention :: Convention -> SDoc-pprConvention (NativeNodeCall   {}) = text "<native-node-call-convention>"-pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"-pprConvention (NativeReturn {})     = text "<native-ret-convention>"-pprConvention  Slow                 = text "<slow-convention>"-pprConvention  GC                   = text "<gc-convention>"--pprForeignConvention :: ForeignConvention -> SDoc-pprForeignConvention (ForeignConvention c args res ret) =-          doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret--pprReturnInfo :: CmmReturnInfo -> SDoc-pprReturnInfo CmmMayReturn = empty-pprReturnInfo CmmNeverReturns = text "never returns"--pprForeignTarget :: Platform -> ForeignTarget -> SDoc-pprForeignTarget platform (ForeignTarget fn c) = ppr c <+> ppr_target fn-  where-        ppr_target :: CmmExpr -> SDoc-        ppr_target t@(CmmLit _) = pdoc platform t-        ppr_target fn'          = parens (pdoc platform fn')--pprForeignTarget platform (PrimTarget op)- -- HACK: We're just using a ForeignLabel to get this printed, the label- --       might not really be foreign.- = pdoc platform-               (CmmLabel (mkForeignLabel-                         (mkFastString (show op))-                         Nothing ForeignLabelInThisPackage IsFunction))--pprNode :: Platform -> CmmNode e x -> SDoc-pprNode platform node = pp_node <+> pp_debug-  where-    pp_node :: SDoc-    pp_node = case node of-      -- label:-      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 -> ppUnlessOption sdocSuppressTicks-                     (text "//tick" <+> ppr t)--      -- unwind reg = expr;-      CmmUnwind regs ->-          text "unwind "-          <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi--      -- reg = expr;-      CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi--      -- rep[lv] = expr;-      CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi-          where-            align_mark = case align of-                           Unaligned -> text "^"-                           NaturallyAligned -> empty-            rep = ppr ( cmmExprType platform expr )--      -- call "ccall" foo(x, y)[r1, r2];-      -- ToDo ppr volatile-      CmmUnsafeForeignCall target results args ->-          hsep [ ppUnless (null results) $-                    parens (commafy $ map ppr results) <+> equals,-                 text "call",-                 pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi]--      -- goto label;-      CmmBranch ident -> text "goto" <+> ppr ident <> semi--      -- if (expr) goto t; else goto f;-      CmmCondBranch expr t f l ->-          hsep [ text "if"-               , parens (pdoc platform expr)-               , case l of-                   Nothing -> empty-                   Just b -> parens (text "likely:" <+> ppr b)-               , text "goto"-               , ppr t <> semi-               , text "else goto"-               , ppr f <> semi-               ]--      CmmSwitch expr ids ->-          hang (hsep [ text "switch"-                     , range-                     , if isTrivialCmmExpr expr-                       then pdoc platform expr-                       else parens (pdoc platform expr)-                     , text "{"-                     ])-             4 (vcat (map ppCase cases) $$ def) $$ rbrace-          where-            (cases, mbdef) = switchTargetsFallThrough ids-            ppCase (is,l) = hsep-                            [ text "case"-                            , commafy $ map integer is-                            , text ": goto"-                            , ppr l <> semi-                            ]-            def | Just l <- mbdef = hsep-                            [ text "default:"-                            , braces (text "goto" <+> ppr l <> semi)-                            ]-                | otherwise = empty--            range = brackets $ hsep [integer lo, text "..", integer hi]-              where (lo,hi) = switchTargetsRange ids--      CmmCall tgt k regs out res updfr_off ->-          hcat [ text "call", space-               , pprFun tgt, parens (interpp'SP regs), space-               , returns <+>-                 text "args: " <> ppr out <> comma <+>-                 text "res: " <> ppr res <> comma <+>-                 text "upd: " <> ppr updfr_off-               , semi ]-          where pprFun f@(CmmLit _) = pdoc platform f-                pprFun f = parens (pdoc platform f)--                returns-                  | Just r <- k = text "returns to" <+> ppr r <> comma-                  | otherwise   = empty--      CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->-          hcat $ if i then [text "interruptible", space] else [] ++-               [ text "foreign call", space-               , pdoc platform t, text "(...)", space-               , text "returns to" <+> ppr s-                    <+> text "args:" <+> parens (pdoc platform as)-                    <+> text "ress:" <+> parens (ppr rs)-               , text "ret_args:" <+> ppr a-               , text "ret_off:" <+> ppr u-               , semi ]--    pp_debug :: SDoc-    pp_debug =-      if not debugIsOn then empty-      else case node of-             CmmEntry {}             -> empty -- Looks terrible with text "  // CmmEntry"-             CmmComment {}           -> empty -- Looks also terrible with text "  // CmmComment"-             CmmTick {}              -> empty-             CmmUnwind {}            -> text "  // CmmUnwind"-             CmmAssign {}            -> text "  // CmmAssign"-             CmmStore {}             -> text "  // CmmStore"-             CmmUnsafeForeignCall {} -> text "  // CmmUnsafeForeignCall"-             CmmBranch {}            -> text "  // CmmBranch"-             CmmCondBranch {}        -> text "  // CmmCondBranch"-             CmmSwitch {}            -> text "  // CmmSwitch"-             CmmCall {}              -> text "  // CmmCall"-             CmmForeignCall {}       -> text "  // CmmForeignCall"--    commafy :: [SDoc] -> SDoc-    commafy xs = hsep $ punctuate comma xs

@@ -1,172 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}------------------------------------------------------------------------------------- Pretty-printing of common Cmm types------ (c) The University of Glasgow 2004-2006---------------------------------------------------------------------------------------- This is where we walk over Cmm emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:---      1) if a value has wordRep type, the type is not appended in the---      output.---      2) MachOps that operate over wordRep type are printed in a---      C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs-----{-# OPTIONS_GHC -fno-warn-orphans #-}-module GHC.Cmm.Ppr.Decl-    ( pprCmms, pprCmmGroup, pprSection, pprStatic-    )-where--import GHC.Prelude--import GHC.Platform-import GHC.Cmm.Ppr.Expr-import GHC.Cmm--import GHC.Utils.Outputable--import Data.List (intersperse)--import qualified Data.ByteString as BS---pprCmms :: (OutputableP Platform info, OutputableP Platform g)-        => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc-pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))-        where-          separator = space $$ text "-------------------" $$ space---------------------------------------------------------------------------------instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)-      => OutputableP Platform (GenCmmDecl d info i) where-    pdoc = pprTop--instance OutputableP Platform (GenCmmStatics a) where-    pdoc = pprStatics--instance OutputableP Platform CmmStatic where-    pdoc = pprStatic--instance OutputableP Platform CmmInfoTable where-    pdoc = pprInfoTable----------------------------------------------------------------------------------pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)-            => Platform -> GenCmmGroup d info g -> SDoc-pprCmmGroup platform tops-    = vcat $ intersperse blankLine $ map (pprTop platform) tops---- ----------------------------------------------------------------------------- Top level `procedure' blocks.----pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)-       => Platform -> GenCmmDecl d info i -> SDoc--pprTop platform (CmmProc info lbl live graph)--  = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live-         , nest 8 $ lbrace <+> pdoc platform info $$ rbrace-         , nest 4 $ pdoc platform graph-         , rbrace ]---- ----------------------------------------------------------------------------- We follow [1], 4.5------      section "data" { ... }----pprTop platform (CmmData section ds) =-    (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))-    $$ rbrace---- ----------------------------------------------------------------------------- Info tables.--pprInfoTable :: Platform -> CmmInfoTable -> SDoc-pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep-                           , cit_prof = prof_info-                           , cit_srt = srt })-  = vcat [ text "label: " <> pdoc platform lbl-         , text "rep: " <> ppr rep-         , case prof_info of-             NoProfilingInfo -> empty-             ProfilingInfo ct cd ->-               vcat [ text "type: " <> text (show (BS.unpack ct))-                    , text "desc: " <> text (show (BS.unpack cd)) ]-         , text "srt: " <> pdoc platform srt ]--instance Outputable ForeignHint where-  ppr NoHint     = empty-  ppr SignedHint = quotes(text "signed")---  ppr AddrHint   = quotes(text "address")--- Temp Jan08-  ppr AddrHint   = (text "PtrHint")---- ----------------------------------------------------------------------------- Static data.---      Strings are printed as C strings, and we print them as I8[],---      following C-------pprStatics :: Platform -> GenCmmStatics a -> SDoc-pprStatics platform (CmmStatics lbl itbl ccs payload) =-  pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload-pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) 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----pprSection :: Platform -> Section -> SDoc-pprSection platform (Section t suffix) =-  section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)-  where-    section = text "section"--pprSectionType :: SectionType -> SDoc-pprSectionType s = doubleQuotes $ case s of-  Text                    -> text "text"-  Data                    -> text "data"-  ReadOnlyData            -> text "readonly"-  ReadOnlyData16          -> text "readonly16"-  RelocatableReadOnlyData -> text "relreadonly"-  UninitialisedData       -> text "uninitialised"-  InitArray               -> text "initarray"-  FiniArray               -> text "finiarray"-  CString                 -> text "cstring"-  OtherSection s'         -> text s'

@@ -1,299 +0,0 @@----------------------------------------------------------------------------------- Pretty-printing of common Cmm types------ (c) The University of Glasgow 2004-2006---------------------------------------------------------------------------------------- This is where we walk over Cmm emitting an external representation,--- suitable for parsing, in a syntax strongly reminiscent of C--. This--- is the "External Core" for the Cmm layer.------ As such, this should be a well-defined syntax: we want it to look nice.--- Thus, we try wherever possible to use syntax defined in [1],--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather--- than C--'s bits8 .. bits64.------ We try to ensure that all information available in the abstract--- syntax is reproduced, or reproducible, in the concrete syntax.--- Data that is not in printed out can be reconstructed according to--- conventions used in the pretty printer. There are at least two such--- cases:---      1) if a value has wordRep type, the type is not appended in the---      output.---      2) MachOps that operate over wordRep type are printed in a---      C-style, rather than as their internal MachRep name.------ These conventions produce much more readable Cmm output.------ A useful example pass over Cmm is in nativeGen/MachCodeGen.hs----{-# LANGUAGE LambdaCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}--{-# OPTIONS_GHC -fno-warn-orphans #-}--module GHC.Cmm.Ppr.Expr-    ( pprExpr, pprLit-    )-where--import GHC.Prelude--import GHC.Platform-import GHC.Cmm.Expr--import GHC.Utils.Outputable-import GHC.Utils.Trace--import Data.Maybe-import Numeric ( fromRat )---------------------------------------------------------------------------------instance OutputableP Platform CmmExpr where-    pdoc = pprExpr--instance Outputable CmmReg where-    ppr e = pprReg e--instance OutputableP Platform CmmLit where-    pdoc = pprLit--instance Outputable LocalReg where-    ppr e = pprLocalReg e--instance Outputable Area where-    ppr e = pprArea e--instance Outputable GlobalReg where-    ppr e = pprGlobalReg e--instance OutputableP env GlobalReg where-    pdoc _ = ppr---- ----------------------------------------------------------------------------- Expressions-----pprExpr :: Platform -> CmmExpr -> SDoc-pprExpr platform e-    = case e of-        CmmRegOff reg i ->-                pprExpr platform (CmmMachOp (MO_Add rep)-                           [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])-                where rep = typeWidth (cmmRegType platform reg)-        CmmLit lit -> pprLit platform lit-        _other     -> pprExpr1 platform e---- Here's the precedence table from GHC.Cmm.Parser:--- %nonassoc '>=' '>' '<=' '<' '!=' '=='--- %left '|'--- %left '^'--- %left '&'--- %left '>>' '<<'--- %left '-' '+'--- %left '/' '*' '%'--- %right '~'---- We just cope with the common operators for now, the rest will get--- a default conservative behaviour.---- %nonassoc '>=' '>' '<=' '<' '!=' '=='-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--infixMachOp1 (MO_Eq     _) = Just (text "==")-infixMachOp1 (MO_Ne     _) = Just (text "!=")-infixMachOp1 (MO_Shl    _) = Just (text "<<")-infixMachOp1 (MO_U_Shr  _) = Just (text ">>")-infixMachOp1 (MO_U_Ge   _) = Just (text ">=")-infixMachOp1 (MO_U_Le   _) = Just (text "<=")-infixMachOp1 (MO_U_Gt   _) = Just (char '>')-infixMachOp1 (MO_U_Lt   _) = Just (char '<')-infixMachOp1 _             = Nothing---- %left '-' '+'-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 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 :: Platform -> CmmExpr -> SDoc-pprExpr9 platform e =-   case e of-        CmmLit    lit       -> pprLit1 platform lit-        CmmLoad   expr rep align-                            -> let align_mark =-                                       case align of-                                         NaturallyAligned -> empty-                                         Unaligned        -> text "^"-                                in ppr rep <> align_mark <> brackets (pdoc platform 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 platform mop args--genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc-genMachOp platform mop args-   | Just doc <- infixMachOp mop = case args of-        -- dyadic-        [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y--        -- unary-        [x]   -> doc <> pprExpr9 platform x--        _     -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args"-                          (pprMachOp mop <+>-                            parens (hcat $ punctuate comma (map (pprExpr platform) args)))-                          empty--   | isJust (infixMachOp1 mop)-   || isJust (infixMachOp7 mop)-   || isJust (infixMachOp8 mop)  = parens (pprExpr platform (CmmMachOp mop 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,------- Unsigned ops on the word size of the machine get nice symbols.--- All else get dumped in their ugly format.----infixMachOp :: MachOp -> Maybe SDoc-infixMachOp mop-        = case mop of-            MO_And    _ -> Just $ char '&'-            MO_Or     _ -> Just $ char '|'-            MO_Xor    _ -> Just $ char '^'-            MO_Not    _ -> Just $ char '~'-            MO_S_Neg  _ -> Just $ char '-' -- there is no unsigned neg :)-            _ -> Nothing---- ----------------------------------------------------------------------------- Literals.---  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 :: 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 platform) $-               space <> dcolon <+> ppr rep ]--    CmmFloat f rep     -> hsep [ double (fromRat f), dcolon, ppr rep ]-    CmmVec lits        -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'-    CmmLabel clbl      -> pdoc platform clbl-    CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i-    CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'-                                       <> pdoc platform clbl2 <> ppr_offset i-    CmmBlock id        -> ppr id-    CmmHighStackMark -> text "<highSp>"--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-    | i==0      = empty-    | i>=0      = char '+' <> int i-    | otherwise = char '-' <> int (-i)---- ----------------------------------------------------------------------------- Registers, whether local (temps) or global----pprReg :: CmmReg -> SDoc-pprReg r-    = case r of-        CmmLocal  local  -> pprLocalReg  local-        CmmGlobal global -> pprGlobalReg global------- We only print the type of the local reg if it isn't wordRep----pprLocalReg :: LocalReg -> SDoc-pprLocalReg (LocalReg uniq rep) =---   = ppr rep <> char '_' <> ppr uniq--- Temp Jan08-    char '_' <> pprUnique uniq <>-       (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08               -- sigh-                    then dcolon <> ptr <> ppr rep-                    else dcolon <> ptr <> ppr rep)-   where-     pprUnique unique = sdocOption sdocSuppressUniques $ \case-       True  -> text "_locVar_"-       False -> ppr unique-     ptr = empty-         --if isGcPtrType rep-         --      then doubleQuotes (text "ptr")-         --      else empty---- Stack areas-pprArea :: Area -> SDoc-pprArea Old        = text "old"-pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]---- needs to be kept in syn with 'GHC.Cmm.Expr.GlobalReg'----pprGlobalReg :: GlobalReg -> SDoc-pprGlobalReg gr-    = case gr of-        VanillaReg n _ -> char 'R' <> int n--- Temp Jan08---        VanillaReg n VNonGcPtr -> char 'R' <> int n---        VanillaReg n VGcPtr    -> char 'P' <> int n-        FloatReg   n   -> char 'F' <> int n-        DoubleReg  n   -> char 'D' <> int n-        LongReg    n   -> char 'L' <> int n-        XmmReg     n   -> text "XMM" <> int n-        YmmReg     n   -> text "YMM" <> int n-        ZmmReg     n   -> text "ZMM" <> int n-        Sp             -> text "Sp"-        SpLim          -> text "SpLim"-        Hp             -> text "Hp"-        HpLim          -> text "HpLim"-        MachSp         -> text "MachSp"-        UnwindReturnReg-> text "UnwindReturnReg"-        CCCS           -> text "CCCS"-        CurrentTSO     -> text "CurrentTSO"-        CurrentNursery -> text "CurrentNursery"-        HpAlloc        -> text "HpAlloc"-        EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"-        GCEnter1       -> text "stg_gc_enter_1"-        GCFun          -> text "stg_gc_fun"-        BaseReg        -> text "BaseReg"-        PicBaseReg     -> text "PicBaseReg"---------------------------------------------------------------------------------commafy :: [SDoc] -> SDoc-commafy xs = fsep $ punctuate comma xs

@@ -2,8 +2,6 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Cmm.ProcPoint     ( ProcPointSet, Status(..)     , callProcPoints, minimalProcPointSet@@ -17,7 +15,6 @@ 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

@@ -0,0 +1,224 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE MultiParamTypeClasses #-}++{-|+Module      : GHC.Cmm.Reducibility+Description : Tell if a `CmmGraph` is reducible, or make it so++Test a Cmm control-flow graph for reducibility.  And provide a+function that, when given an arbitrary control-flow graph, returns an+equivalent, reducible control-flow graph.  The equivalent graph is+obtained by "splitting" (copying) nodes of the original graph.+The resulting equivalent graph has the same dynamic behavior as the+original, but it is larger.++Documentation uses the language of control-flow analysis, in which a+basic block is called a "node."  These "nodes" are `CmmBlock`s or+equivalent; they have nothing to do with a `CmmNode`.++For more on reducibility and related analyses and algorithms, see+Note [Reducibility resources]+-}++module GHC.Cmm.Reducibility+  ( Reducibility(..)+  , reducibility++  , asReducible+  )+where++import GHC.Prelude hiding (splitAt, succ)++import Control.Monad+import Data.List (nub)+import Data.Maybe+import Data.Semigroup+import qualified Data.Sequence as Seq++import GHC.Cmm+import GHC.Cmm.BlockId+import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dominators+import GHC.Cmm.Dataflow.Graph hiding (addBlock)+import GHC.Cmm.Dataflow.Label+import GHC.Data.Graph.Collapse+import GHC.Data.Graph.Inductive.Graph+import GHC.Data.Graph.Inductive.PatriciaTree+import GHC.Types.Unique.Supply+import GHC.Utils.Panic++-- | Represents the result of a reducibility analysis.+data Reducibility = Reducible | Irreducible+  deriving (Eq, Show)++-- | Given a graph, say whether the graph is reducible.  The graph must+-- be bundled with a dominator analysis and a reverse postorder+-- numbering, as these results are needed to perform the test.++reducibility :: NonLocal node+             => GraphWithDominators node+             -> Reducibility+reducibility gwd =+    if all goodBlock blockmap then Reducible else Irreducible+  where goodBlock b = all (goodEdge (entryLabel b)) (successors b)+        goodEdge from to = rpnum to > rpnum from || to `dominates` from+        rpnum = gwdRPNumber gwd+        blockmap = graphMap $ gwd_graph gwd+        dominators = gwdDominatorsOf gwd+        dominates lbl blockname =+            lbl == blockname || dominatorsMember lbl (dominators blockname)++-- | Given a graph, return an equivalent reducible graph, by+-- "splitting" (copying) nodes if necessary.  The input+-- graph must be bundled with a dominator analysis and a reverse+-- postorder numbering.  The computation is monadic because when a+-- node is split, the new copy needs a fresh label.+--+-- Use this function whenever a downstream algorithm needs a reducible+-- control-flow graph.++asReducible :: GraphWithDominators CmmNode+            -> UniqSM (GraphWithDominators CmmNode)+asReducible gwd = case reducibility gwd of+                    Reducible -> return gwd+                    Irreducible -> assertReducible <$> nodeSplit gwd++assertReducible :: GraphWithDominators CmmNode -> GraphWithDominators CmmNode+assertReducible gwd = case reducibility gwd of+                        Reducible -> gwd+                        Irreducible -> panic "result not reducible"++----------------------------------------------------------------++-- | Split one or more nodes of the given graph, which must be+-- irreducible.++nodeSplit :: GraphWithDominators CmmNode+          -> UniqSM (GraphWithDominators CmmNode)+nodeSplit gwd =+    graphWithDominators <$> inflate (g_entry g) <$> runNullCollapse collapsed+  where g = gwd_graph gwd+        collapsed :: NullCollapseViz (Gr CmmSuper ())+        collapsed = collapseInductiveGraph (cgraphOfCmm g)++type CGraph = Gr CmmSuper ()++-- | Turn a collapsed supernode back into a control-flow graph+inflate :: Label -> CGraph -> CmmGraph+inflate entry cg = CmmGraph entry graph+  where graph = GMany NothingO body NothingO+        body :: LabelMap CmmBlock+        body = foldl (\map block -> mapInsert (entryLabel block) block map) mapEmpty $+               blocks super+        super = case labNodes cg of+                  [(_, s)] -> s+                  _ -> panic "graph given to `inflate` is not singleton"+++-- | Convert a `CmmGraph` into an inductive graph.+-- (The function coalesces duplicate edges into a single edge.)+cgraphOfCmm :: CmmGraph -> CGraph+cgraphOfCmm g = foldl' addSuccEdges (mkGraph cnodes []) blocks+   where blocks = zip [0..] $ revPostorderFrom (graphMap g) (g_entry g)+         cnodes = [(k, super block) | (k, block) <- blocks]+          where super block = Nodes (entryLabel block) (Seq.singleton block)+         labelNumber = \lbl -> fromJust $ mapLookup lbl numbers+             where numbers :: LabelMap Int+                   numbers = mapFromList $ map swap blocks+                   swap (k, block) = (entryLabel block, k)+         addSuccEdges :: CGraph -> (Node, CmmBlock) -> CGraph+         addSuccEdges graph (k, block) =+             insEdges [(k, labelNumber lbl, ()) | lbl <- nub $ successors block] graph+{-+Note [Reducibility resources]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++*Flow Analysis of Computer Programs.* Matthew S. Hecht North Holland, 1977.+Available to borrow from archive.org.++Matthew S. Hecht and Jeffrey D. Ullman (1972).+Flow Graph Reducibility. SIAM J. Comput., 1(2), 188–202.+https://doi.org/10.1137/0201014++Johan Janssen and Henk Corporaal. 1997. Making graphs reducible with+controlled node splitting. ACM TOPLAS 19, 6 (Nov. 1997),+1031–1052. DOI:https://doi.org/10.1145/267959.269971++Sebastian Unger and Frank Mueller. 2002. Handling irreducible loops:+optimized node splitting versus DJ-graphs. ACM TOPLAS 24, 4 (July+2002), 299–333. https://doi.org/10.1145/567097.567098.  (This one+contains the most detailed account of how the Hecht/Ullman algorithm+is used to modify an actual control-flow graph.  But still not much detail.)++https://rgrig.blogspot.com/2009/10/dtfloatleftclearleft-summary-of-some.html+ (Nice summary of useful facts)++-}++++type Seq = Seq.Seq++-- | A "supernode" contains a single-entry, multiple-exit, reducible subgraph.+-- The entry point is the given label, and the block with that label+-- dominates all the other blocks in the supernode.  When an entire+-- graph is collapsed into a single supernode, the graph is reducible.+-- More detail can be found in "GHC.Data.Graph.Collapse".++data CmmSuper+    = Nodes { label :: Label+            , blocks :: Seq CmmBlock+            }++instance Semigroup CmmSuper where+  s <> s' = Nodes (label s) (blocks s <> blocks s')++instance PureSupernode CmmSuper where+  superLabel = label+  mapLabels = changeLabels++instance Supernode CmmSuper NullCollapseViz where+  freshen s = liftUniqSM $ relabel s+++-- | Return all labels defined within a supernode.+definedLabels :: CmmSuper -> Seq Label+definedLabels = fmap entryLabel . blocks++++-- | Map the given function over every use and definition of a label+-- in the given supernode.+changeLabels :: (Label -> Label) -> (CmmSuper -> CmmSuper)+changeLabels f (Nodes l blocks) = Nodes (f l) (fmap (changeBlockLabels f) blocks)++-- | Map the given function over every use and definition of a label+-- in the given block.+changeBlockLabels :: (Label -> Label) -> CmmBlock -> CmmBlock+changeBlockLabels f block = blockJoin entry' middle exit'+  where (entry, middle, exit) = blockSplit block+        entry' = let CmmEntry l scope = entry+                 in  CmmEntry (f l) scope+        exit' = case exit of+                  -- unclear why mapSuccessors doesn't touch these+                  CmmCall { cml_cont = Just l } -> exit { cml_cont = Just (f l) }+                  CmmForeignCall { succ = l } -> exit { succ = f l }+                  _ -> mapSuccessors f exit+++-- | Within the given supernode, replace every defined label (and all+-- of its uses) with a fresh label.++relabel :: CmmSuper -> UniqSM CmmSuper+relabel node = do+     finite_map <- foldM addPair mapEmpty $ definedLabels node+     return $ changeLabels (labelChanger finite_map) node+  where addPair :: LabelMap Label -> Label -> UniqSM (LabelMap Label)+        addPair map old = do new <- newBlockId+                             return $ mapInsert old new map+        labelChanger :: LabelMap Label -> (Label -> Label)+        labelChanger mapping = \lbl -> mapFindWithDefault lbl lbl mapping

@@ -268,7 +268,7 @@   all_succs = concatMap successors blocks    succ_counts :: LabelMap Int-  succ_counts = foldr (\l -> mapInsertWith (+) l 1) mapEmpty all_succs+  succ_counts = foldl' (\acc l -> mapInsertWith (+) l 1 acc) mapEmpty all_succs  -- -- filter the list of assignments to remove any assignments that@@ -360,7 +360,7 @@     * The assignment `_c3 = [R1 + 1]`; (R1 already inlined on pickup)       conflicts with R1 = R1, because it reads `R1` and the node writes       to R1-    * This is clearly no-sensical because `R1 = R1` doesn't affect R1's value.+    * This is clearly nonsensical because `R1 = R1` doesn't affect R1's value.  The solutions is to check if we can discard nodes before and *after* simplifying them. We could only do it after as well, but I assume doing it early might save@@ -490,7 +490,7 @@           where (final_node, rest') = go usages live' node' (insertLRegSet l skipped) rest                  -- Avoid discarding of assignments to vars on the rhs.-                -- See Note [Keeping assignemnts mentioned in skipped RHSs]+                -- See Note [Keeping assignments mentioned in skipped RHSs]                 -- usages' = foldLocalRegsUsed platform (\m r -> addToUFM m r 2)                                             -- usages rhs                 live' = inline foldLocalRegsUsed platform (\m r -> insertLRegSet r m)@@ -518,7 +518,7 @@         inl_exp (CmmMachOp op args) = cmmMachOpFold platform op args         inl_exp other = other -{- Note [Keeping assignemnts mentioned in skipped RHSs]+{- Note [Keeping assignments mentioned in skipped RHSs]    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~     If we have to assignments: [z = y, y = e1] and we skip     z we *must* retain the assignment y = e1. This is because

@@ -0,0 +1,285 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}++-- | Annotate a CmmGraph with ThreadSanitizer instrumentation calls.+module GHC.Cmm.ThreadSanitizer (annotateTSAN) where++import GHC.Prelude++import GHC.StgToCmm.Utils (get_GlobalReg_addr)+import GHC.Platform+import GHC.Platform.Regs (activeStgRegs, callerSaves)+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Graph+import GHC.Data.FastString+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Unique+import GHC.Types.Unique.Supply++import Data.Maybe (fromMaybe)++data Env = Env { platform :: Platform+               , uniques :: [Unique]+               }++annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph+annotateTSAN platform graph = do+    env <- Env platform <$> getUniquesM+    return $ modifyGraph (mapGraphBlocks (annotateBlock env)) graph++mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')+             -> Block n e x -> Block n e x+mapBlockList f (BlockCO n rest  ) = f n `blockAppend` mapBlockList f rest+mapBlockList f (BlockCC n rest m) = f n `blockAppend` mapBlockList f rest `blockAppend` f m+mapBlockList f (BlockOC   rest m) = mapBlockList f rest `blockAppend` f m+mapBlockList _ BNil = BNil+mapBlockList f (BMiddle blk) = f blk+mapBlockList f (BCat a b) = mapBlockList f a `blockAppend` mapBlockList f b+mapBlockList f (BSnoc a n) = mapBlockList f a `blockAppend` f n+mapBlockList f (BCons n a) = f n `blockAppend` mapBlockList f a++annotateBlock :: Env -> Block CmmNode e x -> Block CmmNode e x+annotateBlock env = mapBlockList (annotateNode env)++annotateNode :: Env -> CmmNode e x -> Block CmmNode e x+annotateNode env node =+    case node of+      CmmEntry{}              -> BlockCO node BNil+      CmmComment{}            -> BMiddle node+      CmmTick{}               -> BMiddle node+      CmmUnwind{}             -> BMiddle node+      CmmAssign{}             -> annotateNodeOO env node+      CmmStore lhs rhs align  ->+          let ty = cmmExprType (platform env) rhs+              rhs_nodes = annotateLoads env (collectExprLoads rhs)+              lhs_nodes = annotateLoads env (collectExprLoads lhs)+              st        = tsanStore env align ty lhs+          in rhs_nodes `blockAppend` lhs_nodes `blockAppend` st `blockSnoc` node+      CmmUnsafeForeignCall (PrimTarget op) formals args ->+          let node' = fromMaybe (BMiddle node) (annotatePrim env op formals args)+              arg_nodes = blockConcat $ map (annotateExpr env) args+          in arg_nodes `blockAppend` node'+      CmmUnsafeForeignCall{}  -> annotateNodeOO env node+      CmmBranch{}             -> annotateNodeOC env node+      CmmCondBranch{}         -> annotateNodeOC env node+      CmmSwitch{}             -> annotateNodeOC env node+      CmmCall{}               -> annotateNodeOC env node+      CmmForeignCall{}        -> annotateNodeOC env node++annotateNodeOO :: Env -> CmmNode O O -> Block CmmNode O O+annotateNodeOO env node =+    annotateLoads env (collectLoadsNode node) `blockSnoc` node++annotateNodeOC :: Env -> CmmNode O C -> Block CmmNode O C+annotateNodeOC env node =+    annotateLoads env (collectLoadsNode node) `blockJoinTail` node++annotateExpr :: Env -> CmmExpr -> Block CmmNode O O+annotateExpr env expr =+    annotateLoads env (collectExprLoads expr)++data Load = Load CmmType AlignmentSpec CmmExpr++annotateLoads :: Env -> [Load] -> Block CmmNode O O+annotateLoads env loads =+    blockConcat+    [ tsanLoad env align ty addr+    | Load ty align addr <- loads+    ]++collectLoadsNode :: CmmNode e x -> [Load]+collectLoadsNode node =+    foldExp (\exp rest -> collectExprLoads exp ++ rest) node []++-- | Collect all of the memory locations loaded from by a 'CmmExpr'.+collectExprLoads :: CmmExpr -> [Load]+collectExprLoads (CmmLit _)           = []+collectExprLoads (CmmLoad e ty align) = [Load ty align e]+collectExprLoads (CmmReg _)           = []+collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args+collectExprLoads (CmmStackSlot _ _)   = []+collectExprLoads (CmmRegOff _ _)      = []++-- | Generate TSAN instrumentation for a 'CallishMachOp' occurrence.+annotatePrim :: Env+             -> CallishMachOp   -- ^ the applied operation+             -> [CmmFormal]     -- ^ results+             -> [CmmActual]     -- ^ arguments+             -> Maybe (Block CmmNode O O)+                                -- ^ 'Just' a block of instrumentation, if applicable+annotatePrim env (MO_AtomicRMW w aop)    [dest]   [addr, val] = Just $ tsanAtomicRMW env MemOrderSeqCst aop w addr val dest+annotatePrim env (MO_AtomicRead w mord)  [dest]   [addr]      = Just $ tsanAtomicLoad env mord w addr dest+annotatePrim env (MO_AtomicWrite w mord) []       [addr, val] = Just $ tsanAtomicStore env mord w val addr+annotatePrim env (MO_Xchg w)             [dest]   [addr, val] = Just $ tsanAtomicExchange env MemOrderSeqCst w val addr dest+annotatePrim env (MO_Cmpxchg w)          [dest]   [addr, expected, new]+                                                               = Just $ tsanAtomicCas env MemOrderSeqCst MemOrderSeqCst w addr expected new dest+annotatePrim _    _                       _        _           = Nothing++mkUnsafeCall :: Env+             -> ForeignTarget  -- ^ function+             -> [CmmFormal]    -- ^ results+             -> [CmmActual]    -- ^ arguments+             -> Block CmmNode O O+mkUnsafeCall env ftgt formals args =+    save `blockAppend`     -- save global registers+    bind_args `blockSnoc`  -- bind arguments to local registers+    call `blockAppend`     -- perform call+    restore                -- restore global registers+  where+    -- We are rather conservative here and just save/restore all GlobalRegs.+    (save, restore) = saveRestoreCallerRegs (platform env)++    -- We also must be careful not to mention caller-saved registers in+    -- arguments as Cmm-Lint checks this. To accomplish this we instead bind+    -- the arguments to local registers.+    arg_regs :: [CmmReg]+    arg_regs = zipWith arg_reg (uniques env) args+      where+        arg_reg :: Unique -> CmmExpr -> CmmReg+        arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr)++    bind_args :: Block CmmNode O O+    bind_args = blockConcat $ zipWith (\r e -> BMiddle $ CmmAssign r e) arg_regs args++    call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs)++saveRestoreCallerRegs :: Platform+                      -> (Block CmmNode O O, Block CmmNode O O)+saveRestoreCallerRegs platform =+    (save, restore)+  where+    regs = filter (callerSaves platform) (activeStgRegs platform)++    save = blockFromList (map saveReg regs)+    saveReg reg =+      CmmStore (get_GlobalReg_addr platform reg)+               (CmmReg (CmmGlobal reg))+               NaturallyAligned++    restore = blockFromList (map restoreReg regs)+    restoreReg reg =+      CmmAssign (CmmGlobal reg)+                (CmmLoad (get_GlobalReg_addr platform reg)+                         (globalRegType platform reg)+                         NaturallyAligned)++-- | Mirrors __tsan_memory_order+-- <https://github.com/llvm-mirror/compiler-rt/blob/master/include/sanitizer/tsan_interface_atomic.h#L32>+memoryOrderToTsanMemoryOrder :: Env -> MemoryOrdering -> CmmExpr+memoryOrderToTsanMemoryOrder env mord =+    mkIntExpr (platform env) n+  where+    n = case mord of+      MemOrderRelaxed -> 0+      MemOrderAcquire -> 2+      MemOrderRelease -> 3+      MemOrderSeqCst  -> 5++tsanTarget :: FastString     -- ^ function name+           -> [ForeignHint]  -- ^ formals+           -> [ForeignHint]  -- ^ arguments+           -> ForeignTarget+tsanTarget fn formals args =+    ForeignTarget (CmmLit (CmmLabel lbl)) conv+  where+    conv = ForeignConvention CCallConv args formals CmmMayReturn+    lbl = mkForeignLabel fn Nothing ForeignLabelInExternalPackage IsFunction++tsanStore :: Env+          -> AlignmentSpec -> CmmType -> CmmExpr+          -> Block CmmNode O O+tsanStore env align ty addr =+    mkUnsafeCall env ftarget [] [addr]+  where+    ftarget = tsanTarget fn [] [AddrHint]+    w = widthInBytes (typeWidth ty)+    fn = case align of+           Unaligned+             | w > 1    -> fsLit $ "__tsan_unaligned_write" ++ show w+           _            -> fsLit $ "__tsan_write" ++ show w++tsanLoad :: Env+         -> AlignmentSpec -> CmmType -> CmmExpr+         -> Block CmmNode O O+tsanLoad env align ty addr =+    mkUnsafeCall env ftarget [] [addr]+  where+    ftarget = tsanTarget fn [] [AddrHint]+    w = widthInBytes (typeWidth ty)+    fn = case align of+           Unaligned+             | w > 1    -> fsLit $ "__tsan_unaligned_read" ++ show w+           _            -> fsLit $ "__tsan_read" ++ show w++tsanAtomicStore :: Env+                -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr+                -> Block CmmNode O O+tsanAtomicStore env mord w val addr =+    mkUnsafeCall env ftarget [] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [] [AddrHint, NoHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_store"++tsanAtomicLoad :: Env+               -> MemoryOrdering -> Width -> CmmExpr -> LocalReg+               -> Block CmmNode O O+tsanAtomicLoad env mord w addr dest =+    mkUnsafeCall env ftarget [dest] [addr, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_load"++tsanAtomicExchange :: Env+                   -> MemoryOrdering -> Width -> CmmExpr -> CmmExpr -> LocalReg+                   -> Block CmmNode O O+tsanAtomicExchange env mord w val addr dest =+    mkUnsafeCall env ftarget [dest] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint]+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_exchange"++-- N.B. C11 CAS returns a boolean (to avoid the ABA problem) whereas Cmm's CAS+-- returns the expected value. We use define a shim in the RTS to provide+-- Cmm's semantics using the TSAN C11 primitive.+tsanAtomicCas :: Env+              -> MemoryOrdering  -- ^ success ordering+              -> MemoryOrdering  -- ^ failure ordering+              -> Width+              -> CmmExpr         -- ^ address+              -> CmmExpr         -- ^ expected value+              -> CmmExpr         -- ^ new value+              -> LocalReg        -- ^ result destination+              -> Block CmmNode O O+tsanAtomicCas env mord_success mord_failure w addr expected new dest =+    mkUnsafeCall env ftarget [dest] [addr, expected, new, mord_success', mord_failure']+  where+    mord_success' = memoryOrderToTsanMemoryOrder env mord_success+    mord_failure' = memoryOrderToTsanMemoryOrder env mord_failure+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint, NoHint, NoHint]+    fn = fsLit $ "ghc_tsan_atomic" ++ show (widthInBits w) ++ "_compare_exchange"++tsanAtomicRMW :: Env+              -> MemoryOrdering -> AtomicMachOp -> Width -> CmmExpr -> CmmExpr -> LocalReg+              -> Block CmmNode O O+tsanAtomicRMW env mord op w addr val dest =+    mkUnsafeCall env ftarget [dest] [addr, val, mord']+  where+    mord' = memoryOrderToTsanMemoryOrder env mord+    ftarget = tsanTarget fn [NoHint] [AddrHint, NoHint, NoHint]+    op' = case op of+           AMO_Add  -> "fetch_add"+           AMO_Sub  -> "fetch_sub"+           AMO_And  -> "fetch_and"+           AMO_Nand -> "fetch_nand"+           AMO_Or   -> "fetch_or"+           AMO_Xor  -> "fetch_xor"+    fn = fsLit $ "__tsan_atomic" ++ show (widthInBits w) ++ "_" ++ op'+

@@ -42,8 +42,6 @@          cmmMkAssign, -        isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,-         baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,         currentTSOExpr, currentNurseryExpr, cccsExpr, @@ -61,9 +59,9 @@         modifyGraph,          ofBlockMap, toBlockMap,-        ofBlockList, toBlockList, bodyToBlockList,+        ofBlockList, toBlockList,         toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,-        foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,+        foldlGraphBlocks, mapGraphNodes, mapGraphNodes1,          -- * Ticks         blockTicks@@ -199,9 +197,9 @@  -- | 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]))+  :: CLabel -> FilePath -> Int -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)+mkFileEmbedLit lbl path len+  = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path len]))   -- | Build a data-segment data block@@ -401,36 +399,6 @@  --------------------------------------------------- -----      CmmExpr predicates---------------------------------------------------------isTrivialCmmExpr :: CmmExpr -> Bool-isTrivialCmmExpr (CmmLoad _ _ _)    = False-isTrivialCmmExpr (CmmMachOp _ _)    = False-isTrivialCmmExpr (CmmLit _)         = True-isTrivialCmmExpr (CmmReg _)         = True-isTrivialCmmExpr (CmmRegOff _ _)    = True-isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"--hasNoGlobalRegs :: CmmExpr -> Bool-hasNoGlobalRegs (CmmLoad e _ _)            = hasNoGlobalRegs e-hasNoGlobalRegs (CmmMachOp _ es)           = all hasNoGlobalRegs es-hasNoGlobalRegs (CmmLit _)                 = True-hasNoGlobalRegs (CmmReg (CmmLocal _))      = True-hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True-hasNoGlobalRegs _ = False--isLit :: CmmExpr -> Bool-isLit (CmmLit _) = True-isLit _          = False--isComparisonExpr :: CmmExpr -> Bool-isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op-isComparisonExpr _                  = False-------------------------------------------------------- --      Tagging -- ---------------------------------------------------@@ -526,15 +494,9 @@ modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} -toBlockMap :: CmmGraph -> LabelMap CmmBlock-toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body- ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} -toBlockList :: CmmGraph -> [CmmBlock]-toBlockList g = mapElems $ toBlockMap g- -- | like 'toBlockList', but the entry block always comes first toBlockListEntryFirst :: CmmGraph -> [CmmBlock] toBlockListEntryFirst g@@ -579,9 +541,6 @@                                     , g_graph = GMany NothingO body NothingO }   where body = foldr addBlock emptyBody blocks -bodyToBlockList :: Body CmmNode -> [CmmBlock]-bodyToBlockList body = mapElems body- mapGraphNodes :: ( CmmNode C O -> CmmNode C O                  , CmmNode O O -> CmmNode O O                  , CmmNode O C -> CmmNode O C)@@ -596,10 +555,6 @@  foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g--revPostorder :: CmmGraph -> [CmmBlock]-revPostorder g = {-# SCC "revPostorder" #-}-    revPostorderFrom (toBlockMap g) (g_entry g)  ------------------------------------------------- -- Tick utilities

@@ -15,8 +15,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Native code generator -- -- The native-code generator has machine-independent and@@ -78,11 +76,12 @@    ) where -import GHC.Prelude+import GHC.Prelude hiding (head)  import qualified GHC.CmmToAsm.X86   as X86 import qualified GHC.CmmToAsm.PPC   as PPC import qualified GHC.CmmToAsm.AArch64 as AArch64+import qualified GHC.CmmToAsm.Wasm as Wasm32  import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear                as Linear@@ -116,7 +115,6 @@ 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@@ -126,11 +124,9 @@ import GHC.Utils.Misc import GHC.Utils.Logger -import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain ( massert ) import GHC.Utils.Error import GHC.Utils.Exception (evaluate) import GHC.Utils.Constants (debugIsOn)@@ -140,18 +136,21 @@ import GHC.Unit import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream+import GHC.Settings -import Data.List (sortBy, groupBy)+import Data.List (sortBy)+import Data.List.NonEmpty (groupAllWith, head) import Data.Maybe import Data.Ord         ( comparing ) import Control.Monad import System.IO+import System.Directory ( getCurrentDirectory )  ---------------------nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply+nativeCodeGen :: forall a . Logger -> ToolSettings -> NCGConfig -> ModLocation -> Handle -> UniqSupply               -> Stream IO RawCmmGroup a               -> IO a-nativeCodeGen logger config modLoc h us cmms+nativeCodeGen logger ts config modLoc h us cmms  = let platform = ncgPlatform config        nCG' :: ( OutputableP Platform statics, Outputable jumpDest, Instruction instr)             => NcgImpl statics instr jumpDest -> IO a@@ -168,8 +167,10 @@       ArchMipseb    -> panic "nativeCodeGen: No NCG for mipseb"       ArchMipsel    -> panic "nativeCodeGen: No NCG for mipsel"       ArchRISCV64   -> panic "nativeCodeGen: No NCG for RISCV64"+      ArchLoongArch64->panic "nativeCodeGen: No NCG for LoongArch64"       ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"       ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"+      ArchWasm32    -> Wasm32.ncgWasm platform ts us modLoc h cmms  -- | Data accumulated during code generation. Mostly about statistics, -- but also collects debug data for DWARF generation.@@ -243,16 +244,17 @@                 -> UniqSupply                 -> NativeGenAcc statics instr                 -> IO UniqSupply-finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs+finishNativeGen logger config modLoc bufh us ngs  = withTimingSilent logger (text "NCG") (`seq` ()) $ do         -- Write debug data and finish         us' <- if not (ncgDwarfEnabled config)                   then return us                   else do-                     (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)-                     emitNativeCode logger config bufh dwarf+                     compPath <- getCurrentDirectory+                     let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)+                         (dwarf_s, _)   = dwarfGen compPath config modLoc us (ngs_debug ngs)+                     emitNativeCode logger config bufh dwarf_h dwarf_s                      return us'-        bFlush bufh          -- dump global NCG stats for graph coloring allocator         let stats = concat (ngs_colorStats ngs)@@ -285,8 +287,9 @@          -- write out the imports         let ctx = ncgAsmContext config-        printSDocLn ctx Pretty.LeftMode h-                $ makeImportsDoc config (concat (ngs_imports ngs))+        bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs))+        bFlush bufh+         return us'   where     dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify)@@ -333,7 +336,7 @@                   dbgMap = debugToMap ndbgs                -- Generate native code-              (ngs',us') <- cmmNativeGens logger config modLoc ncgImpl h+              (ngs',us') <- cmmNativeGens logger config ncgImpl h                                           dbgMap us cmms ngs 0                -- Link native code information into debug blocks@@ -357,7 +360,6 @@                  (OutputableP Platform statics, Outputable jumpDest, Instruction instr)               => Logger               -> NCGConfig-              -> ModLocation               -> NcgImpl statics instr jumpDest               -> BufHandle               -> LabelMap DebugBlock@@ -367,7 +369,7 @@               -> Int               -> IO (NativeGenAcc statics instr, UniqSupply) -cmmNativeGens logger config modLoc ncgImpl h dbgMap = go+cmmNativeGens logger config ncgImpl h dbgMap = go   where     go :: UniqSupply -> [RawCmmDecl]        -> NativeGenAcc statics instr -> Int@@ -380,7 +382,7 @@         let fileIds = ngs_dwarfFiles ngs         (us', fileIds', native, imports, colorStats, linearStats, unwinds)           <- {-# SCC "cmmNativeGen" #-}-             cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap+             cmmNativeGen logger ncgImpl us fileIds dbgMap                           cmm count          -- Generate .file directives for every new file that has been@@ -389,16 +391,21 @@         let newFileIds = sortBy (comparing snd) $                          nonDetEltsUFM $ fileIds' `minusUFM` fileIds             -- See Note [Unique Determinism and code generation]-            pprDecl (f,n) = text "\t.file " <> ppr n <+>-                            pprFilePathString (unpackFS f)+            pprDecl (f,n) = line $ text "\t.file " <> int n <+>+                                   pprFilePathString (unpackFS f) -        emitNativeCode logger config h $ vcat $-          map pprDecl newFileIds ++-          map (pprNatCmmDecl ncgImpl) native+        -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad+        emitNativeCode logger config h+          (vcat $+           map pprDecl newFileIds +++           map (pprNatCmmDeclH ncgImpl) native)+          (vcat $+           map pprDecl newFileIds +++           map (pprNatCmmDeclS ncgImpl) native)          -- force evaluation all this stuff to avoid space leaks         let platform = ncgPlatform config-        {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pdoc platform) imports) ()+        {-# SCC "seqString" #-} evaluate $ seqList (showSDocUnsafe $ vcat $ map (pprAsmLabel platform) imports) ()          let !labels' = if ncgDwarfEnabled config                        then cmmDebugLabels isMetaInstr native else []@@ -417,11 +424,11 @@         go us' cmms ngs' (count + 1)  -emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO ()-emitNativeCode logger config h sdoc = do-+-- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad+emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO ()+emitNativeCode logger config h hdoc sdoc = do         let ctx = ncgAsmContext config-        {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc+        {-# SCC "pprNativeCode" #-} bPutHDoc h ctx hdoc          -- dump native code         putDumpFileMaybe logger@@ -434,7 +441,6 @@ cmmNativeGen     :: forall statics instr jumpDest. (Instruction instr, OutputableP Platform statics, Outputable jumpDest)     => Logger-    -> ModLocation     -> NcgImpl statics instr jumpDest         -> UniqSupply         -> DwarfFiles@@ -450,14 +456,14 @@                 , LabelMap [UnwindPoint]                    -- unwinding information for blocks                 ) -cmmNativeGen logger modLoc ncgImpl us fileIds dbgMap cmm count+cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count  = do         let config   = ncgConfig ncgImpl         let platform = ncgPlatform config         let weights  = ncgCfgWeights config          let proc_name = case cmm of-                (CmmProc _ entry_label _ _) -> pdoc platform entry_label+                (CmmProc _ entry_label _ _) -> pprAsmLabel platform entry_label                 _                           -> text "DataChunk"          -- rewrite assignments to global regs@@ -480,13 +486,13 @@         -- generate native code from cmm         let ((native, lastMinuteImports, fileIds', nativeCfgWeights), usGen) =                 {-# SCC "genMachCode" #-}-                initUs us $ genMachCode config modLoc+                initUs us $ genMachCode config                                         (cmmTopCodeGen ncgImpl)                                         fileIds dbgMap opt_cmm cmmCfg          putDumpFileMaybe logger                 Opt_D_dump_asm_native "Native code" FormatASM-                (vcat $ map (pprNatCmmDecl ncgImpl) native)+                (vcat $ map (pprNatCmmDeclS ncgImpl) native)          maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name @@ -543,7 +549,7 @@                 putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM-                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)+                        (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)                  putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"@@ -587,7 +593,7 @@                 putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM-                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)+                        (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)                  let mPprStats =                         if logHasDumpFlag logger Opt_D_dump_asm_stats@@ -649,14 +655,13 @@                                 text "cfg not in lockstep") ()          ---- sequence blocks-        -- sequenced :: [NatCmmDecl statics instr]-        let (sequenced, us_seq) =-                        {-# SCC "sequenceBlocks" #-}-                        initUs usAlloc $ mapM (BlockLayout.sequenceTop-                                ncgImpl optimizedCFG)-                            shorted--        massert (checkLayout shorted sequenced)+        let sequenced :: [NatCmmDecl statics instr]+            sequenced =+                checkLayout shorted $+                {-# SCC "sequenceBlocks" #-}+                map (BlockLayout.sequenceTop+                        ncgImpl optimizedCFG)+                    shorted          let branchOpt :: [NatCmmDecl statics instr]             branchOpt =@@ -679,7 +684,7 @@                 addUnwind acc proc =                     acc `mapUnion` computeUnwinding config ncgImpl proc -        return  ( us_seq+        return  ( usAlloc                 , fileIds'                 , branchOpt                 , lastMinuteImports ++ imports@@ -699,10 +704,10 @@  -- | Make sure all blocks we want the layout algorithm to place have been placed. checkLayout :: [NatCmmDecl statics instr] -> [NatCmmDecl statics instr]-            -> Bool+            -> [NatCmmDecl statics instr] checkLayout procsUnsequenced procsSequenced =         assertPpr (setNull diff) (text "Block sequencing dropped blocks:" <> ppr diff)-        True+        procsSequenced   where         blocks1 = foldl' (setUnion) setEmpty $                         map getBlockIds procsUnsequenced :: LabelSet@@ -740,7 +745,7 @@  -- | Build a doc for all the imports. ---makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc+makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc makeImportsDoc config imports  = dyld_stubs imports             $$@@ -748,7 +753,7 @@             -- dead-stripping of code and data on a per-symbol basis.             -- There's a hack to make this work in PprMach.pprNatCmmDecl.             (if platformHasSubsectionsViaSymbols platform-             then text ".subsections_via_symbols"+             then line $ text ".subsections_via_symbols"              else Outputable.empty)             $$                 -- On recent GNU ELF systems one can mark an object file@@ -758,14 +763,14 @@                 -- 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 platform "progbits"+             then line $ text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"              else Outputable.empty)             $$                 -- And just because every other compiler does, let's stick in                 -- an identifier directive: .ident "GHC x.y.z"             (if platformHasIdentDirective platform              then let compilerIdent = text "GHC" <+> text cProjectVersion-                   in text ".ident" <+> doubleQuotes compilerIdent+                   in line $ text ".ident" <+> doubleQuotes compilerIdent              else Outputable.empty)   where@@ -773,26 +778,23 @@          -- Generate "symbol stubs" for all external symbols that might         -- come from a dynamic library.-        dyld_stubs :: [CLabel] -> SDoc-{-      dyld_stubs imps = vcat $ map pprDyldSymbolStub $-                                    map head $ group $ sort imps-}+        dyld_stubs :: [CLabel] -> HDoc         -- (Hack) sometimes two Labels pretty-print the same, but have         -- different uniques; so we compare their text versions...         dyld_stubs imps                 | needImportedSymbols config                 = vcat $                         (pprGotDeclaration config :) $-                        map ( pprImportedSymbol config . fst . head) $-                        groupBy (\(_,a) (_,b) -> a == b) $-                        sortBy (\(_,a) (_,b) -> compare a b) $+                        fmap (pprImportedSymbol config . fst . head) $+                        groupAllWith snd $                         map doPpr $                         imps                 | otherwise                 = Outputable.empty -        doPpr lbl = (lbl, renderWithContext+        doPpr lbl = (lbl, showSDocOneLine                               (ncgAsmContext config)-                              (pprCLabel platform AsmStyle lbl))+                              (pprAsmLabel platform lbl))  -- ----------------------------------------------------------------------------- -- Generate jump tables@@ -805,7 +807,7 @@ generateJumpTables ncgImpl xs = concatMap f xs     where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs           f p = [p]-          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)+          g (BasicBlock _ xs) = mapMaybe (generateJumpTableForInstr ncgImpl) xs  -- ----------------------------------------------------------------------------- -- Shortcut branches@@ -920,7 +922,6 @@  genMachCode         :: NCGConfig-        -> ModLocation         -> (RawCmmDecl -> NatM [NatCmmDecl statics instr])         -> DwarfFiles         -> LabelMap DebugBlock@@ -933,10 +934,10 @@                 , CFG                 ) -genMachCode config modLoc cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg+genMachCode config cmmTopCodeGen fileIds dbgMap cmm_top cmm_cfg   = do  { initial_us <- getUniqueSupplyM         ; let initial_st           = mkNatM_State initial_us 0 config-                                                  modLoc fileIds dbgMap cmm_cfg+                                                  fileIds dbgMap cmm_cfg               (new_tops, final_st) = initNat initial_st (cmmTopCodeGen cmm_top)               final_delta          = natm_delta final_st               final_imports        = natm_imports final_st