ghc-lib 9.8.5.20250214 → 9.10.1.20240511

raw patch · 335 files changed

+24201/−16880 lines, 335 filesdep ~basedep ~deepseqdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

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

API changes (from Hackage documentation)

Files

• compiler/ClosureTypes.h +1/−0
• compiler/CodeGen.Platform.h +1/−0
• compiler/GHC.hs +5/−10
• compiler/GHC/Builtin/Names/TH.hs +69/−54
• compiler/GHC/Builtin/PrimOps/Casts.hs +0/−1
• compiler/GHC/Builtin/Types/Literals.hs +19/−19
• compiler/GHC/Builtin/Utils.hs +15/−20
• compiler/GHC/ByteCode/Asm.hs +69/−104
• compiler/GHC/ByteCode/InfoTable.hs +2/−2
• compiler/GHC/ByteCode/Instr.hs +7/−3
• compiler/GHC/ByteCode/Linker.hs +23/−54
• compiler/GHC/Cmm/CommonBlockElim.hs +1/−2
• compiler/GHC/Cmm/ContFlowOpt.hs +0/−2
• compiler/GHC/Cmm/Dataflow.hs +0/−5
• compiler/GHC/Cmm/DebugBlock.hs +2/−7
• compiler/GHC/Cmm/Dominators.hs +0/−1
• compiler/GHC/Cmm/GenericOpt.hs +222/−0
• compiler/GHC/Cmm/Graph.hs +1/−1
• compiler/GHC/Cmm/Info.hs +2/−3
• compiler/GHC/Cmm/Info/Build.hs +3/−8
• compiler/GHC/Cmm/LayoutStack.hs +2/−3
• compiler/GHC/Cmm/Lexer.x +1/−1
• compiler/GHC/Cmm/Lint.hs +0/−1
• compiler/GHC/Cmm/Liveness.hs +0/−4
• compiler/GHC/Cmm/Opt.hs +1/−18
• compiler/GHC/Cmm/Parser.y +27/−11
• compiler/GHC/Cmm/Pipeline.hs +3/−6
• compiler/GHC/Cmm/ProcPoint.hs +0/−2
• compiler/GHC/Cmm/Reducibility.hs +0/−1
• compiler/GHC/Cmm/Sink.hs +0/−1
• compiler/GHC/Cmm/ThreadSanitizer.hs +42/−35
• compiler/GHC/Cmm/Utils.hs +6/−10
• compiler/GHC/CmmToAsm.hs +18/−230
• compiler/GHC/CmmToAsm/AArch64.hs +0/−1
• compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +232/−111
• compiler/GHC/CmmToAsm/AArch64/Instr.hs +14/−67
• compiler/GHC/CmmToAsm/AArch64/Ppr.hs +3/−15
• compiler/GHC/CmmToAsm/AArch64/Regs.hs +9/−1
• compiler/GHC/CmmToAsm/BlockLayout.hs +3/−8
• compiler/GHC/CmmToAsm/CFG.hs +0/−2
• compiler/GHC/CmmToAsm/CFG/Dominators.hs +0/−4
• compiler/GHC/CmmToAsm/Dwarf.hs +0/−1
• compiler/GHC/CmmToAsm/Instr.hs +1/−7
• compiler/GHC/CmmToAsm/Monad.hs +0/−27
• compiler/GHC/CmmToAsm/PIC.hs +1/−1
• compiler/GHC/CmmToAsm/PPC.hs +0/−1
• compiler/GHC/CmmToAsm/PPC/CodeGen.hs +11/−6
• compiler/GHC/CmmToAsm/PPC/Instr.hs +0/−9
• compiler/GHC/CmmToAsm/PPC/Ppr.hs +0/−1
• compiler/GHC/CmmToAsm/Reg/Graph.hs +0/−5
• compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +1/−1
• compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +1/−7
• compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +0/−1
• compiler/GHC/CmmToAsm/Reg/Graph/Stats.hs +0/−5
• compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +7/−4
• compiler/GHC/CmmToAsm/Reg/Linear.hs +1/−3
• compiler/GHC/CmmToAsm/Reg/Linear/AArch64.hs +3/−3
• compiler/GHC/CmmToAsm/Reg/Linear/Base.hs +1/−1
• compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +1/−1
• compiler/GHC/CmmToAsm/Reg/Liveness.hs +9/−19
• compiler/GHC/CmmToAsm/Utils.hs +0/−1
• compiler/GHC/CmmToAsm/Wasm.hs +36/−9
• compiler/GHC/CmmToAsm/Wasm/Asm.hs +5/−2
• compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +4/−2
• compiler/GHC/CmmToAsm/X86.hs +0/−1
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +330/−116
• compiler/GHC/CmmToAsm/X86/Instr.hs +7/−14
• compiler/GHC/CmmToAsm/X86/Ppr.hs +17/−1
• compiler/GHC/CmmToAsm/X86/Regs.hs +1/−1
• compiler/GHC/CmmToC.hs +27/−8
• compiler/GHC/CmmToLlvm.hs +30/−2
• compiler/GHC/CmmToLlvm/Base.hs +2/−1
• compiler/GHC/CmmToLlvm/CodeGen.hs +17/−30
• compiler/GHC/CmmToLlvm/Version.hs +43/−0
• compiler/GHC/CmmToLlvm/Version/Bounds.hs +19/−0
• compiler/GHC/Core/LateCC.hs +76/−153
• compiler/GHC/Core/LateCC/OverloadedCalls.hs +204/−0
• compiler/GHC/Core/LateCC/TopLevelBinds.hs +106/−0
• compiler/GHC/Core/LateCC/Types.hs +74/−0
• compiler/GHC/Core/LateCC/Utils.hs +80/−0
• compiler/GHC/Core/Opt/CSE.hs +3/−3
• compiler/GHC/Core/Opt/CallArity.hs +0/−1
• compiler/GHC/Core/Opt/DmdAnal.hs +8/−8
• compiler/GHC/Core/Opt/Exitify.hs +12/−8
• compiler/GHC/Core/Opt/FloatIn.hs +57/−11
• compiler/GHC/Core/Opt/FloatOut.hs +2/−2
• compiler/GHC/Core/Opt/Pipeline.hs +9/−4
• compiler/GHC/Core/Opt/SetLevels.hs +87/−51
• compiler/GHC/Core/Opt/SpecConstr.hs +258/−199
• compiler/GHC/Core/Opt/Specialise.hs +1/−2
• compiler/GHC/Core/Opt/WorkWrap.hs +2/−3
• compiler/GHC/Core/Opt/WorkWrap/Utils.hs +0/−1
• compiler/GHC/CoreToStg.hs +52/−42
• compiler/GHC/CoreToStg/Prep.hs +2527/−2280
• compiler/GHC/Data/Bitmap.hs +0/−2
• compiler/GHC/Data/Graph/Collapse.hs +2/−2
• compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs +0/−2
• compiler/GHC/Driver/Config/CmmToAsm.hs +2/−1
• compiler/GHC/Driver/Config/CmmToLlvm.hs +1/−0
• compiler/GHC/Driver/Config/Core/Opt/LiberateCase.hs +1/−1
• compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +0/−35
• compiler/GHC/Driver/Config/CoreToStg/Prep.hs +7/−2
• compiler/GHC/Driver/Config/HsToCore.hs +1/−1
• compiler/GHC/Driver/Config/Linker.hs +81/−1
• compiler/GHC/Driver/Config/StgToCmm.hs +3/−1
• compiler/GHC/Driver/Config/StgToJS.hs +19/−0
• compiler/GHC/Driver/Config/Tidy.hs +1/−0
• compiler/GHC/Driver/GenerateCgIPEStub.hs +1/−2
• compiler/GHC/Driver/Main.hs +86/−68
• compiler/GHC/Driver/Make.hs +31/−46
• compiler/GHC/Driver/MakeSem.hs +1/−1
• compiler/GHC/Driver/Pipeline.hs +25/−27
• compiler/GHC/Driver/Pipeline/Execute.hs +30/−69
• compiler/GHC/Hs/Syn/Type.hs +10/−8
• compiler/GHC/HsToCore.hs +7/−1
• compiler/GHC/HsToCore/Arrows.hs +22/−23
• compiler/GHC/HsToCore/Binds.hs +187/−49
• compiler/GHC/HsToCore/Breakpoints.hs +7/−0
• compiler/GHC/HsToCore/Docs.hs +27/−11
• compiler/GHC/HsToCore/Expr.hs +143/−38
• compiler/GHC/HsToCore/Foreign/C.hs +0/−1
• compiler/GHC/HsToCore/Foreign/Call.hs +0/−1
• compiler/GHC/HsToCore/Foreign/Decl.hs +28/−12
• compiler/GHC/HsToCore/Foreign/JavaScript.hs +14/−18
• compiler/GHC/HsToCore/Foreign/Utils.hs +1/−2
• compiler/GHC/HsToCore/Foreign/Wasm.hs +724/−0
• compiler/GHC/HsToCore/GuardedRHSs.hs +3/−4
• compiler/GHC/HsToCore/ListComp.hs +2/−3
• compiler/GHC/HsToCore/Match.hs +94/−87
• compiler/GHC/HsToCore/Match.hs-boot +6/−4
• compiler/GHC/HsToCore/Match/Constructor.hs +21/−25
• compiler/GHC/HsToCore/Match/Literal.hs +10/−11
• compiler/GHC/HsToCore/Monad.hs +50/−21
• compiler/GHC/HsToCore/Pmc.hs +101/−15
• compiler/GHC/HsToCore/Pmc/Check.hs +19/−1
• compiler/GHC/HsToCore/Pmc/Desugar.hs +4/−2
• compiler/GHC/HsToCore/Pmc/Solver.hs +1/−3
• compiler/GHC/HsToCore/Pmc/Utils.hs +13/−11
• compiler/GHC/HsToCore/Quote.hs +92/−46
• compiler/GHC/HsToCore/Ticks.hs +85/−55
• compiler/GHC/HsToCore/Usage.hs +1/−1
• compiler/GHC/HsToCore/Utils.hs +38/−26
• compiler/GHC/Iface/Ext/Ast.hs +236/−160
• compiler/GHC/Iface/Ext/Binary.hs +0/−2
• compiler/GHC/Iface/Ext/Utils.hs +16/−17
• compiler/GHC/Iface/Load.hs +2/−4
• compiler/GHC/Iface/Make.hs +7/−5
• compiler/GHC/Iface/Recomp.hs +0/−1
• compiler/GHC/Iface/Recomp/Flags.hs +1/−4
• compiler/GHC/Iface/Rename.hs +3/−2
• compiler/GHC/Iface/Tidy.hs +54/−22
• compiler/GHC/IfaceToCore.hs +22/−14
• compiler/GHC/JS/Opt/Expr.hs +186/−0
• compiler/GHC/JS/Opt/Simple.hs +607/−0
• compiler/GHC/JS/Optimizer.hs +57/−16
• compiler/GHC/Linker/Config.hs +0/−13
• compiler/GHC/Linker/Deps.hs +4/−9
• compiler/GHC/Linker/Dynamic.hs +6/−4
• compiler/GHC/Linker/External.hs +26/−0
• compiler/GHC/Linker/ExtraObj.hs +1/−13
• compiler/GHC/Linker/Loader.hs +58/−45
• compiler/GHC/Linker/MacOS.hs +2/−2
• compiler/GHC/Linker/Static.hs +8/−8
• compiler/GHC/Llvm.hs +4/−0
• compiler/GHC/Llvm/MetaData.hs +51/−1
• compiler/GHC/Llvm/Ppr.hs +1/−0
• compiler/GHC/Rename/Bind.hs +71/−37
• compiler/GHC/Rename/Env.hs +143/−172
• compiler/GHC/Rename/Expr.hs +196/−134
• compiler/GHC/Rename/Expr.hs-boot +1/−1
• compiler/GHC/Rename/Fixity.hs +45/−14
• compiler/GHC/Rename/HsType.hs +236/−158
• compiler/GHC/Rename/Module.hs +54/−51
• compiler/GHC/Rename/Names.hs +65/−52
• compiler/GHC/Rename/Pat.hs +544/−86
• compiler/GHC/Rename/Splice.hs +129/−23
• compiler/GHC/Rename/Splice.hs-boot +5/−0
• compiler/GHC/Rename/Utils.hs +221/−33
• compiler/GHC/Runtime/Eval.hs +11/−23
• compiler/GHC/Runtime/Heap/Inspect.hs +5/−6
• compiler/GHC/Runtime/Interpreter.hs +36/−86
• compiler/GHC/Runtime/Interpreter/JS.hs +43/−19
• compiler/GHC/Settings/IO.hs +20/−46
• compiler/GHC/Stg/BcPrep.hs +2/−2
• compiler/GHC/Stg/CSE.hs +11/−2
• compiler/GHC/Stg/Debug.hs +19/−15
• compiler/GHC/Stg/FVs.hs +2/−2
• compiler/GHC/Stg/InferTags.hs +16/−11
• compiler/GHC/Stg/InferTags/Rewrite.hs +38/−22
• compiler/GHC/Stg/Lift/Analysis.hs +5/−5
• compiler/GHC/Stg/Lift/Monad.hs +0/−1
• compiler/GHC/Stg/Lint.hs +10/−19
• compiler/GHC/Stg/Pipeline.hs +3/−0
• compiler/GHC/Stg/Subst.hs +2/−2
• compiler/GHC/Stg/Unarise.hs +48/−40
• compiler/GHC/Stg/Utils.hs +0/−1
• compiler/GHC/StgToByteCode.hs +123/−123
• compiler/GHC/StgToCmm.hs +4/−10
• compiler/GHC/StgToCmm/ArgRep.hs +8/−5
• compiler/GHC/StgToCmm/Bind.hs +86/−25
• compiler/GHC/StgToCmm/CgUtils.hs +0/−1
• compiler/GHC/StgToCmm/Closure.hs +15/−19
• compiler/GHC/StgToCmm/DataCon.hs +0/−1
• compiler/GHC/StgToCmm/Env.hs +2/−3
• compiler/GHC/StgToCmm/Expr.hs +149/−80
• compiler/GHC/StgToCmm/InfoTableProv.hs +13/−10
• compiler/GHC/StgToCmm/Layout.hs +9/−17
• compiler/GHC/StgToCmm/Lit.hs +0/−1
• compiler/GHC/StgToCmm/Monad.hs +1/−1
• compiler/GHC/StgToCmm/Prim.hs +116/−10
• compiler/GHC/StgToCmm/Prof.hs +62/−25
• compiler/GHC/StgToCmm/TagCheck.hs +5/−6
• compiler/GHC/StgToCmm/Ticky.hs +24/−16
• compiler/GHC/StgToCmm/Utils.hs +25/−1
• compiler/GHC/StgToJS/Apply.hs +526/−458
• compiler/GHC/StgToJS/Arg.hs +23/−21
• compiler/GHC/StgToJS/Closure.hs +41/−34
• compiler/GHC/StgToJS/CodeGen.hs +29/−35
• compiler/GHC/StgToJS/DataCon.hs +19/−18
• compiler/GHC/StgToJS/Deps.hs +6/−7
• compiler/GHC/StgToJS/Expr.hs +155/−143
• compiler/GHC/StgToJS/ExprCtx.hs +37/−14
• compiler/GHC/StgToJS/FFI.hs +24/−29
• compiler/GHC/StgToJS/Heap.hs +27/−27
• compiler/GHC/StgToJS/Ids.hs +12/−11
• compiler/GHC/StgToJS/Linker/Linker.hs +276/−194
• compiler/GHC/StgToJS/Linker/Opt.hs +2/−1
• compiler/GHC/StgToJS/Linker/Utils.hs +25/−59
• compiler/GHC/StgToJS/Literal.hs +10/−27
• compiler/GHC/StgToJS/Monad.hs +7/−7
• compiler/GHC/StgToJS/Prim.hs +1669/−1584
• compiler/GHC/StgToJS/Profiling.hs +40/−30
• compiler/GHC/StgToJS/Regs.hs +20/−10
• compiler/GHC/StgToJS/Rts/Rts.hs +475/−410
• compiler/GHC/StgToJS/Rts/Types.hs +23/−22
• compiler/GHC/StgToJS/Sinker.hs +2/−2
• compiler/GHC/StgToJS/Stack.hs +30/−29
• compiler/GHC/StgToJS/StaticPtr.hs +4/−5
• compiler/GHC/StgToJS/Utils.hs +117/−257
• compiler/GHC/SysTools.hs +0/−3
• compiler/GHC/SysTools/Cpp.hs +35/−19
• compiler/GHC/SysTools/Info.hs +0/−243
• compiler/GHC/SysTools/Process.hs +5/−6
• compiler/GHC/SysTools/Tasks.hs +56/−127
• compiler/GHC/Tc/Deriv.hs +17/−10
• compiler/GHC/Tc/Deriv/Functor.hs +3/−3
• compiler/GHC/Tc/Deriv/Generate.hs +54/−75
• compiler/GHC/Tc/Deriv/Generics.hs +0/−1
• compiler/GHC/Tc/Deriv/Infer.hs +0/−1
• compiler/GHC/Tc/Deriv/Utils.hs +10/−4
• compiler/GHC/Tc/Errors.hs +51/−115
• compiler/GHC/Tc/Errors/Hole.hs +4/−7
• compiler/GHC/Tc/Gen/App.hs +745/−137
• compiler/GHC/Tc/Gen/Arrow.hs +29/−39
• compiler/GHC/Tc/Gen/Bind.hs +257/−143
• compiler/GHC/Tc/Gen/Do.hs +492/−0
• compiler/GHC/Tc/Gen/Export.hs +18/−17
• compiler/GHC/Tc/Gen/Expr.hs +285/−149
• compiler/GHC/Tc/Gen/Expr.hs-boot +4/−1
• compiler/GHC/Tc/Gen/Foreign.hs +7/−17
• compiler/GHC/Tc/Gen/Head.hs +495/−321
• compiler/GHC/Tc/Gen/HsType.hs +357/−169
• compiler/GHC/Tc/Gen/Match.hs +236/−178
• compiler/GHC/Tc/Gen/Match.hs-boot +14/−10
• compiler/GHC/Tc/Gen/Pat.hs +275/−52
• compiler/GHC/Tc/Gen/Sig.hs +37/−64
• compiler/GHC/Tc/Gen/Splice.hs +24/−13
• compiler/GHC/Tc/Gen/Splice.hs-boot +3/−2
• compiler/GHC/Tc/Instance/Class.hs +362/−11
• compiler/GHC/Tc/Instance/Family.hs +1/−2
• compiler/GHC/Tc/Instance/FunDeps.hs +2/−2
• compiler/GHC/Tc/Instance/Typeable.hs +5/−8
• compiler/GHC/Tc/Module.hs +6/−14
• compiler/GHC/Tc/Solver.hs +126/−73
• compiler/GHC/Tc/Solver/Dict.hs +61/−37
• compiler/GHC/Tc/Solver/Equality.hs +108/−51
• compiler/GHC/Tc/Solver/Monad.hs +57/−29
• compiler/GHC/Tc/Solver/Rewrite.hs +0/−5
• compiler/GHC/Tc/Solver/Solve.hs +0/−1
• compiler/GHC/Tc/TyCl.hs +14/−19
• compiler/GHC/Tc/TyCl/Build.hs +3/−1
• compiler/GHC/Tc/TyCl/Class.hs +6/−7
• compiler/GHC/Tc/TyCl/Instance.hs +16/−30
• compiler/GHC/Tc/TyCl/PatSyn.hs +45/−62
• compiler/GHC/Tc/TyCl/Utils.hs +22/−19
• compiler/GHC/Tc/Types/EvTerm.hs +4/−6
• compiler/GHC/Tc/Utils/Backpack.hs +2/−3
• compiler/GHC/Tc/Utils/Concrete.hs +60/−21
• compiler/GHC/Tc/Utils/Env.hs +35/−12
• compiler/GHC/Tc/Utils/Instantiate.hs +56/−26
• compiler/GHC/Tc/Utils/Monad.hs +19/−26
• compiler/GHC/Tc/Utils/TcMType.hs +161/−29
• compiler/GHC/Tc/Utils/TcMType.hs-boot +8/−0
• compiler/GHC/Tc/Utils/Unify.hs +1861/−1682
• compiler/GHC/Tc/Validity.hs +146/−21
• compiler/GHC/Tc/Zonk/Env.hs +1/−1
• compiler/GHC/Tc/Zonk/Type.hs +55/−37
• compiler/GHC/ThToHs.hs +84/−72
• compiler/GHC/Utils/Touch.hs +34/−0
• compiler/GHC/Utils/Unique.hs +8/−8
• compiler/GHC/Wasm/ControlFlow/FromCmm.hs +1/−2
• compiler/MachRegs.h +15/−599
• compiler/ghc-llvm-version.h +0/−11
• ghc-lib.cabal +39/−22
• ghc-lib/stage0/compiler/build/GHC/Platform/Constants.hs +55/−51
• ghc-lib/stage0/compiler/build/primop-can-fail.hs-incl +0/−261
• ghc-lib/stage0/compiler/build/primop-code-size.hs-incl +4/−2
• ghc-lib/stage0/compiler/build/primop-commutable.hs-incl +1/−1
• ghc-lib/stage0/compiler/build/primop-data-decl.hs-incl +49/−1
• ghc-lib/stage0/compiler/build/primop-docs.hs-incl +51/−3
• ghc-lib/stage0/compiler/build/primop-effects.hs-incl +410/−0
• ghc-lib/stage0/compiler/build/primop-fixity.hs-incl +1/−1
• ghc-lib/stage0/compiler/build/primop-has-side-effects.hs-incl +0/−261
• ghc-lib/stage0/compiler/build/primop-is-cheap.hs-incl +3/−0
• ghc-lib/stage0/compiler/build/primop-is-work-free.hs-incl +8/−0
• ghc-lib/stage0/compiler/build/primop-list.hs-incl +49/−1
• ghc-lib/stage0/compiler/build/primop-out-of-line.hs-incl +1/−1
• ghc-lib/stage0/compiler/build/primop-primop-info.hs-incl +50/−2
• ghc-lib/stage0/compiler/build/primop-strictness.hs-incl +4/−3
• ghc-lib/stage0/compiler/build/primop-tag.hs-incl +1375/−1327
• ghc-lib/stage0/lib/llvm-passes +3/−3
• ghc-lib/stage0/lib/settings +13/−15
• ghc-lib/stage0/rts/build/include/GhclibDerivedConstants.h +38/−20
• ghc-lib/stage0/rts/build/include/ghcautoconf.h +6/−62
• ghc-lib/stage0/rts/build/include/ghcplatform.h +14/−15
• libraries/ghci/GHCi/BinaryArray.hs +0/−78
• libraries/ghci/GHCi/ResolvedBCO.hs +0/−77
• rts/include/stg/MachRegs/arm32.h +60/−0
• rts/include/stg/MachRegs/arm64.h +64/−0
• rts/include/stg/MachRegs/loongarch64.h +51/−0
• rts/include/stg/MachRegs/ppc.h +65/−0
• rts/include/stg/MachRegs/riscv64.h +61/−0
• rts/include/stg/MachRegs/s390x.h +72/−0
• rts/include/stg/MachRegs/wasm32.h +35/−0
• rts/include/stg/MachRegs/x86.h +210/−0

@@ -16,6 +16,7 @@  *   - the closure flags table in rts/ClosureFlags.c  *   - isRetainer in rts/RetainerProfile.c  *   - the closure_type_names list in rts/Printer.c+ *   - the ClosureType sum type in libraries/ghc-internal/src/GHC/Internal/ClosureTypes.hs  */  /* CONSTR/THUNK/FUN_$A_$B mean they have $A pointers followed by $B

@@ -480,6 +480,7 @@  #endif +-- See also Note [Caller saves and callee-saves regs.] callerSaves :: GlobalReg -> Bool #if defined(CALLER_SAVES_Base) callerSaves BaseReg           = True

@@ -359,9 +359,6 @@ import GHC.Utils.Misc import GHC.Utils.Outputable import GHC.Utils.Panic-#if !defined(javascript_HOST_ARCH)-import GHC.Utils.Panic.Plain-#endif import GHC.Utils.Logger import GHC.Utils.Fingerprint @@ -397,7 +394,6 @@ import GHC.Types.TypeEnv import GHC.Types.BreakInfo import GHC.Types.PkgQual-import GHC.Types.Unique.FM  import GHC.Unit import GHC.Unit.Env@@ -677,7 +673,6 @@ setTopSessionDynFlags dflags = do   hsc_env <- getSession   logger  <- getLogger-  lookup_cache  <- liftIO $ newMVar emptyUFM    -- Interpreter   interp <- if@@ -707,7 +702,7 @@             }          s <- liftIO $ newMVar InterpPending          loader <- liftIO Loader.uninitializedLoader-         return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader lookup_cache))+         return (Just (Interp (ExternalInterp (ExtIServ (ExtInterpState conf s))) loader))      -- JavaScript interpreter     | ArchJavaScript <- platformArch (targetPlatform dflags)@@ -725,7 +720,7 @@               , jsInterpFinderOpts  = initFinderOpts dflags               , jsInterpFinderCache = hsc_FC hsc_env               }-         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader lookup_cache))+         return (Just (Interp (ExternalInterp (ExtJS (ExtInterpState cfg s))) loader))      -- Internal interpreter     | otherwise@@ -733,7 +728,7 @@ #if defined(HAVE_INTERNAL_INTERPRETER)      do       loader <- liftIO Loader.uninitializedLoader-      return (Just (Interp InternalInterp loader lookup_cache))+      return (Just (Interp InternalInterp loader)) #else       return Nothing #endif@@ -1162,7 +1157,7 @@  type ParsedSource      = Located (HsModule GhcPs) type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],-                          Maybe (LHsDoc GhcRn))+                          Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)) type TypecheckedSource = LHsBinds GhcTc  -- NOTE:@@ -1997,6 +1992,6 @@   #if !defined(javascript_HOST_ARCH)-foreign import ccall unsafe "ghc_lib_parser_keepCAFsForGHCi"+foreign import ccall unsafe "keepCAFsForGHCi"     c_keepCAFsForGHCi   :: IO Bool #endif

@@ -47,6 +47,7 @@     litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName,     conPName, tildePName, bangPName, infixPName,     asPName, wildPName, recPName, listPName, sigPName, viewPName,+    typePName, invisPName,     -- FieldPat     fieldPatName,     -- Match@@ -61,6 +62,7 @@     fromEName, fromThenEName, fromToEName, fromThenToEName,     listEName, sigEName, recConEName, recUpdEName, staticEName, unboundVarEName,     labelEName, implicitParamVarEName, getFieldEName, projectionEName,+    typeEName,     -- FieldExp     fieldExpName,     -- Body@@ -74,10 +76,11 @@     classDName, instanceWithOverlapDName,     standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,     pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,-    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,+    pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,+    defaultSigDName, defaultDName,     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,     dataInstDName, newtypeInstDName, tySynInstDName,-    infixLDName, infixRDName, infixNDName,+    infixLWithSpecDName, infixRWithSpecDName, infixNWithSpecDName,     roleAnnotDName, patSynDName, patSynSigDName,     implicitParamBindDName,     -- Cxt@@ -138,6 +141,9 @@     -- Overlap     overlappableDataConName, overlappingDataConName, overlapsDataConName,     incoherentDataConName,+    -- NamespaceSpecifier+    noNamespaceSpecifierDataConName, typeNamespaceSpecifierDataConName,+    dataNamespaceSpecifierDataConName,     -- DerivStrategy     stockStrategyName, anyclassStrategyName,     newtypeStrategyName, viaStrategyName,@@ -156,7 +162,8 @@     liftClassName, quoteClassName,      -- And the tycons-    qTyConName, nameTyConName, patTyConName, fieldPatTyConName, matchTyConName,+    qTyConName, nameTyConName, patTyConName,+    fieldPatTyConName, matchTyConName,     expQTyConName, fieldExpTyConName, predTyConName,     stmtTyConName,  decsTyConName, conTyConName, bangTypeTyConName,     varBangTypeTyConName, typeQTyConName, expTyConName, decTyConName,@@ -268,7 +275,7 @@ -- data Pat = ... litPName, varPName, tupPName, unboxedTupPName, unboxedSumPName, conPName,     infixPName, tildePName, bangPName, asPName, wildPName, recPName, listPName,-    sigPName, viewPName :: Name+    sigPName, viewPName, typePName, invisPName :: Name litPName   = libFun (fsLit "litP")   litPIdKey varPName   = libFun (fsLit "varP")   varPIdKey tupPName   = libFun (fsLit "tupP")   tupPIdKey@@ -284,6 +291,8 @@ listPName  = libFun (fsLit "listP")  listPIdKey sigPName   = libFun (fsLit "sigP")   sigPIdKey viewPName  = libFun (fsLit "viewP")  viewPIdKey+typePName  = libFun (fsLit "typeP")  typePIdKey+invisPName = libFun (fsLit "invisP")  invisPIdKey  -- type FieldPat = ... fieldPatName :: Name@@ -302,7 +311,7 @@     sectionLName, sectionRName, lamEName, lamCaseEName, lamCasesEName, tupEName,     unboxedTupEName, unboxedSumEName, condEName, multiIfEName, letEName,     caseEName, doEName, mdoEName, compEName, staticEName, unboundVarEName,-    labelEName, implicitParamVarEName, getFieldEName, projectionEName :: Name+    labelEName, implicitParamVarEName, getFieldEName, projectionEName, typeEName :: Name varEName              = libFun (fsLit "varE")              varEIdKey conEName              = libFun (fsLit "conE")              conEIdKey litEName              = libFun (fsLit "litE")              litEIdKey@@ -343,6 +352,7 @@ implicitParamVarEName = libFun (fsLit "implicitParamVarE") implicitParamVarEIdKey getFieldEName         = libFun (fsLit "getFieldE")         getFieldEIdKey projectionEName       = libFun (fsLit "projectionE")       projectionEIdKey+typeEName             = libFun (fsLit "typeE")             typeEIdKey  -- type FieldExp = ... fieldExpName :: Name@@ -370,11 +380,12 @@ funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,     instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,-    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,+    pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,+    standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,-    openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,-    infixNDName, roleAnnotDName, patSynDName, patSynSigDName,-    pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name+    openTypeFamilyDName, closedTypeFamilyDName, infixLWithSpecDName,+    infixRWithSpecDName, infixNWithSpecDName, roleAnnotDName, patSynDName,+    patSynSigDName, pragCompleteDName, implicitParamBindDName, pragOpaqueDName :: Name funDName                         = libFun (fsLit "funD")                         funDIdKey valDName                         = libFun (fsLit "valD")                         valDIdKey dataDName                        = libFun (fsLit "dataD")                        dataDIdKey@@ -397,15 +408,17 @@ pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey+pragSCCFunDName                  = libFun (fsLit "pragSCCFunD")                  pragSCCFunDKey+pragSCCFunNamedDName             = libFun (fsLit "pragSCCFunNamedD")             pragSCCFunNamedDKey dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey openTypeFamilyDName              = libFun (fsLit "openTypeFamilyD")              openTypeFamilyDIdKey closedTypeFamilyDName            = libFun (fsLit "closedTypeFamilyD")            closedTypeFamilyDIdKey dataFamilyDName                  = libFun (fsLit "dataFamilyD")                  dataFamilyDIdKey-infixLDName                      = libFun (fsLit "infixLD")                      infixLDIdKey-infixRDName                      = libFun (fsLit "infixRD")                      infixRDIdKey-infixNDName                      = libFun (fsLit "infixND")                      infixNDIdKey+infixLWithSpecDName              = libFun (fsLit "infixLWithSpecD")              infixLWithSpecDIdKey+infixRWithSpecDName              = libFun (fsLit "infixRWithSpecD")              infixRWithSpecDIdKey+infixNWithSpecDName              = libFun (fsLit "infixNWithSpecD")              infixNWithSpecDIdKey roleAnnotDName                   = libFun (fsLit "roleAnnotD")                   roleAnnotDIdKey patSynDName                      = libFun (fsLit "patSynD")                      patSynDIdKey patSynSigDName                   = libFun (fsLit "patSynSigD")                   patSynSigDIdKey@@ -647,6 +660,17 @@ overlapsDataConName     = thCon (fsLit "Overlaps")     overlapsDataConKey incoherentDataConName   = thCon (fsLit "Incoherent")   incoherentDataConKey +-- data NamespaceSpecifier = ...+noNamespaceSpecifierDataConName,+  typeNamespaceSpecifierDataConName,+  dataNamespaceSpecifierDataConName :: Name+noNamespaceSpecifierDataConName =+  thCon (fsLit "NoNamespaceSpecifier") noNamespaceSpecifierDataConKey+typeNamespaceSpecifierDataConName =+  thCon (fsLit "TypeNamespaceSpecifier") typeNamespaceSpecifierDataConKey+dataNamespaceSpecifierDataConName =+  thCon (fsLit "DataNamespaceSpecifier") dataNamespaceSpecifierDataConKey+ {- ********************************************************************* *                                                                      *                      Class keys@@ -754,6 +778,13 @@ overlapsDataConKey     = mkPreludeDataConUnique 211 incoherentDataConKey   = mkPreludeDataConUnique 212 +-- data NamespaceSpecifier = ...+noNamespaceSpecifierDataConKey,+  typeNamespaceSpecifierDataConKey,+  dataNamespaceSpecifierDataConKey :: Unique+noNamespaceSpecifierDataConKey = mkPreludeDataConUnique 213+typeNamespaceSpecifierDataConKey = mkPreludeDataConUnique 214+dataNamespaceSpecifierDataConKey = mkPreludeDataConUnique 215 {- ********************************************************************* *                                                                      *                      Id keys@@ -808,7 +839,7 @@ -- data Pat = ... litPIdKey, varPIdKey, tupPIdKey, unboxedTupPIdKey, unboxedSumPIdKey, conPIdKey,   infixPIdKey, tildePIdKey, bangPIdKey, asPIdKey, wildPIdKey, recPIdKey,-  listPIdKey, sigPIdKey, viewPIdKey :: Unique+  listPIdKey, sigPIdKey, viewPIdKey, typePIdKey, invisPIdKey :: Unique litPIdKey         = mkPreludeMiscIdUnique 240 varPIdKey         = mkPreludeMiscIdUnique 241 tupPIdKey         = mkPreludeMiscIdUnique 242@@ -824,6 +855,8 @@ listPIdKey        = mkPreludeMiscIdUnique 252 sigPIdKey         = mkPreludeMiscIdUnique 253 viewPIdKey        = mkPreludeMiscIdUnique 254+typePIdKey        = mkPreludeMiscIdUnique 255+invisPIdKey       = mkPreludeMiscIdUnique 256  -- type FieldPat = ... fieldPatIdKey :: Unique@@ -846,7 +879,7 @@     fromEIdKey, fromThenEIdKey, fromToEIdKey, fromThenToEIdKey,     listEIdKey, sigEIdKey, recConEIdKey, recUpdEIdKey, staticEIdKey,     unboundVarEIdKey, labelEIdKey, implicitParamVarEIdKey, mdoEIdKey,-    getFieldEIdKey, projectionEIdKey :: Unique+    getFieldEIdKey, projectionEIdKey, typeEIdKey :: Unique varEIdKey              = mkPreludeMiscIdUnique 270 conEIdKey              = mkPreludeMiscIdUnique 271 litEIdKey              = mkPreludeMiscIdUnique 272@@ -856,7 +889,7 @@ infixAppIdKey          = mkPreludeMiscIdUnique 276 sectionLIdKey          = mkPreludeMiscIdUnique 277 sectionRIdKey          = mkPreludeMiscIdUnique 278-lamEIdKey              = mkPreludeMiscIdUnique 279+lamEIdKey           = mkPreludeMiscIdUnique 279 lamCaseEIdKey          = mkPreludeMiscIdUnique 280 lamCasesEIdKey         = mkPreludeMiscIdUnique 281 tupEIdKey              = mkPreludeMiscIdUnique 282@@ -883,28 +916,29 @@ mdoEIdKey              = mkPreludeMiscIdUnique 303 getFieldEIdKey         = mkPreludeMiscIdUnique 304 projectionEIdKey       = mkPreludeMiscIdUnique 305+typeEIdKey             = mkPreludeMiscIdUnique 306  -- type FieldExp = ... fieldExpIdKey :: Unique-fieldExpIdKey       = mkPreludeMiscIdUnique 306+fieldExpIdKey       = mkPreludeMiscIdUnique 307  -- data Body = ... guardedBIdKey, normalBIdKey :: Unique-guardedBIdKey     = mkPreludeMiscIdUnique 307-normalBIdKey      = mkPreludeMiscIdUnique 308+guardedBIdKey     = mkPreludeMiscIdUnique 308+normalBIdKey      = mkPreludeMiscIdUnique 309  -- data Guard = ... normalGEIdKey, patGEIdKey :: Unique-normalGEIdKey     = mkPreludeMiscIdUnique 309-patGEIdKey        = mkPreludeMiscIdUnique 310+normalGEIdKey     = mkPreludeMiscIdUnique 310+patGEIdKey        = mkPreludeMiscIdUnique 311  -- data Stmt = ... bindSIdKey, letSIdKey, noBindSIdKey, parSIdKey, recSIdKey :: Unique-bindSIdKey       = mkPreludeMiscIdUnique 311-letSIdKey        = mkPreludeMiscIdUnique 312-noBindSIdKey     = mkPreludeMiscIdUnique 313-parSIdKey        = mkPreludeMiscIdUnique 314-recSIdKey        = mkPreludeMiscIdUnique 315+bindSIdKey       = mkPreludeMiscIdUnique 312+letSIdKey        = mkPreludeMiscIdUnique 313+noBindSIdKey     = mkPreludeMiscIdUnique 314+parSIdKey        = mkPreludeMiscIdUnique 315+recSIdKey        = mkPreludeMiscIdUnique 316  -- data Dec = ... funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,@@ -913,9 +947,10 @@     pragRuleDIdKey, pragAnnDIdKey, defaultSigDIdKey, dataFamilyDIdKey,     openTypeFamilyDIdKey, closedTypeFamilyDIdKey, dataInstDIdKey,     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,-    infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,-    patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,-    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique+    infixLWithSpecDIdKey, infixRWithSpecDIdKey, infixNWithSpecDIdKey,+    roleAnnotDIdKey, patSynDIdKey, patSynSigDIdKey, pragCompleteDIdKey,+    implicitParamBindDIdKey, kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey,+    typeDataDIdKey, pragSCCFunDKey, pragSCCFunNamedDKey :: Unique funDIdKey                         = mkPreludeMiscIdUnique 320 valDIdKey                         = mkPreludeMiscIdUnique 321 dataDIdKey                        = mkPreludeMiscIdUnique 322@@ -938,9 +973,9 @@ newtypeInstDIdKey                 = mkPreludeMiscIdUnique 339 tySynInstDIdKey                   = mkPreludeMiscIdUnique 340 closedTypeFamilyDIdKey            = mkPreludeMiscIdUnique 341-infixLDIdKey                      = mkPreludeMiscIdUnique 342-infixRDIdKey                      = mkPreludeMiscIdUnique 343-infixNDIdKey                      = mkPreludeMiscIdUnique 344+infixLWithSpecDIdKey              = mkPreludeMiscIdUnique 342+infixRWithSpecDIdKey              = mkPreludeMiscIdUnique 343+infixNWithSpecDIdKey              = mkPreludeMiscIdUnique 344 roleAnnotDIdKey                   = mkPreludeMiscIdUnique 345 standaloneDerivWithStrategyDIdKey = mkPreludeMiscIdUnique 346 defaultSigDIdKey                  = mkPreludeMiscIdUnique 347@@ -952,6 +987,8 @@ defaultDIdKey                     = mkPreludeMiscIdUnique 353 pragOpaqueDIdKey                  = mkPreludeMiscIdUnique 354 typeDataDIdKey                    = mkPreludeMiscIdUnique 355+pragSCCFunDKey                    = mkPreludeMiscIdUnique 356+pragSCCFunNamedDKey               = mkPreludeMiscIdUnique 357  -- type Cxt = ... cxtIdKey :: Unique@@ -1147,29 +1184,7 @@ ************************************************************************ -} -lift_RDR, liftTyped_RDR, mkNameG_dRDR, mkNameG_vRDR, mkNameG_fldRDR,-  unsafeCodeCoerce_RDR :: RdrName+lift_RDR, liftTyped_RDR, unsafeCodeCoerce_RDR :: RdrName lift_RDR     = nameRdrName liftName liftTyped_RDR = nameRdrName liftTypedName unsafeCodeCoerce_RDR = nameRdrName unsafeCodeCoerceName-mkNameG_dRDR = nameRdrName mkNameG_dName-mkNameG_vRDR = nameRdrName mkNameG_vName-mkNameG_fldRDR = nameRdrName mkNameG_fldName---- data Exp = ...-conE_RDR, litE_RDR, appE_RDR, infixApp_RDR :: RdrName-conE_RDR     = nameRdrName conEName-litE_RDR     = nameRdrName litEName-appE_RDR     = nameRdrName appEName-infixApp_RDR = nameRdrName infixAppName---- data Lit = ...-stringL_RDR, intPrimL_RDR, wordPrimL_RDR, floatPrimL_RDR,-    doublePrimL_RDR, stringPrimL_RDR, charPrimL_RDR :: RdrName-stringL_RDR     = nameRdrName stringLName-intPrimL_RDR    = nameRdrName intPrimLName-wordPrimL_RDR   = nameRdrName wordPrimLName-floatPrimL_RDR  = nameRdrName floatPrimLName-doublePrimL_RDR = nameRdrName doublePrimLName-stringPrimL_RDR = nameRdrName stringPrimLName-charPrimL_RDR   = nameRdrName charPrimLName

@@ -13,7 +13,6 @@ import GHC.Core.TyCon import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Types.RepType import GHC.Core.Type import GHC.Builtin.Types.Prim

@@ -40,10 +40,10 @@ import GHC.Builtin.Types import GHC.Builtin.Types.Prim  ( mkTemplateAnonTyConBinders ) import GHC.Builtin.Names-                  ( gHC_TYPELITS-                  , gHC_TYPELITS_INTERNAL-                  , gHC_TYPENATS-                  , gHC_TYPENATS_INTERNAL+                  ( gHC_INTERNAL_TYPELITS+                  , gHC_INTERNAL_TYPELITS_INTERNAL+                  , gHC_INTERNAL_TYPENATS+                  , gHC_INTERNAL_TYPENATS_INTERNAL                   , typeNatAddTyFamNameKey                   , typeNatMulTyFamNameKey                   , typeNatExpTyFamNameKey@@ -172,7 +172,7 @@     , sfInteractInert = interactInertAdd     }   where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "+")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "+")             typeNatAddTyFamNameKey typeNatAddTyCon  typeNatSubTyCon :: TyCon@@ -183,7 +183,7 @@     , sfInteractInert = interactInertSub     }   where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "-")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "-")             typeNatSubTyFamNameKey typeNatSubTyCon  typeNatMulTyCon :: TyCon@@ -194,7 +194,7 @@     , sfInteractInert = interactInertMul     }   where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "*")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "*")             typeNatMulTyFamNameKey typeNatMulTyCon  typeNatDivTyCon :: TyCon@@ -205,7 +205,7 @@     , sfInteractInert = interactInertDiv     }   where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Div")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Div")             typeNatDivTyFamNameKey typeNatDivTyCon  typeNatModTyCon :: TyCon@@ -216,7 +216,7 @@     , sfInteractInert = interactInertMod     }   where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Mod")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Mod")             typeNatModTyFamNameKey typeNatModTyCon  typeNatExpTyCon :: TyCon@@ -227,7 +227,7 @@     , sfInteractInert = interactInertExp     }   where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "^")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "^")                 typeNatExpTyFamNameKey typeNatExpTyCon  typeNatLogTyCon :: TyCon@@ -238,7 +238,7 @@     , sfInteractInert = interactInertLog     }   where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS (fsLit "Log2")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS (fsLit "Log2")             typeNatLogTyFamNameKey typeNatLogTyCon  @@ -254,7 +254,7 @@     NotInjective    where-  name = mkWiredInTyConName UserSyntax gHC_TYPENATS_INTERNAL (fsLit "CmpNat")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPENATS_INTERNAL (fsLit "CmpNat")                 typeNatCmpTyFamNameKey typeNatCmpTyCon   ops = BuiltInSynFamily     { sfMatchFam      = matchFamCmpNat@@ -273,7 +273,7 @@     NotInjective    where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpSymbol")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpSymbol")                 typeSymbolCmpTyFamNameKey typeSymbolCmpTyCon   ops = BuiltInSynFamily     { sfMatchFam      = matchFamCmpSymbol@@ -289,7 +289,7 @@     , sfInteractInert = interactInertAppendSymbol     }   where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "AppendSymbol")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "AppendSymbol")                 typeSymbolAppendFamNameKey typeSymbolAppendTyCon  typeConsSymbolTyCon :: TyCon@@ -302,7 +302,7 @@     Nothing     (Injective [True, True])   where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "ConsSymbol")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "ConsSymbol")                   typeConsSymbolTyFamNameKey typeConsSymbolTyCon   ops = BuiltInSynFamily       { sfMatchFam      = matchFamConsSymbol@@ -320,7 +320,7 @@     Nothing     (Injective [True])   where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "UnconsSymbol")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "UnconsSymbol")                   typeUnconsSymbolTyFamNameKey typeUnconsSymbolTyCon   ops = BuiltInSynFamily       { sfMatchFam      = matchFamUnconsSymbol@@ -338,7 +338,7 @@     Nothing     (Injective [True])   where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "CharToNat")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "CharToNat")                   typeCharToNatTyFamNameKey typeCharToNatTyCon   ops = BuiltInSynFamily       { sfMatchFam      = matchFamCharToNat@@ -357,7 +357,7 @@     Nothing     (Injective [True])   where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS (fsLit "NatToChar")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS (fsLit "NatToChar")                   typeNatToCharTyFamNameKey typeNatToCharTyCon   ops = BuiltInSynFamily       { sfMatchFam      = matchFamNatToChar@@ -1130,7 +1130,7 @@     Nothing     NotInjective   where-  name = mkWiredInTyConName UserSyntax gHC_TYPELITS_INTERNAL (fsLit "CmpChar")+  name = mkWiredInTyConName UserSyntax gHC_INTERNAL_TYPELITS_INTERNAL (fsLit "CmpChar")                   typeCharCmpTyFamNameKey typeCharCmpTyCon   ops = BuiltInSynFamily       { sfMatchFam      = matchFamCmpChar

@@ -67,7 +67,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Map import GHC.Types.TyThing-import GHC.Types.Unique ( isValidKnownKeyUnique )+import GHC.Types.Unique ( isValidKnownKeyUnique, pprUniqueAlways )  import GHC.Utils.Outputable import GHC.Utils.Misc as Utils@@ -79,7 +79,7 @@ import GHC.Data.List.SetOps  import Control.Applicative ((<|>))-import Data.List        ( intercalate , find )+import Data.List        ( find ) import Data.Maybe  {-@@ -116,12 +116,8 @@ knownKeyNames :: [Name] knownKeyNames   | debugIsOn-  , Just badNamesStr <- knownKeyNamesOkay all_names-  = panic ("badAllKnownKeyNames:\n" ++ badNamesStr)-       -- NB: We can't use ppr here, because this is sometimes evaluated in a-       -- context where there are no DynFlags available, leading to a cryptic-       -- "<<details unavailable>>" error. (This seems to happen only in the-       -- stage 2 compiler, for reasons I [Richard] have no clue of.)+  , Just badNamesDoc <- knownKeyNamesOkay all_names+  = pprPanic "badAllKnownKeyNames" badNamesDoc   | otherwise   = all_names   where@@ -161,16 +157,15 @@                         Nothing -> []  -- | Check the known-key names list of consistency.-knownKeyNamesOkay :: [Name] -> Maybe String+knownKeyNamesOkay :: [Name] -> Maybe SDoc knownKeyNamesOkay all_names   | ns@(_:_) <- filter (not . isValidKnownKeyUnique . getUnique) all_names-  = Just $ "    Out-of-range known-key uniques: ["-        ++ intercalate ", " (map (occNameString . nameOccName) ns) ++-         "]"+  = Just $ text "    Out-of-range known-key uniques: " <>+           brackets (pprWithCommas (ppr . nameOccName) ns)   | null badNamesPairs   = Nothing   | otherwise-  = Just badNamesStr+  = Just badNamesDoc   where     namesEnv      = foldl' (\m n -> extendNameEnv_Acc (:) Utils.singleton m n n)                            emptyUFM all_names@@ -178,14 +173,14 @@     badNamesPairs = nonDetUFMToList badNamesEnv       -- It's OK to use nonDetUFMToList here because the ordering only affects       -- the message when we get a panic-    badNamesStrs  = map pairToStr badNamesPairs-    badNamesStr   = unlines badNamesStrs+    badNamesDoc :: SDoc+    badNamesDoc  = vcat $ map pairToDoc badNamesPairs -    pairToStr (uniq, ns) = "        " ++-                           show uniq ++-                           ": [" ++-                           intercalate ", " (map (occNameString . nameOccName) ns) ++-                           "]"+    pairToDoc :: (Unique, [Name]) -> SDoc+    pairToDoc (uniq, ns) = text "        " <>+                           pprUniqueAlways uniq <>+                           text ": " <>+                           brackets (pprWithCommas (ppr . nameOccName) ns)  -- | Given a 'Unique' lookup its associated 'Name' if it corresponds to a -- known-key thing.

@@ -43,23 +43,19 @@ import GHC.Platform.Profile  import Control.Monad-import Control.Monad.ST ( runST ) import Control.Monad.Trans.Class import Control.Monad.Trans.State.Strict -import Data.Array.MArray- import qualified Data.Array.Unboxed as Array import Data.Array.Base  ( UArray(..) ) -import Data.Array.Unsafe( castSTUArray )- import Foreign hiding (shiftL, shiftR) import Data.Char        ( ord ) import Data.List        ( genericLength ) import Data.Map.Strict (Map) import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as Map+import GHC.Float (castFloatToWord32, castDoubleToWord64)  -- ----------------------------------------------------------------------------- -- Unlinked BCOs@@ -416,7 +412,7 @@                                                                 tuple_proto                                  p <- ioptr (liftM BCOPtrBCO ul_bco)                                  p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)-                                 info <- int (fromIntegral $+                                 info <- word (fromIntegral $                                               mkNativeCallInfoSig platform call_info)                                  emit bci_PUSH_ALTS_T                                       [Op p, Op info, Op p_tup]@@ -466,21 +462,21 @@                                  emit bci_TESTLT_W [Op np, LabelOp l]   TESTEQ_W  w l            -> do np <- word w                                  emit bci_TESTEQ_W [Op np, LabelOp l]-  TESTLT_I64  i l          -> do np <- int64 i+  TESTLT_I64  i l          -> do np <- word64 (fromIntegral i)                                  emit bci_TESTLT_I64 [Op np, LabelOp l]-  TESTEQ_I64  i l          -> do np <- int64 i+  TESTEQ_I64  i l          -> do np <- word64 (fromIntegral i)                                  emit bci_TESTEQ_I64 [Op np, LabelOp l]-  TESTLT_I32  i l          -> do np <- int (fromIntegral i)+  TESTLT_I32  i l          -> do np <- word (fromIntegral i)                                  emit bci_TESTLT_I32 [Op np, LabelOp l]-  TESTEQ_I32 i l           -> do np <- int (fromIntegral i)+  TESTEQ_I32 i l           -> do np <- word (fromIntegral i)                                  emit bci_TESTEQ_I32 [Op np, LabelOp l]-  TESTLT_I16  i l          -> do np <- int (fromIntegral i)+  TESTLT_I16  i l          -> do np <- word (fromIntegral i)                                  emit bci_TESTLT_I16 [Op np, LabelOp l]-  TESTEQ_I16 i l           -> do np <- int (fromIntegral i)+  TESTEQ_I16 i l           -> do np <- word (fromIntegral i)                                  emit bci_TESTEQ_I16 [Op np, LabelOp l]-  TESTLT_I8  i l           -> do np <- int (fromIntegral i)+  TESTLT_I8  i l           -> do np <- word (fromIntegral i)                                  emit bci_TESTLT_I8 [Op np, LabelOp l]-  TESTEQ_I8 i l            -> do np <- int (fromIntegral i)+  TESTEQ_I8 i l            -> do np <- word (fromIntegral i)                                  emit bci_TESTEQ_I8 [Op np, LabelOp l]   TESTLT_W64  w l          -> do np <- word64 w                                  emit bci_TESTLT_W64 [Op np, LabelOp l]@@ -517,7 +513,7 @@   CCALL off m_addr i       -> do np <- addr m_addr                                  emit bci_CCALL [wOp off, Op np, SmallOp i]   PRIMCALL                 -> emit bci_PRIMCALL []-  BRK_FUN index mod cc     -> do p1 <- ptr BCOPtrBreakArray+  BRK_FUN arr index mod cc -> do p1 <- ptr (BCOPtrBreakArray arr)                                  m <- addr mod                                  np <- addr cc                                  emit bci_BRK_FUN [Op p1, SmallOp index,@@ -530,43 +526,81 @@      -- On Windows, stdcall labels have a suffix indicating the no. of      -- arg words, e.g. foo@8.  testcase: ffi012(ghci)     literal (LitLabel fs _ _) = litlabel fs-    literal LitNullAddr       = int 0+    literal LitNullAddr       = word 0     literal (LitFloat r)      = float (fromRational r)     literal (LitDouble r)     = double (fromRational r)     literal (LitChar c)       = int (ord c)     literal (LitString bs)    = lit [BCONPtrStr bs]        -- LitString requires a zero-terminator when emitted     literal (LitNumber nt i) = case nt of-      LitNumInt     -> int (fromIntegral i)-      LitNumWord    -> int (fromIntegral i)-      LitNumInt8    -> int8 (fromIntegral i)-      LitNumWord8   -> int8 (fromIntegral i)-      LitNumInt16   -> int16 (fromIntegral i)-      LitNumWord16  -> int16 (fromIntegral i)-      LitNumInt32   -> int32 (fromIntegral i)-      LitNumWord32  -> int32 (fromIntegral i)-      LitNumInt64   -> int64 (fromIntegral i)-      LitNumWord64  -> int64 (fromIntegral i)+      LitNumInt     -> word (fromIntegral i)+      LitNumWord    -> word (fromIntegral i)+      LitNumInt8    -> word8 (fromIntegral i)+      LitNumWord8   -> word8 (fromIntegral i)+      LitNumInt16   -> word16 (fromIntegral i)+      LitNumWord16  -> word16 (fromIntegral i)+      LitNumInt32   -> word32 (fromIntegral i)+      LitNumWord32  -> word32 (fromIntegral i)+      LitNumInt64   -> word64 (fromIntegral i)+      LitNumWord64  -> word64 (fromIntegral i)       LitNumBigNat  -> panic "GHC.ByteCode.Asm.literal: LitNumBigNat"      -- We can lower 'LitRubbish' to an arbitrary constant, but @NULL@ is most     -- likely to elicit a crash (rather than corrupt memory) in case absence     -- analysis messed up.-    literal (LitRubbish {}) = int 0+    literal (LitRubbish {}) = word 0      litlabel fs = lit [BCONPtrLbl fs]     addr (RemotePtr a) = words [fromIntegral a]-    float = words . mkLitF platform-    double = words . mkLitD platform-    int = words . mkLitI-    int8 = words . mkLitI64 platform-    int16 = words . mkLitI64 platform-    int32 = words . mkLitI64 platform-    int64 = words . mkLitI64 platform-    word64 = words . mkLitW64 platform     words ws = lit (map BCONPtrWord ws)     word w = words [w]+    word_size  = platformWordSize platform+    word_size_bits = platformWordSizeInBits platform +    -- Make lists of host-sized words for literals, so that when the+    -- words are placed in memory at increasing addresses, the+    -- bit pattern is correct for the host's word size and endianness.+    --+    -- Note that we only support host endianness == target endianness for now,+    -- even with the external interpreter. This would need to be fixed to+    -- support host endianness /= target endianness+    int :: Int -> Assembler Word+    int  i = word (fromIntegral i)++    float :: Float -> Assembler Word+    float f = word32 (castFloatToWord32 f)++    double :: Double -> Assembler Word+    double d = word64 (castDoubleToWord64 d)++    word64 :: Word64 -> Assembler Word+    word64 ww = case word_size of+       PW4 ->+        let !wl = fromIntegral ww+            !wh = fromIntegral (ww `unsafeShiftR` 32)+        in case platformByteOrder platform of+            LittleEndian -> words [wl,wh]+            BigEndian    -> words [wh,wl]+       PW8 -> word (fromIntegral ww)++    word8 :: Word8 -> Assembler Word+    word8  x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8))++    word16 :: Word16 -> Assembler Word+    word16 x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16))++    word32 :: Word32 -> Assembler Word+    word32 x = case platformByteOrder platform of+      LittleEndian -> word (fromIntegral x)+      BigEndian    -> case word_size of+        PW4 -> word (fromIntegral x)+        PW8 -> word (fromIntegral x `unsafeShiftL` 32)++ isLargeW :: Word -> Bool isLargeW n = n > 65535 @@ -647,75 +681,6 @@ mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal mkNativeCallInfoLit platform call_info =   mkLitWord platform . fromIntegral $ mkNativeCallInfoSig platform call_info---- Make lists of host-sized words for literals, so that when the--- words are placed in memory at increasing addresses, the--- bit pattern is correct for the host's word size and endianness.-mkLitI   ::             Int    -> [Word]-mkLitF   :: Platform -> Float  -> [Word]-mkLitD   :: Platform -> Double -> [Word]-mkLitI64 :: Platform -> Int64  -> [Word]-mkLitW64 :: Platform -> Word64 -> [Word]--mkLitF platform f = case platformWordSize platform of-  PW4 -> runST $ do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 f-        f_arr <- castSTUArray arr-        w0 <- readArray f_arr 0-        return [w0 :: Word]--  PW8 -> runST $ do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 f-        -- on 64-bit architectures we read two (32-bit) Float cells when we read-        -- a (64-bit) Word: so we write a dummy value in the second cell to-        -- avoid an out-of-bound read.-        writeArray arr 1 0.0-        f_arr <- castSTUArray arr-        w0 <- readArray f_arr 0-        return [w0 :: Word]--mkLitD platform d = case platformWordSize platform of-   PW4 -> runST (do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 d-        d_arr <- castSTUArray arr-        w0 <- readArray d_arr 0-        w1 <- readArray d_arr 1-        return [w0 :: Word, w1]-     )-   PW8 -> runST (do-        arr <- newArray_ ((0::Int),0)-        writeArray arr 0 d-        d_arr <- castSTUArray arr-        w0 <- readArray d_arr 0-        return [w0 :: Word]-     )--mkLitI64 platform ii = case platformWordSize platform of-   PW4 -> runST (do-        arr <- newArray_ ((0::Int),1)-        writeArray arr 0 ii-        d_arr <- castSTUArray arr-        w0 <- readArray d_arr 0-        w1 <- readArray d_arr 1-        return [w0 :: Word,w1]-     )-   PW8 -> [fromIntegral ii :: Word]--mkLitW64 platform ww = case platformWordSize platform of-   PW4 -> runST (do-        arr <- newArray_ ((0::Word),1)-        writeArray arr 0 ww-        d_arr <- castSTUArray arr-        w0 <- readArray d_arr 0-        w1 <- readArray d_arr 1-        return [w0 :: Word,w1]-     )-   PW8 -> [fromIntegral ww :: Word]--mkLitI i = [fromIntegral i :: Word]  iNTERP_STACK_CHECK_THRESH :: Int iNTERP_STACK_CHECK_THRESH = INTERP_STACK_CHECK_THRESH

@@ -25,7 +25,7 @@ import GHC.Core.Multiplicity     ( scaledThing )  import GHC.StgToCmm.Layout  ( mkVirtConstrSizes )-import GHC.StgToCmm.Closure ( tagForCon, NonVoid (..) )+import GHC.StgToCmm.Closure ( tagForCon )  import GHC.Utils.Misc import GHC.Utils.Panic@@ -61,7 +61,7 @@  where   mk_itbl :: DataCon -> Int -> IO (Name,ItblPtr)   mk_itbl dcon conNo = do-     let rep_args = [ NonVoid prim_rep+     let rep_args = [ prim_rep                     | arg <- dataConRepArgTys dcon                     , prim_rep <- typePrimRep (scaledThing arg) ] 

@@ -30,6 +30,7 @@ import GHC.Stack.CCS (CostCentre)  import GHC.Stg.Syntax+import GHCi.BreakArray (BreakArray) import Language.Haskell.Syntax.Module.Name (ModuleName)  -- ----------------------------------------------------------------------------@@ -82,7 +83,7 @@    | PUSH16_W !ByteOff    | PUSH32_W !ByteOff -   -- Push a (heap) ptr  (these all map to PUSH_G really)+   -- Push a ptr  (these all map to PUSH_G really)    | PUSH_G       Name    | PUSH_PRIMOP  PrimOp    | PUSH_BCO     (ProtoBCO Name)@@ -205,7 +206,8 @@                    -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode     -- Breakpoints-   | BRK_FUN         !Word16 (RemotePtr ModuleName) (RemotePtr CostCentre)+   | BRK_FUN          (ForeignRef BreakArray) !Word16 (RemotePtr ModuleName)+                      (RemotePtr CostCentre)  -- ----------------------------------------------------------------------------- -- Printing bytecode instructions@@ -356,7 +358,9 @@    ppr ENTER                 = text "ENTER"    ppr (RETURN pk)           = text "RETURN  " <+> ppr pk    ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"-   ppr (BRK_FUN index _mod_name _cc) = text "BRK_FUN" <+> ppr index <+> text "<module>" <+> text "<cc>"+   ppr (BRK_FUN _ index _ _) = text "BRK_FUN" <+> text "<breakarray>"+                               <+> ppr index <+> text "<module>" <+> text "<cc>"+   -- -----------------------------------------------------------------------------

@@ -22,10 +22,8 @@ import GHC.ByteCode.Types import GHCi.RemoteTypes import GHCi.ResolvedBCO-import GHCi.BreakArray  import GHC.Builtin.PrimOps-import GHC.Builtin.PrimOps.Ids import GHC.Builtin.Names  import GHC.Unit.Types@@ -36,13 +34,10 @@ import GHC.Linker.Types  import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Outputable  import GHC.Types.Name import GHC.Types.Name.Env-import qualified GHC.Types.Id as Id-import GHC.Types.Unique.DFM  import Language.Haskell.Syntax.Module.Name @@ -57,33 +52,31 @@  linkBCO   :: Interp-  -> PkgsLoaded   -> LinkerEnv   -> NameEnv Int-  -> RemoteRef BreakArray   -> UnlinkedBCO   -> IO ResolvedBCO-linkBCO interp pkgs_loaded le bco_ix breakarray+linkBCO interp le bco_ix            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do   -- fromIntegral Word -> Word64 should be a no op if Word is Word64   -- otherwise it will result in a cast to longlong on 32bit systems.-  lits <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (ssElts lits0)-  ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix breakarray) (ssElts ptrs0)+  lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)+  ptrs <- mapM (resolvePtr interp le bco_ix) (ssElts ptrs0)   return (ResolvedBCO isLittleEndian arity insns bitmap               (listArray (0, fromIntegral (sizeSS lits0)-1) lits)               (addListToSS emptySS ptrs)) -lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word-lookupLiteral interp pkgs_loaded le ptr = case ptr of+lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word+lookupLiteral interp le ptr = case ptr of   BCONPtrWord lit -> return lit   BCONPtrLbl  sym -> do     Ptr a# <- lookupStaticPtr interp sym     return (W# (int2Word# (addr2Int# a#)))   BCONPtrItbl nm -> do-    Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm+    Ptr a# <- lookupIE interp (itbl_env le) nm     return (W# (int2Word# (addr2Int# a#)))   BCONPtrAddr nm -> do-    Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm+    Ptr a# <- lookupAddr interp (addr_env le) nm     return (W# (int2Word# (addr2Int# a#)))   BCONPtrStr _ ->     -- should be eliminated during assembleBCOs@@ -97,19 +90,19 @@     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"                   (unpackFS addr_of_label_string) -lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())-lookupIE interp pkgs_loaded ie con_nm =+lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())+lookupIE interp ie con_nm =   case lookupNameEnv ie con_nm of     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))     Nothing -> do -- try looking up in the object files.        let sym_to_find1 = nameToCLabel con_nm "con_info"-       m <- lookupHsSymbol interp pkgs_loaded con_nm "con_info"+       m <- lookupSymbol interp sym_to_find1        case m of           Just addr -> return addr           Nothing              -> do -- perhaps a nullary constructor?                    let sym_to_find2 = nameToCLabel con_nm "static_info"-                   n <- lookupHsSymbol interp pkgs_loaded con_nm "static_info"+                   n <- lookupSymbol interp sym_to_find2                    case n of                       Just addr -> return addr                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"@@ -117,36 +110,34 @@                                        unpackFS sym_to_find2)  -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode-lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())-lookupAddr interp pkgs_loaded ae addr_nm = do+lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())+lookupAddr interp ae addr_nm = do   case lookupNameEnv ae addr_nm of     Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)     Nothing -> do -- try looking up in the object files.       let sym_to_find = nameToCLabel addr_nm "bytes"                           -- see Note [Bytes label] in GHC.Cmm.CLabel-      m <- lookupHsSymbol interp pkgs_loaded addr_nm "bytes"+      m <- lookupSymbol interp sym_to_find       case m of         Just ptr -> return ptr         Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"                      (unpackFS sym_to_find) -lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())-lookupPrimOp interp pkgs_loaded primop = do+lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())+lookupPrimOp interp primop = do   let sym_to_find = primopToCLabel primop "closure"-  m <- lookupHsSymbol interp pkgs_loaded (Id.idName $ primOpId primop) "closure"+  m <- lookupSymbol interp (mkFastString sym_to_find)   case m of     Just p -> return (toRemotePtr p)     Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find  resolvePtr   :: Interp-  -> PkgsLoaded   -> LinkerEnv   -> NameEnv Int-  -> RemoteRef BreakArray   -> BCOPtr   -> IO ResolvedBCOPtr-resolvePtr interp pkgs_loaded le bco_ix breakarray ptr = case ptr of+resolvePtr interp le bco_ix ptr = case ptr of   BCOPtrName nm     | Just ix <- lookupNameEnv bco_ix nm     -> return (ResolvedBCORef ix) -- ref to another BCO in this group@@ -158,41 +149,19 @@     -> assertPpr (isExternalName nm) (ppr nm) $        do           let sym_to_find = nameToCLabel nm "closure"-          m <- lookupHsSymbol interp pkgs_loaded nm "closure"+          m <- lookupSymbol interp sym_to_find           case m of             Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))             Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)    BCOPtrPrimOp op-    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op+    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op    BCOPtrBCO bco-    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix breakarray bco--  BCOPtrBreakArray-    -> return (ResolvedBCOPtrBreakArray breakarray)---- | Look up the address of a Haskell symbol in the currently--- loaded units.------ See Note [Looking up symbols in the relevant objects].-lookupHsSymbol :: Interp -> PkgsLoaded -> Name -> String -> IO (Maybe (Ptr ()))-lookupHsSymbol interp pkgs_loaded nm sym_suffix = do-  massertPpr (isExternalName nm) (ppr nm)-  let sym_to_find = nameToCLabel nm sym_suffix-      pkg_id = moduleUnitId $ nameModule nm-      loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id--      go (dll:dlls) = do-        mb_ptr <- lookupSymbolInDLL interp dll sym_to_find-        case mb_ptr of-          Just ptr -> pure (Just ptr)-          Nothing -> go dlls-      go [] =-        -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types-        lookupSymbol interp sym_to_find+    -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix bco -  go loaded_dlls+  BCOPtrBreakArray breakarray+    -> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba)  linkFail :: String -> String -> IO a linkFail who what

@@ -1,4 +1,4 @@-{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}+{-# LANGUAGE GADTs #-}  module GHC.Cmm.CommonBlockElim   ( elimCommonBlocks@@ -17,7 +17,6 @@ import GHC.Cmm.Dataflow.Block 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

@@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-}-{-# LANGUAGE BangPatterns #-} module GHC.Cmm.ContFlowOpt     ( cmmCfgOpts     , cmmCfgOptsProc@@ -11,7 +10,6 @@ import GHC.Prelude hiding (succ, unzip, zip)  import GHC.Cmm.Dataflow.Block hiding (blockConcat)-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId

@@ -1,9 +1,5 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses  #-}-{-# LANGUAGE RankNTypes #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}  --@@ -47,7 +43,6 @@  import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label  type family   Fact (x :: Extensibility) f :: Type

@@ -47,10 +47,9 @@ import GHC.Utils.Panic import GHC.Types.SrcLoc import GHC.Types.Tickish-import GHC.Utils.Misc      ( seqList )+import GHC.Utils.Misc      ( partitionWith, seqList )  import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label @@ -58,7 +57,6 @@ import Data.List     ( minimumBy, nubBy ) import Data.Ord      ( comparing ) import qualified Data.Map as Map-import Data.Either   ( partitionEithers )  -- | Debug information about a block of code. Ticks scope over nested -- blocks.@@ -110,7 +108,7 @@       -- Analyse tick scope structure: Each one is either a top-level       -- tick scope, or the child of another.       (topScopes, childScopes)-        = partitionEithers $ map (\a -> findP a a) $ Map.keys blockCtxs+        = partitionWith (\a -> findP a a) $ Map.keys blockCtxs       findP tsc GlobalScope = Left tsc -- top scope       findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)                     | otherwise                   = findP tsc scp'@@ -119,9 +117,6 @@               -- recover by copying ticks below.               scp' | SubScope _ scp' <- scp      = scp'                    | CombinedScope scp' _ <- scp = scp'-#if __GLASGOW_HASKELL__ < 901-                   | otherwise                   = panic "findP impossible"-#endif        scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope acc) Map.empty childScopes 

@@ -32,7 +32,6 @@  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

@@ -0,0 +1,222 @@+-- -----------------------------------------------------------------------------+--+-- (c) The University of Glasgow 1993-2004+--+--+-- -----------------------------------------------------------------------------++{-# LANGUAGE PatternSynonyms #-}+{-# LANGUAGE UnboxedTuples #-}++module GHC.Cmm.GenericOpt+   ( cmmToCmm+   )+where++import GHC.Prelude hiding (head)+import GHC.Platform+import GHC.CmmToAsm.PIC+import GHC.CmmToAsm.Config+import GHC.CmmToAsm.Types+import GHC.Cmm.BlockId+import GHC.Cmm+import GHC.Cmm.Utils+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Opt           ( cmmMachOpFold )+import GHC.Cmm.CLabel+import GHC.Data.FastString+import GHC.Unit+import Control.Monad++-- -----------------------------------------------------------------------------+-- Generic Cmm optimiser++{-+Here we do:++  (a) Constant folding+  (c) Position independent code and dynamic linking+        (i)  introduce the appropriate indirections+             and position independent refs+        (ii) compile a list of imported symbols+  (d) Some arch-specific optimizations++(a) will be moving to the new Hoopl pipeline, however, (c) and+(d) are only needed by the native backend and will continue to live+here.++Ideas for other things we could do (put these in Hoopl please!):++  - shortcut jumps-to-jumps+  - simple CSE: if an expr is assigned to a temp, then replace later occs of+    that expr with the temp, until the expr is no longer valid (can push through+    temp assignments, and certain assigns to mem...)+-}++cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])+cmmToCmm _ top@(CmmData _ _) = (top, [])+cmmToCmm config (CmmProc info lbl live graph)+    = runCmmOpt config $+      do blocks' <- mapM cmmBlockConFold (toBlockList graph)+         return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')++type OptMResult a = (# a, [CLabel] #)++pattern OptMResult :: a -> b -> (# a, b #)+pattern OptMResult x y = (# x, y #)+{-# COMPLETE OptMResult #-}++newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)+    deriving (Functor)++instance Applicative CmmOptM where+    pure x = CmmOptM $ \_ imports -> OptMResult x imports+    (<*>) = ap++instance Monad CmmOptM where+  (CmmOptM f) >>= g =+    CmmOptM $ \config imports0 ->+                case f config imports0 of+                  OptMResult x imports1 ->+                    case g x of+                      CmmOptM g' -> g' config imports1++instance CmmMakeDynamicReferenceM CmmOptM where+    addImport = addImportCmmOpt++addImportCmmOpt :: CLabel -> CmmOptM ()+addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports)++getCmmOptConfig :: CmmOptM NCGConfig+getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports++runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])+runCmmOpt config (CmmOptM f) =+  case f config [] of+    OptMResult result imports -> (result, imports)++cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock+cmmBlockConFold block = do+  let (entry, middle, last) = blockSplit block+      stmts = blockToList middle+  stmts' <- mapM cmmStmtConFold stmts+  last' <- cmmStmtConFold last+  return $ blockJoin entry (blockFromList stmts') last'++-- This does three optimizations, but they're very quick to check, so we don't+-- bother turning them off even when the Hoopl code is active.  Since+-- this is on the old Cmm representation, we can't reuse the code either:+--  * reg = reg      --> nop+--  * if 0 then jump --> nop+--  * if 1 then jump --> jump+-- We might be tempted to skip this step entirely of not Opt_PIC, but+-- there is some PowerPC code for the non-PIC case, which would also+-- have to be separated.+cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)+cmmStmtConFold stmt+   = case stmt of+        CmmAssign reg src+           -> do src' <- cmmExprConFold DataReference src+                 return $ case src' of+                   CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")+                   new_src -> CmmAssign reg new_src++        CmmStore addr src align+           -> do addr' <- cmmExprConFold DataReference addr+                 src'  <- cmmExprConFold DataReference src+                 return $ CmmStore addr' src' align++        CmmCall { cml_target = addr }+           -> do addr' <- cmmExprConFold JumpReference addr+                 return $ stmt { cml_target = addr' }++        CmmUnsafeForeignCall target regs args+           -> do target' <- case target of+                              ForeignTarget e conv -> do+                                e' <- cmmExprConFold CallReference e+                                return $ ForeignTarget e' conv+                              PrimTarget _ ->+                                return target+                 args' <- mapM (cmmExprConFold DataReference) args+                 return $ CmmUnsafeForeignCall target' regs args'++        CmmCondBranch test true false likely+           -> do test' <- cmmExprConFold DataReference test+                 return $ case test' of+                   CmmLit (CmmInt 0 _) -> CmmBranch false+                   CmmLit (CmmInt _ _) -> CmmBranch true+                   _other -> CmmCondBranch test' true false likely++        CmmSwitch expr ids+           -> do expr' <- cmmExprConFold DataReference expr+                 return $ CmmSwitch expr' ids++        other+           -> return other++cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr+cmmExprConFold referenceKind expr = do+    config <- getCmmOptConfig++    let expr' = if not (ncgDoConstantFolding config)+                    then expr+                    else cmmExprCon config expr++    cmmExprNative referenceKind expr'++cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr+cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align+cmmExprCon config (CmmMachOp mop args)+    = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args)+cmmExprCon _ other = other++-- handles both PIC and non-PIC cases... a very strange mixture+-- of things to do.+cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr+cmmExprNative referenceKind expr = do+     config <- getCmmOptConfig+     let platform = ncgPlatform config+         arch = platformArch platform+     case expr of+        CmmLoad addr rep align+          -> do addr' <- cmmExprNative DataReference addr+                return $ CmmLoad addr' rep align++        CmmMachOp mop args+          -> do args' <- mapM (cmmExprNative DataReference) args+                return $ CmmMachOp mop args'++        CmmLit (CmmBlock id)+          -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))+          -- we must convert block Ids to CLabels here, because we+          -- might have to do the PIC transformation.  Hence we must+          -- not modify BlockIds beyond this point.++        CmmLit (CmmLabel lbl)+          -> cmmMakeDynamicReference config referenceKind lbl+        CmmLit (CmmLabelOff lbl off)+          -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl+                -- need to optimize here, since it's late+                return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [+                    dynRef,+                    (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))+                  ]++        -- On powerpc (non-PIC), it's easier to jump directly to a label than+        -- to use the register table, so we replace these registers+        -- with the corresponding labels:+        CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))+        CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))+        CmmReg (CmmGlobal (GlobalRegUse GCFun _))+          | arch == ArchPPC && not (ncgPIC config)+          -> cmmExprNative referenceKind $+             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))++        other+           -> return other

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, GADTs #-}+{-# LANGUAGE GADTs #-}  module GHC.Cmm.Graph   ( CmmAGraph, CmmAGraphScoped, CgStmt(..)

@@ -40,14 +40,13 @@ import GHC.Data.Bitmap import GHC.Data.Stream (Stream) import qualified GHC.Data.Stream as Stream-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label  import GHC.Platform import GHC.Platform.Profile import GHC.Data.Maybe import GHC.Utils.Error (withTimingSilent) import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Types.Unique.Supply import GHC.Utils.Logger import GHC.Utils.Monad@@ -450,7 +449,7 @@ -- | Takes a closure pointer and returns the info table pointer closureInfoPtr :: Platform -> DoAlignSanitisation -> CmmExpr -> CmmExpr closureInfoPtr platform align_check e =-    cmmLoadBWord platform (wordAligned platform align_check e)+    CmmMachOp (MO_RelaxedRead (wordWidth platform)) [wordAligned platform align_check e]  -- | Takes an info pointer (the first word of a closure) and returns its entry -- code

@@ -1,11 +1,7 @@-{-# LANGUAGE GADTs, BangPatterns, RecordWildCards,-    GeneralizedNewtypeDeriving, NondecreasingIndentation, TupleSections,-    ScopedTypeVariables, OverloadedStrings, LambdaCase, EmptyCase #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE StandaloneDeriving #-}+{-# LANGUAGE GADTs, RecordWildCards,+    NondecreasingIndentation,+    OverloadedStrings, LambdaCase #-} {-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE UndecidableInstances #-}  @@ -27,7 +23,6 @@ import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Unit.Module import GHC.Data.Graph.Directed

@@ -1,4 +1,4 @@-{-# LANGUAGE BangPatterns, RecordWildCards, GADTs #-}+{-# LANGUAGE RecordWildCards, GADTs #-} module GHC.Cmm.LayoutStack (        cmmLayoutStack, setInfoTableStackMap   ) where@@ -21,9 +21,8 @@ import GHC.Cmm.Liveness import GHC.Cmm.ProcPoint import GHC.Runtime.Heap.Layout-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow+import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Types.Unique.Supply

@@ -62,7 +62,7 @@ @hexadecimal = $hexit+ @exponent    = [eE] [\-\+]? @decimal -@floating_point = @decimal \. @decimal @exponent? | @decimal @exponent+@floating_point = [\-]? (@decimal \. @decimal @exponent? | @decimal @exponent)  @escape      = \\ ([abfnrt\\\'\"\?] | x $hexit{1,2} | $octit{1,3}) @strchar     = ($printable # [\"\\]) | @escape

@@ -18,7 +18,6 @@ import GHC.Platform import GHC.Platform.Regs (callerSaves) import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm

@@ -1,7 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-}-{-# LANGUAGE ScopedTypeVariables #-}  module GHC.Cmm.Liveness     ( CmmLocalLive@@ -21,7 +18,6 @@ import GHC.Cmm.BlockId import GHC.Cmm import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Label import GHC.Cmm.LRegSet

@@ -213,33 +213,23 @@   = Just $! CmmMachOp op [pic, CmmLit $ cmmOffsetLit lit off ]   where off = fromIntegral (narrowS rep n) --- Make a RegOff if we can. We don't perform this optimization if rep is greater--- than the host word size because we use an Int to store the offset. See--- #24893 and #24700. This should be fixed to ensure that optimizations don't--- depend on the compiler host platform.+-- Make a RegOff if we can cmmMachOpFoldM _ (MO_Add _) [CmmReg reg, CmmLit (CmmInt n rep)]-  | validOffsetRep rep   = Just $! cmmRegOff reg (fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Add _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]-  | validOffsetRep rep   = Just $! cmmRegOff reg (off + fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmReg reg, CmmLit (CmmInt n rep)]-  | validOffsetRep rep   = Just $! cmmRegOff reg (- fromIntegral (narrowS rep n)) cmmMachOpFoldM _ (MO_Sub _) [CmmRegOff reg off, CmmLit (CmmInt n rep)]-  | validOffsetRep rep   = Just $! cmmRegOff reg (off - fromIntegral (narrowS rep n))  -- Fold label(+/-)offset into a CmmLit where possible  cmmMachOpFoldM _ (MO_Add _) [CmmLit lit, CmmLit (CmmInt i rep)]-  | validOffsetRep rep   = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Add _) [CmmLit (CmmInt i rep), CmmLit lit]-  | validOffsetRep rep   = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (narrowU rep i))) cmmMachOpFoldM _ (MO_Sub _) [CmmLit lit, CmmLit (CmmInt i rep)]-  | validOffsetRep rep   = Just $! CmmLit (cmmOffsetLit lit (fromIntegral (negate (narrowU rep i))))  @@ -419,13 +409,6 @@ -- Anything else is just too hard.  cmmMachOpFoldM _ _ _ = Nothing---- | Check that a literal width is compatible with the host word size used to--- store offsets. This should be fixed properly (using larger types to store--- literal offsets). See #24893-validOffsetRep :: Width -> Bool-validOffsetRep rep = widthInBits rep <= finiteBitSize (undefined :: Int)-  {- Note [Comparison operators] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -198,14 +198,15 @@ ---------------  Cmm respects the C11 memory model and distinguishes between non-atomic and-atomic memory accesses. In C11 fashion, atomic accesses can provide a number of-memory ordering guarantees. These are supported in Cmm syntax as follows:+atomic memory accesses. In C11 fashion, atomic accesses can provide a variety of+memory ordering guarantees. These supported as statements in Cmm syntax as+follows:      W_[ptr] = ...;            // a non-atomic store     %relaxed W_[ptr] = ...;   // an atomic store with relaxed ordering semantics     %release W_[ptr] = ...;   // an atomic store with release ordering semantics -    x = W_(ptr);              // a non-atomic load+    x = W_[ptr];              // a non-atomic load     x = %relaxed W_[ptr];     // an atomic load with relaxed ordering     x = %acquire W_[ptr];     // an atomic load with acquire ordering     // or equivalently...@@ -214,6 +215,18 @@ Here we used W_ as an example but these operations can be used on all Cmm types. +Sometimes it is also necessary to perform atomic but non-ordered loads in an+expression context. For this we provide the MO_RelaxedRead MachOp, expressed in+Cmm syntax as++    x = W_![ptr];++This operation and syntax was primarily added to support hand-written Cmm,+where sometimes such atomic loads are unavoidable deep inside expressions (e.g.+see the CHECK_GC macro). Since one should be explicit about program order when+writing operations with ordered semantics, we do not provide similar MachOps+for acquire and release reads.+ See Note [Heap memory barriers] in SMP.h for details.  ----------------------------------------------------------------------------- -}@@ -837,14 +850,12 @@         | STRING                 { do s <- code (newStringCLit $1);                                       return (CmmLit s) }         | reg                    { $1 }-        | type dereference       { do (align, ptr) <- $2; return (CmmLoad ptr $1 align) }+        | type '!' '[' expr ']'  { do ptr <- $4; return (CmmMachOp (MO_RelaxedRead (typeWidth $1)) [ptr]) }+        | type '^' '[' expr ']'  { do ptr <- $4; return (CmmLoad ptr $1 Unaligned) }+        | type '[' expr ']'      { do ptr <- $3; return (CmmLoad ptr $1 NaturallyAligned) }         | '%' NAME '(' exprs0 ')' {% exprOp $2 $4 }         | '(' expr ')'           { $2 } -dereference :: { CmmParse (AlignmentSpec, CmmExpr) }-        : '^' '[' expr ']'       { do ptr <- $3; return (Unaligned, ptr) }-        | '[' expr ']'           { do ptr <- $2; return (NaturallyAligned, ptr) }- -- leaving out the type of a literal gives you the native word size in C-- maybe_ty :: { CmmType }         : {- empty -}                   {% do platform <- PD.getPlatform; return $ bWord platform }@@ -1117,8 +1128,13 @@         ( "fabs32f", (MO_F32_Fabs,) ),         ( "sqrt32f", (MO_F32_Sqrt,) ), -        ( "read_barrier", (MO_ReadBarrier,)),-        ( "write_barrier", (MO_WriteBarrier,)),+        -- TODO: It would be nice to rename the following operations to+        -- acquire_fence and release_fence. Be aware that there'll be issues+        -- with an overlapping token ('acquire') in the lexer.+        ( "fence_acquire", (MO_AcquireFence,)),+        ( "fence_release", (MO_ReleaseFence,)),+        ( "fence_seq_cst", (MO_SeqCstFence,)),+         ( "memcpy", memcpyLikeTweakArgs MO_Memcpy ),         ( "memset", memcpyLikeTweakArgs MO_Memset ),         ( "memmove", memcpyLikeTweakArgs MO_Memmove ),@@ -1259,7 +1275,7 @@   ( fsLit "POP_ARG_REGS",          \[live_regs] -> emitPopArgRegs live_regs ),    ( fsLit "LDV_ENTER",             \[e] -> ldvEnter e ),-  ( fsLit "LDV_RECORD_CREATE",     \[e] -> ldvRecordCreate e ),+  ( fsLit "PROF_HEADER_CREATE",     \[e] -> profHeaderCreate e ),    ( fsLit "PUSH_UPD_FRAME",        \[sp,e] -> emitPushUpdateFrame sp e ),   ( fsLit "SET_HDR",               \[ptr,info,ccs] ->

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-}  module GHC.Cmm.Pipeline (   cmmPipeline@@ -12,7 +11,7 @@ import GHC.Cmm.Config import GHC.Cmm.ContFlowOpt import GHC.Cmm.CommonBlockElim-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import GHC.Cmm.Info.Build import GHC.Cmm.Lint import GHC.Cmm.LayoutStack@@ -26,11 +25,11 @@ import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Outputable+import GHC.Utils.Misc ( partitionWithM )  import GHC.Platform  import Control.Monad-import Data.Either (partitionEithers)  ----------------------------------------------------------------------------- -- | Top level driver for C-- pipeline@@ -50,9 +49,7 @@   let forceRes (info, group) = info `seq` foldr seq () group   let platform = cmmPlatform cmm_config   withTimingSilent logger (text "Cmm pipeline") forceRes $ do-     tops <- {-# SCC "tops" #-} mapM (cpsTop logger platform cmm_config) prog--     let (procs, data_) = partitionEithers tops+     (procs, data_) <- {-# SCC "tops" #-} partitionWithM (cpsTop logger platform cmm_config) prog      (srtInfo, cmms) <- {-# SCC "doSRTs" #-} doSRTs cmm_config srtInfo procs data_      dumpWith logger Opt_D_dump_cmm_cps "Post CPS Cmm" FormatCMM (pdoc platform cmms) 

@@ -1,4 +1,3 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} @@ -27,7 +26,6 @@ import GHC.Platform import GHC.Types.Unique.Supply import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label

@@ -40,7 +40,6 @@ 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)

@@ -14,7 +14,6 @@ import GHC.Cmm.Utils import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Platform.Regs 

@@ -6,7 +6,6 @@  import GHC.Prelude -import GHC.StgToCmm.Utils (get_GlobalReg_addr) import GHC.Platform import GHC.Platform.Regs (activeStgRegs, callerSaves) import GHC.Cmm@@ -24,12 +23,12 @@ import Data.Maybe (fromMaybe)  data Env = Env { platform :: Platform-               , uniques :: [Unique]+               , uniques :: UniqSupply                }  annotateTSAN :: Platform -> CmmGraph -> UniqSM CmmGraph annotateTSAN platform graph = do-    env <- Env platform <$> getUniquesM+    env <- Env platform <$> getUniqueSupplyM     return $ modifyGraph (mapGraphBlocks (annotateBlock env)) graph  mapBlockList :: (forall e' x'. n e' x' -> Block n e' x')@@ -37,11 +36,11 @@ 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+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)@@ -85,6 +84,7 @@ annotateExpr env expr =     annotateLoads env (collectExprLoads expr) +-- | A load mentioned in a 'CmmExpr'. data Load = Load CmmType AlignmentSpec CmmExpr  annotateLoads :: Env -> [Load] -> Block CmmNode O O@@ -103,6 +103,9 @@ collectExprLoads (CmmLit _)           = [] collectExprLoads (CmmLoad e ty align) = [Load ty align e] collectExprLoads (CmmReg _)           = []+-- N.B. we don't bother telling TSAN about MO_RelaxedReads+-- since doing so would be inconvenient and they by+-- definition can neither race nor introduce ordering. collectExprLoads (CmmMachOp _op args) = foldMap collectExprLoads args collectExprLoads (CmmStackSlot _ _)   = [] collectExprLoads (CmmRegOff _ _)      = []@@ -114,10 +117,10 @@              -> [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_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@@ -133,14 +136,15 @@     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)+    (save, restore) = saveRestoreCallerRegs gregs_us (platform env) +    (arg_us, gregs_us) = splitUniqSupply (uniques 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+    arg_regs = zipWith arg_reg (uniqsFromSupply arg_us) args       where         arg_reg :: Unique -> CmmExpr -> CmmReg         arg_reg u expr = CmmLocal $ LocalReg u (cmmExprType (platform env) expr)@@ -150,31 +154,34 @@      call = CmmUnsafeForeignCall ftgt formals (map CmmReg arg_regs) -saveRestoreCallerRegs :: Platform+-- | We save the contents of global registers in locals and allow the+-- register allocator to spill them to the stack around the call.+-- We cannot use the register table for this since we would interface+-- with {SAVE,RESTORE}_THREAD_STATE.+saveRestoreCallerRegs :: UniqSupply -> Platform                       -> (Block CmmNode O O, Block CmmNode O O)-saveRestoreCallerRegs platform =+saveRestoreCallerRegs us platform =     (save, restore)   where-    regs = filter (callerSaves platform) (activeStgRegs platform)--    save = blockFromList (map saveReg regs)--    saveReg :: GlobalReg -> CmmNode O O-    saveReg reg =-      CmmStore (get_GlobalReg_addr platform reg)-               (CmmReg (CmmGlobal (GlobalRegUse reg ty)))-               NaturallyAligned-      where ty = globalRegSpillType platform reg+    regs_to_save :: [GlobalReg]+    regs_to_save = filter (callerSaves platform) (activeStgRegs platform) -    restore = blockFromList (map restoreReg regs)+    nodes :: [(CmmNode O O, CmmNode O O)]+    nodes =+        zipWith mk_reg regs_to_save (uniqsFromSupply us)+      where+        mk_reg :: GlobalReg -> Unique -> (CmmNode O O, CmmNode O O)+        mk_reg reg u =+            let ty = globalRegSpillType platform reg+                greg = CmmGlobal (GlobalRegUse reg ty)+                lreg = CmmLocal (LocalReg u ty)+                save = CmmAssign lreg (CmmReg greg)+                restore = CmmAssign greg (CmmReg lreg)+            in (save, restore) -    restoreReg :: GlobalReg -> CmmNode O O-    restoreReg reg =-      CmmAssign (CmmGlobal (GlobalRegUse reg ty))-                (CmmLoad (get_GlobalReg_addr platform reg)-                         ty-                         NaturallyAligned)-      where ty = globalRegSpillType platform reg+    (save_nodes, restore_nodes) = unzip nodes+    save = blockFromList save_nodes+    restore = blockFromList restore_nodes  -- | Mirrors __tsan_memory_order -- <https://github.com/llvm-mirror/compiler-rt/blob/master/include/sanitizer/tsan_interface_atomic.h#L32>

@@ -1,5 +1,4 @@-{-# LANGUAGE GADTs, RankNTypes #-}-{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE GADTs #-} {-# LANGUAGE LambdaCase #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -70,7 +69,7 @@ import GHC.Prelude  import GHC.Core.TyCon     ( PrimRep(..), PrimElemRep(..) )-import GHC.Types.RepType  ( UnaryType, SlotTy (..), typePrimRep1 )+import GHC.Types.RepType  ( NvUnaryType, SlotTy (..), typePrimRepU )  import GHC.Platform import GHC.Runtime.Heap.Layout@@ -87,7 +86,6 @@ import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections  --------------------------------------------------- --@@ -97,7 +95,6 @@  primRepCmmType :: Platform -> PrimRep -> CmmType primRepCmmType platform = \case-   VoidRep          -> panic "primRepCmmType:VoidRep"    BoxedRep _       -> gcWord platform    IntRep           -> bWord platform    WordRep          -> bWord platform@@ -136,11 +133,10 @@ primElemRepCmmType FloatElemRep  = f32 primElemRepCmmType DoubleElemRep = f64 -typeCmmType :: Platform -> UnaryType -> CmmType-typeCmmType platform ty = primRepCmmType platform (typePrimRep1 ty)+typeCmmType :: Platform -> NvUnaryType -> CmmType+typeCmmType platform ty = primRepCmmType platform (typePrimRepU ty)  primRepForeignHint :: PrimRep -> ForeignHint-primRepForeignHint VoidRep      = panic "primRepForeignHint:VoidRep" primRepForeignHint (BoxedRep _) = AddrHint primRepForeignHint IntRep       = SignedHint primRepForeignHint Int8Rep      = SignedHint@@ -157,8 +153,8 @@ primRepForeignHint DoubleRep    = NoHint primRepForeignHint (VecRep {})  = NoHint -typeForeignHint :: UnaryType -> ForeignHint-typeForeignHint = primRepForeignHint . typePrimRep1+typeForeignHint :: NvUnaryType -> ForeignHint+typeForeignHint = primRepForeignHint . typePrimRepU  --------------------------------------------------- --

@@ -5,17 +5,8 @@ -- -- ----------------------------------------------------------------------------- -{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE PatternSynonyms #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE UnboxedTuples #-}---- | Native code generator+-- | Note [Native code generator]+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- -- The native-code generator has machine-independent and -- machine-dependent modules.@@ -23,51 +14,45 @@ -- This module ("GHC.CmmToAsm") is the top-level machine-independent -- module.  Before entering machine-dependent land, we do some -- machine-independent optimisations (defined below) on the--- 'CmmStmts's.+-- 'CmmStmts's. (Which ideally would be folded into CmmOpt ...) -- -- We convert to the machine-specific 'Instr' datatype with -- 'cmmCodeGen', assuming an infinite supply of registers.  We then use--- a machine-independent register allocator ('regAlloc') to rejoin+-- a (mostly) machine-independent register allocator to rejoin -- reality.  Obviously, 'regAlloc' has machine-specific helper--- functions (see about "RegAllocInfo" below).+-- functions (see the used register allocator for details). -- -- Finally, we order the basic blocks of the function so as to minimise -- the number of jumps between blocks, by utilising fallthrough wherever -- possible. ----- The machine-dependent bits break down as follows:+-- The machine-dependent bits are generally contained under+--  GHC/CmmToAsm/<Arch>/* and generally breaks down as follows: -----   * ["MachRegs"]  Everything about the target platform's machine+--   * "Regs": Everything about the target platform's machine --     registers (and immediate operands, and addresses, which tend to --     intermingle/interact with registers). -----   * ["MachInstrs"]  Includes the 'Instr' datatype (possibly should---     have a module of its own), plus a miscellany of other things+--   * "Instr":  Includes the 'Instr' datatype plus a miscellany of other things --     (e.g., 'targetDoubleSize', 'smStablePtrTable', ...) -----   * ["MachCodeGen"]  is where 'Cmm' stuff turns into+--   * "CodeGen":  is where 'Cmm' stuff turns into --     machine instructions. -----   * ["PprMach"] 'pprInstr' turns an 'Instr' into text (well, really+--   * "Ppr": 'pprInstr' turns an 'Instr' into text (well, really --     a 'SDoc'). -----   * ["RegAllocInfo"] In the register allocator, we manipulate---     'MRegsState's, which are 'BitSet's, one bit per machine register.---     When we want to say something about a specific machine register---     (e.g., ``it gets clobbered by this instruction''), we set/unset---     its bit.  Obviously, we do this 'BitSet' thing for efficiency---     reasons.------     The 'RegAllocInfo' module collects together the machine-specific---     info needed to do register allocation.+-- The register allocators lives under GHC.CmmToAsm.Reg.*, there is both a Linear and a Graph+-- based register allocator. Both of which have their own notes describing them. They+-- are mostly platform independent but there are some platform specific files+-- encoding architecture details under Reg/<Allocator>/<Arch.hs> -----    * ["RegisterAlloc"] The (machine-independent) register allocator. -- -} -- module GHC.CmmToAsm    ( nativeCodeGen -   -- * Test-only exports: see trac #12744+   -- * Test-only exports: see #12744    -- used by testGraphNoSpills, which needs to access    -- the register allocator intermediate data structures    -- cmmNativeGen emits@@ -110,11 +95,8 @@ import GHC.Cmm.BlockId import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import GHC.Cmm-import GHC.Cmm.Utils-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label-import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Opt           ( cmmMachOpFold )+import GHC.Cmm.GenericOpt import GHC.Cmm.CLabel  import GHC.Types.Unique.FM@@ -127,7 +109,6 @@ import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Error import GHC.Utils.Exception (evaluate) import GHC.Utils.Constants (debugIsOn)@@ -171,7 +152,7 @@       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+      ArchWasm32    -> Wasm32.ncgWasm config logger platform ts us modLoc h cmms  -- | Data accumulated during code generation. Mostly about statistics, -- but also collects debug data for DWARF generation.@@ -949,196 +930,3 @@                       , natm_fileid final_st, final_cfg)           else pprPanic "genMachCode: nonzero final delta" (int final_delta)     }---- -------------------------------------------------------------------------------- Generic Cmm optimiser--{--Here we do:--  (a) Constant folding-  (c) Position independent code and dynamic linking-        (i)  introduce the appropriate indirections-             and position independent refs-        (ii) compile a list of imported symbols-  (d) Some arch-specific optimizations--(a) will be moving to the new Hoopl pipeline, however, (c) and-(d) are only needed by the native backend and will continue to live-here.--Ideas for other things we could do (put these in Hoopl please!):--  - shortcut jumps-to-jumps-  - simple CSE: if an expr is assigned to a temp, then replace later occs of-    that expr with the temp, until the expr is no longer valid (can push through-    temp assignments, and certain assigns to mem...)--}--cmmToCmm :: NCGConfig -> RawCmmDecl -> (RawCmmDecl, [CLabel])-cmmToCmm _ top@(CmmData _ _) = (top, [])-cmmToCmm config (CmmProc info lbl live graph)-    = runCmmOpt config $-      do blocks' <- mapM cmmBlockConFold (toBlockList graph)-         return $ CmmProc info lbl live (ofBlockList (g_entry graph) blocks')--type OptMResult a = (# a, [CLabel] #)--pattern OptMResult :: a -> b -> (# a, b #)-pattern OptMResult x y = (# x, y #)-{-# COMPLETE OptMResult #-}--newtype CmmOptM a = CmmOptM (NCGConfig -> [CLabel] -> OptMResult a)-    deriving (Functor)--instance Applicative CmmOptM where-    pure x = CmmOptM $ \_ imports -> OptMResult x imports-    (<*>) = ap--instance Monad CmmOptM where-  (CmmOptM f) >>= g =-    CmmOptM $ \config imports0 ->-                case f config imports0 of-                  OptMResult x imports1 ->-                    case g x of-                      CmmOptM g' -> g' config imports1--instance CmmMakeDynamicReferenceM CmmOptM where-    addImport = addImportCmmOpt--addImportCmmOpt :: CLabel -> CmmOptM ()-addImportCmmOpt lbl = CmmOptM $ \_ imports -> OptMResult () (lbl:imports)--getCmmOptConfig :: CmmOptM NCGConfig-getCmmOptConfig = CmmOptM $ \config imports -> OptMResult config imports--runCmmOpt :: NCGConfig -> CmmOptM a -> (a, [CLabel])-runCmmOpt config (CmmOptM f) =-  case f config [] of-    OptMResult result imports -> (result, imports)--cmmBlockConFold :: CmmBlock -> CmmOptM CmmBlock-cmmBlockConFold block = do-  let (entry, middle, last) = blockSplit block-      stmts = blockToList middle-  stmts' <- mapM cmmStmtConFold stmts-  last' <- cmmStmtConFold last-  return $ blockJoin entry (blockFromList stmts') last'---- This does three optimizations, but they're very quick to check, so we don't--- bother turning them off even when the Hoopl code is active.  Since--- this is on the old Cmm representation, we can't reuse the code either:---  * reg = reg      --> nop---  * if 0 then jump --> nop---  * if 1 then jump --> jump--- We might be tempted to skip this step entirely of not Opt_PIC, but--- there is some PowerPC code for the non-PIC case, which would also--- have to be separated.-cmmStmtConFold :: CmmNode e x -> CmmOptM (CmmNode e x)-cmmStmtConFold stmt-   = case stmt of-        CmmAssign reg src-           -> do src' <- cmmExprConFold DataReference src-                 return $ case src' of-                   CmmReg reg' | reg == reg' -> CmmComment (fsLit "nop")-                   new_src -> CmmAssign reg new_src--        CmmStore addr src align-           -> do addr' <- cmmExprConFold DataReference addr-                 src'  <- cmmExprConFold DataReference src-                 return $ CmmStore addr' src' align--        CmmCall { cml_target = addr }-           -> do addr' <- cmmExprConFold JumpReference addr-                 return $ stmt { cml_target = addr' }--        CmmUnsafeForeignCall target regs args-           -> do target' <- case target of-                              ForeignTarget e conv -> do-                                e' <- cmmExprConFold CallReference e-                                return $ ForeignTarget e' conv-                              PrimTarget _ ->-                                return target-                 args' <- mapM (cmmExprConFold DataReference) args-                 return $ CmmUnsafeForeignCall target' regs args'--        CmmCondBranch test true false likely-           -> do test' <- cmmExprConFold DataReference test-                 return $ case test' of-                   CmmLit (CmmInt 0 _) -> CmmBranch false-                   CmmLit (CmmInt _ _) -> CmmBranch true-                   _other -> CmmCondBranch test' true false likely--        CmmSwitch expr ids-           -> do expr' <- cmmExprConFold DataReference expr-                 return $ CmmSwitch expr' ids--        other-           -> return other--cmmExprConFold :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr-cmmExprConFold referenceKind expr = do-    config <- getCmmOptConfig--    let expr' = if not (ncgDoConstantFolding config)-                    then expr-                    else cmmExprCon config expr--    cmmExprNative referenceKind expr'--cmmExprCon :: NCGConfig -> CmmExpr -> CmmExpr-cmmExprCon config (CmmLoad addr rep align) = CmmLoad (cmmExprCon config addr) rep align-cmmExprCon config (CmmMachOp mop args)-    = cmmMachOpFold (ncgPlatform config) mop (map (cmmExprCon config) args)-cmmExprCon _ other = other---- handles both PIC and non-PIC cases... a very strange mixture--- of things to do.-cmmExprNative :: ReferenceKind -> CmmExpr -> CmmOptM CmmExpr-cmmExprNative referenceKind expr = do-     config <- getCmmOptConfig-     let platform = ncgPlatform config-         arch = platformArch platform-     case expr of-        CmmLoad addr rep align-          -> do addr' <- cmmExprNative DataReference addr-                return $ CmmLoad addr' rep align--        CmmMachOp mop args-          -> do args' <- mapM (cmmExprNative DataReference) args-                return $ CmmMachOp mop args'--        CmmLit (CmmBlock id)-          -> cmmExprNative referenceKind (CmmLit (CmmLabel (infoTblLbl id)))-          -- we must convert block Ids to CLabels here, because we-          -- might have to do the PIC transformation.  Hence we must-          -- not modify BlockIds beyond this point.--        CmmLit (CmmLabel lbl)-          -> cmmMakeDynamicReference config referenceKind lbl-        CmmLit (CmmLabelOff lbl off)-          -> do dynRef <- cmmMakeDynamicReference config referenceKind lbl-                -- need to optimize here, since it's late-                return $ cmmMachOpFold platform (MO_Add (wordWidth platform)) [-                    dynRef,-                    (CmmLit $ CmmInt (fromIntegral off) (wordWidth platform))-                  ]--        -- On powerpc (non-PIC), it's easier to jump directly to a label than-        -- to use the register table, so we replace these registers-        -- with the corresponding labels:-        CmmReg (CmmGlobal (GlobalRegUse EagerBlackholeInfo _))-          | arch == ArchPPC && not (ncgPIC config)-          -> cmmExprNative referenceKind $-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_EAGER_BLACKHOLE_info")))-        CmmReg (CmmGlobal (GlobalRegUse GCEnter1 _))-          | arch == ArchPPC && not (ncgPIC config)-          -> cmmExprNative referenceKind $-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_enter_1")))-        CmmReg (CmmGlobal (GlobalRegUse GCFun _))-          | arch == ArchPPC && not (ncgPIC config)-          -> cmmExprNative referenceKind $-             CmmLit (CmmLabel (mkCmmCodeLabel rtsUnitId (fsLit "__stg_gc_fun")))--        other-           -> return other

@@ -47,7 +47,6 @@         patchRegsOfInstr        = AArch64.patchRegsOfInstr         isJumpishInstr          = AArch64.isJumpishInstr         jumpDestsOfInstr        = AArch64.jumpDestsOfInstr-        canFallthroughTo        = AArch64.canFallthroughTo         patchJumpInstr          = AArch64.patchJumpInstr         mkSpillInstr            = AArch64.mkSpillInstr         mkLoadInstr             = AArch64.mkLoadInstr

@@ -1,9 +1,5 @@ {-# language GADTs #-}-{-# LANGUAGE TupleSections #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE BinaryLiterals #-} {-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NumericUnderscores #-} module GHC.CmmToAsm.AArch64.CodeGen (       cmmTopCodeGen     , generateJumpTableForInstr@@ -63,12 +59,9 @@ import GHC.Data.FastString import GHC.Utils.Misc import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Monad (mapAccumLM) -import GHC.Cmm.Dataflow.Collections- -- Note [General layout of an NCG] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- @cmmTopCodeGen@ will be our main entry point to code gen.  Here we'll get@@ -163,8 +156,9 @@   --      unwinding info. See Ticket 19913   -- code generation may introduce new basic block boundaries, which   -- are indicated by the NEWBLOCK instruction.  We must split up the-  -- instruction stream into basic blocks again.  Also, we extract-  -- LDATAs here too.+  -- instruction stream into basic blocks again. Also, we may extract+  -- LDATAs here too (if they are implemented by AArch64 again - See+  -- PPC how to do that.)   let         (top,other_blocks,statics) = foldrOL mkBlocks ([],[],[]) instrs @@ -175,8 +169,6 @@           -> ([Instr], [GenBasicBlock Instr], [GenCmmDecl RawCmmStatics h g]) mkBlocks (NEWBLOCK id) (instrs,blocks,statics)   = ([], BasicBlock id instrs : blocks, statics)-mkBlocks (LDATA sec dat) (instrs,blocks,statics)-  = (instrs, blocks, CmmData sec dat:statics) mkBlocks instr (instrs,blocks,statics)   = (instr:instrs, blocks, statics) -- -----------------------------------------------------------------------------@@ -197,7 +189,7 @@ -- going back to the exact CmmExpr representation can be laborious and adds -- indirections to find the matches that lead to the assembly. ----- An improvement oculd be to have+-- An improvement could be to have -- --    (pprExpr genericPlatform e) <> parens (text. show e) --@@ -381,9 +373,117 @@     Fixed rep reg code ->         return (reg, rep, code) +{- Note [Aarch64 immediates]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Aarch64 with it's fixed width instruction encoding uses leftover space for+immediates.+If you want the full rundown consult the arch reference document:+"Arm® Architecture Reference Manual" - "C3.4 Data processing - immediate"++The gist of it is that different instructions allow for different immediate encodings.+The ones we care about for better code generation are:++* Simple but potentially repeated bit-patterns for logic instructions.+* 16bit numbers shifted by multiples of 16.+* 12 bit numbers optionally shifted by 12 bits.++It might seem like the ISA allows for 64bit immediates but this isn't the case.+Rather there are some instruction aliases which allow for large unencoded immediates+which will then be transalted to one of the immediate encodings implicitly.++For example mov x1, #0x10000 is allowed but will be assembled to movz x1, #0x1, lsl #16+-}++-- | Move (wide immediate)+-- Allows for 16bit immediate which can be shifted by 0/16/32/48 bits.+-- Used with MOVZ,MOVN, MOVK+-- See Note [Aarch64 immediates]+getMovWideImm :: Integer -> Width -> Maybe Operand+getMovWideImm n w+  -- TODO: Handle sign extension/negatives+  | n <= 0+  = Nothing+  -- Fits in 16 bits+  | sized_n < 2^(16 :: Int)+  = Just $ OpImm (ImmInteger truncated)++  -- 0x0000 0000 xxxx 0000+  | trailing_zeros >= 16 && sized_n < 2^(32 :: Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 16) SLSL 16++  -- 0x 0000 xxxx 0000 0000+  | trailing_zeros >= 32 && sized_n < 2^(48 :: Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 32) SLSL 32++  -- 0x xxxx 0000 0000 0000+  | trailing_zeros >= 48+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 48) SLSL 48++  | otherwise+  = Nothing+  where+    truncated = narrowU w n+    sized_n = fromIntegral truncated :: Word64+    trailing_zeros = countTrailingZeros sized_n++-- | Arithmetic(immediate)+--  Allows for 12bit immediates which can be shifted by 0 or 12 bits.+-- Used with ADD, ADDS, SUB, SUBS, CMP+-- See Note [Aarch64 immediates]+getArithImm :: Integer -> Width -> Maybe Operand+getArithImm n w+  -- TODO: Handle sign extension+  | n <= 0+  = Nothing+  -- Fits in 16 bits+  -- Fits in 12 bits+  | sized_n < 2^(12::Int)+  = Just $ OpImm (ImmInteger truncated)++  -- 12 bits shifted by 12 places.+  | trailing_zeros >= 12 && sized_n < 2^(24::Int)+  = Just $ OpImmShift (ImmInteger $ truncated `shiftR` 12) SLSL 12++  | otherwise+  = Nothing+  where+    sized_n = fromIntegral truncated :: Word64+    truncated = narrowU w n+    trailing_zeros = countTrailingZeros sized_n++-- |  Logical (immediate)+-- Allows encoding of some repeated bitpatterns+-- Used with AND, EOR, ORR+-- and their aliases which includes at least MOV (bitmask immediate)+-- See Note [Aarch64 immediates]+getBitmaskImm :: Integer -> Width -> Maybe Operand+getBitmaskImm n w+  | isAArch64Bitmask (opRegWidth w) truncated = Just $ OpImm (ImmInteger truncated)+  | otherwise = Nothing+  where+    truncated = narrowU w n++-- | Load/store immediate.+-- Depends on the width of the store to some extent.+isOffsetImm :: Int -> Width -> Bool+isOffsetImm off w+  -- 8 bits + sign for unscaled offsets+  | -256 <= off, off <= 255 = True+  -- Offset using 12-bit positive immediate, scaled by width+  -- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4+  -- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8+  -- 16-bit: 0 .. 8188, 8-bit: 0 -- 4095+  | 0 <= off, off < 4096 * byte_width, off `mod` byte_width == 0 = True+  | otherwise = False+  where+    byte_width = widthInBytes w++++ -- TODO OPT: we might be able give getRegister --          a hint, what kind of register we want.-getFloatReg :: HasDebugCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock)+getFloatReg :: HasCallStack => CmmExpr -> NatM (Reg, Format, InstrBlock) getFloatReg expr = do   r <- getRegister expr   case r of@@ -503,8 +603,14 @@     CmmLit lit       -> case lit of -        -- TODO handle CmmInt 0 specially, use wzr or xzr.-+        -- Use wzr xzr for CmmInt 0 if the width matches up, otherwise do a move.+        -- TODO: Reenable after https://gitlab.haskell.org/ghc/ghc/-/issues/23632 is fixed.+        -- CmmInt 0 W32 -> do+        --   let format = intFormat W32+        --   return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))+        -- CmmInt 0 W64 -> do+        --   let format = intFormat W64+        --   return (Fixed format reg_zero (unitOL $ (COMMENT ((text . show $ expr))) ))         CmmInt i W8 | i >= 0 -> do           return (Any (intFormat W8) (\dst -> unitOL $ annExpr expr (MOV (OpReg W8 dst) (OpImm (ImmInteger (narrowU W8 i))))))         CmmInt i W16 | i >= 0 -> do@@ -519,8 +625,13 @@         -- Those need the upper bits set. We'd either have to explicitly sign         -- or figure out something smarter. Lowered to         -- `MOV dst XZR`+        CmmInt i w | i >= 0+                   , Just imm_op <- getMovWideImm i w -> do+          return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOVZ (OpReg w dst) imm_op)))+         CmmInt i w | isNbitEncodeable 16 i, i >= 0 -> do           return (Any (intFormat w) (\dst -> unitOL $ annExpr expr (MOV (OpReg W16 dst) (OpImm (ImmInteger i)))))+         CmmInt i w | isNbitEncodeable 32 i, i >= 0 -> do           let  half0 = fromIntegral (fromIntegral i :: Word16)                half1 = fromIntegral (fromIntegral (i `shiftR` 16) :: Word16)@@ -595,7 +706,6 @@           (op, imm_code) <- litToImm' lit           let rep = cmmLitType plat lit               format = cmmTypeFormat rep-              -- width = typeWidth rep           return (Any format (\dst -> imm_code `snocOL` LDR format (OpReg (formatToWidth format) dst) op))          CmmLabelOff lbl off -> do@@ -619,21 +729,20 @@       -> return (Fixed (cmmTypeFormat (cmmRegType reg))                        (getRegisterReg plat reg)                        nilOL)-    CmmRegOff reg off | isNbitEncodeable 12 (fromIntegral off) -> do-      getRegister' config plat $-            CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)]-          where width = typeWidth (cmmRegType reg)--    CmmRegOff reg off -> do-      (off_r, _off_format, off_code) <- getSomeReg $ CmmLit (CmmInt (fromIntegral off) width)-      (reg, _format, code) <- getSomeReg $ CmmReg reg-      return $ Any (intFormat width) (\dst -> off_code `appOL` code `snocOL` ADD (OpReg width dst) (OpReg width reg) (OpReg width off_r))-          where width = typeWidth (cmmRegType reg)--+    CmmRegOff reg off ->+      -- If we got here we will load the address into a register either way. So we might as well just expand+      -- and re-use the existing code path to handle "reg + off".+      let !width = cmmRegWidth reg+      in getRegister' config plat (CmmMachOp (MO_Add width) [CmmReg reg, CmmLit (CmmInt (fromIntegral off) width)])      -- for MachOps, see GHC.Cmm.MachOp     -- For CmmMachOp, see GHC.Cmm.Expr++    -- Handle MO_RelaxedRead as a normal CmmLoad, to allow+    -- non-trivial addressing modes to be used.+    CmmMachOp (MO_RelaxedRead w) [e] ->+      getRegister (CmmLoad e (cmmBits w) NaturallyAligned)+     CmmMachOp op [e] -> do       (reg, _format, code) <- getSomeReg e       case op of@@ -702,37 +811,25 @@     -- 0. TODO This should not exist! Rewrite: Reg +- 0 -> Reg     CmmMachOp (MO_Add _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'     CmmMachOp (MO_Sub _) [expr'@(CmmReg (CmmGlobal _r)), CmmLit (CmmInt 0 _)] -> getRegister' config plat expr'-    -- 1. Compute Reg +/- n directly.-    --    For Add/Sub we can directly encode 12bits, or 12bits lsl #12.-    CmmMachOp (MO_Add w) [(CmmReg reg), CmmLit (CmmInt n _)]-      | n > 0 && n < 4096-      , w == W32 || w == W64 -- Work around #23749-      -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ADD (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))-      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.-      where w' = formatToWidth (cmmTypeFormat (cmmRegType reg))-            r' = getRegisterReg plat reg-    CmmMachOp (MO_Sub w) [(CmmReg reg), CmmLit (CmmInt n _)]-      | n > 0 && n < 4096-      , w == W32 || w == W64 -- Work around #23749-      -> return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (SUB (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))-      -- TODO: 12bits lsl #12; e.g. lower 12 bits of n are 0; shift n >> 12, and set lsl to #12.-      where w' = formatToWidth (cmmTypeFormat (cmmRegType reg))-            r' = getRegisterReg plat reg+    -- Immediates are handled via `getArithImm` in the generic code path.      CmmMachOp (MO_U_Quot w) [x, y] | w == W8 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       (reg_y, _format_y, code_y) <- getSomeReg y-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                        (UXTB (OpReg w reg_y) (OpReg w reg_y)) `snocOL`+                                                                        (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))     CmmMachOp (MO_U_Quot w) [x, y] | w == W16 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       (reg_y, _format_y, code_y) <- getSomeReg y-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL` (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                        (UXTH (OpReg w reg_y) (OpReg w reg_y)) `snocOL`+                                                                        (UDIV (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))      -- 2. Shifts. x << n, x >> n.-    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do-      (reg_x, _format_x, code_x) <- getSomeReg x-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))-    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do+    CmmMachOp (MO_Shl w) [x, (CmmLit (CmmInt n _))]+      | w == W32 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> do       (reg_x, _format_x, code_x) <- getSomeReg x       return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSL (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) @@ -742,7 +839,8 @@     CmmMachOp (MO_S_Shr w) [x, y] | w == W8 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       (reg_y, _format_y, code_y) <- getSomeReg y-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))      CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do       (reg_x, _format_x, code_x) <- getSomeReg x@@ -750,24 +848,23 @@     CmmMachOp (MO_S_Shr w) [x, y] | w == W16 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       (reg_y, _format_y, code_y) <- getSomeReg y-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))--    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do-      (reg_x, _format_x, code_x) <- getSomeReg x-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (SXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                         (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) -    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do+    CmmMachOp (MO_S_Shr w) [x, (CmmLit (CmmInt n _))]+      | w == W32 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> do       (reg_x, _format_x, code_x) <- getSomeReg x       return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (ASR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)))) -     CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W8, 0 <= n, n < 8 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (UBFX (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n)) (OpImm (ImmInteger (8-n)))))     CmmMachOp (MO_U_Shr w) [x, y] | w == W8 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       (reg_y, _format_y, code_y) <- getSomeReg y-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTB (OpReg w reg_x) (OpReg w reg_x)) `snocOL`+                                                                        (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))      CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W16, 0 <= n, n < 16 -> do       (reg_x, _format_x, code_x) <- getSomeReg x@@ -775,23 +872,22 @@     CmmMachOp (MO_U_Shr w) [x, y] | w == W16 -> do       (reg_x, _format_x, code_x) <- getSomeReg x       (reg_y, _format_y, code_y) <- getSomeReg y-      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x)) `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y)))--    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W32, 0 <= n, n < 32 -> do-      (reg_x, _format_x, code_x) <- getSomeReg x-      return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))+      return $ Any (intFormat w) (\dst -> code_x `appOL` code_y `snocOL` annExpr expr (UXTH (OpReg w reg_x) (OpReg w reg_x))+                                                                `snocOL` (ASR (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))) -    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))] | w == W64, 0 <= n, n < 64 -> do+    CmmMachOp (MO_U_Shr w) [x, (CmmLit (CmmInt n _))]+      | w == W32 || w == W64+      , 0 <= n, n < fromIntegral (widthInBits w) -> do       (reg_x, _format_x, code_x) <- getSomeReg x       return $ Any (intFormat w) (\dst -> code_x `snocOL` annExpr expr (LSR (OpReg w dst) (OpReg w reg_x) (OpImm (ImmInteger n))))      -- 3. Logic &&, ||-    CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) ->+    CmmMachOp (MO_And w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) ->       return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (AND (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))       where w' = formatToWidth (cmmTypeFormat (cmmRegType reg))             r' = getRegisterReg plat reg -    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (fromIntegral n) ->+    CmmMachOp (MO_Or w) [(CmmReg reg), CmmLit (CmmInt n _)] | isAArch64Bitmask (opRegWidth w') (fromIntegral n) ->       return $ Any (intFormat w) (\d -> unitOL $ annExpr expr (ORR (OpReg w d) (OpReg w' r') (OpImm (ImmInteger n))))       where w' = formatToWidth (cmmTypeFormat (cmmRegType reg))             r' = getRegisterReg plat reg@@ -804,22 +900,56 @@           -- withTempFloatReg w op = OpReg w <$> getNewRegNat (floatFormat w) >>= op            -- A "plain" operation.-          bitOp w op = do+          bitOpImm w op encode_imm = do             -- compute x<m> <- x             -- compute x<o> <- y             -- <OP> x<n>, x<m>, x<o>             (reg_x, format_x, code_x) <- getSomeReg x-            (reg_y, format_y, code_y) <- getSomeReg y-            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOp: incompatible"+            (op_y, format_y, code_y) <- case y of+              CmmLit (CmmInt n w)+                | Just imm_operand_y <- encode_imm n w+                -> return (imm_operand_y, intFormat w, nilOL)+              _ -> do+                  (reg_y, format_y, code_y) <- getSomeReg y+                  return (OpReg w reg_y, format_y, code_y)+            massertPpr (isIntFormat format_x == isIntFormat format_y) $ text "bitOpImm: incompatible"             return $ Any (intFormat w) (\dst ->                 code_x `appOL`                 code_y `appOL`-                op (OpReg w dst) (OpReg w reg_x) (OpReg w reg_y))+                op (OpReg w dst) (OpReg w reg_x) op_y)            -- A (potentially signed) integer operation.           -- In the case of 8- and 16-bit signed arithmetic we must first           -- sign-extend both arguments to 32-bits.           -- See Note [Signed arithmetic on AArch64].+          intOpImm :: Bool -> Width -> (Operand -> Operand -> Operand -> OrdList Instr) -> (Integer -> Width -> Maybe Operand) -> NatM (Register)+          intOpImm {- is signed -} True  w op _encode_imm = intOp True w op+          intOpImm                 False w op  encode_imm = do+              -- compute x<m> <- x+              -- compute x<o> <- y+              -- <OP> x<n>, x<m>, x<o>+              (reg_x, format_x, code_x) <- getSomeReg x+              (op_y, format_y, code_y) <- case y of+                CmmLit (CmmInt n w)+                  | Just imm_operand_y <- encode_imm n w+                  -> return (imm_operand_y, intFormat w, nilOL)+                _ -> do+                    (reg_y, format_y, code_y) <- getSomeReg y+                    return (OpReg w reg_y, format_y, code_y)+              massertPpr (isIntFormat format_x && isIntFormat format_y) $ text "intOp: non-int"+              -- This is the width of the registers on which the operation+              -- should be performed.+              let w' = opRegWidth w+              return $ Any (intFormat w) $ \dst ->+                  code_x `appOL`+                  code_y `appOL`+                  op (OpReg w' dst) (OpReg w' reg_x) (op_y) `appOL`+                  truncateReg w' w dst -- truncate back to the operand's original width++          -- A (potentially signed) integer operation.+          -- In the case of 8- and 16-bit signed arithmetic we must first+          -- sign-extend both arguments to 32-bits.+          -- See Note [Signed arithmetic on AArch64].           intOp is_signed w op = do               -- compute x<m> <- x               -- compute x<o> <- y@@ -860,9 +990,9 @@       case op of         -- Integer operations         -- Add/Sub should only be Integer Options.-        MO_Add w -> intOp False w (\d x y -> unitOL $ annExpr expr (ADD d x y))+        MO_Add w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (ADD d x y)) getArithImm         -- TODO: Handle sub-word case-        MO_Sub w -> intOp False w (\d x y -> unitOL $ annExpr expr (SUB d x y))+        MO_Sub w -> intOpImm False w (\d x y -> unitOL $ annExpr expr (SUB d x y)) getArithImm          -- Note [CSET]         -- ~~~~~~~~~~~@@ -904,8 +1034,8 @@          -- N.B. We needn't sign-extend sub-word size (in)equality comparisons         -- since we don't care about ordering.-        MO_Eq w     -> bitOp w (\d x y -> toOL [ CMP x y, CSET d EQ ])-        MO_Ne w     -> bitOp w (\d x y -> toOL [ CMP x y, CSET d NE ])+        MO_Eq w     -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d EQ ]) getArithImm+        MO_Ne w     -> bitOpImm w (\d x y -> toOL [ CMP x y, CSET d NE ]) getArithImm          -- Signed multiply/divide         MO_Mul w          -> intOp True w (\d x y -> unitOL $ MUL d x y)@@ -934,10 +1064,10 @@         MO_S_Lt w     -> intOp True  w (\d x y -> toOL [ CMP x y, CSET d SLT ])          -- Unsigned comparisons-        MO_U_Ge w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGE ])-        MO_U_Le w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULE ])-        MO_U_Gt w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d UGT ])-        MO_U_Lt w     -> intOp False w (\d x y -> toOL [ CMP x y, CSET d ULT ])+        MO_U_Ge w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGE ]) getArithImm+        MO_U_Le w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULE ]) getArithImm+        MO_U_Gt w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d UGT ]) getArithImm+        MO_U_Lt w     -> intOpImm False w (\d x y -> toOL [ CMP x y, CSET d ULT ]) getArithImm          -- Floating point arithmetic         MO_F_Add w   -> floatOp w (\d x y -> unitOL $ ADD d x y)@@ -960,9 +1090,9 @@         MO_F_Lt w    -> floatCond w (\d x y -> toOL [ CMP x y, CSET d OLT ]) -- x < y <=> y >= x          -- Bitwise operations-        MO_And   w -> bitOp w (\d x y -> unitOL $ AND d x y)-        MO_Or    w -> bitOp w (\d x y -> unitOL $ ORR d x y)-        MO_Xor   w -> bitOp w (\d x y -> unitOL $ EOR d x y)+        MO_And   w -> bitOpImm w (\d x y -> unitOL $ AND d x y) getBitmaskImm+        MO_Or    w -> bitOpImm w (\d x y -> unitOL $ ORR d x y) getBitmaskImm+        MO_Xor   w -> bitOpImm w (\d x y -> unitOL $ EOR d x y) getBitmaskImm         MO_Shl   w -> intOp False w (\d x y -> unitOL $ LSL d x y)         MO_U_Shr w -> intOp False w (\d x y -> unitOL $ LSR d x y)         MO_S_Shr w -> intOp True  w (\d x y -> unitOL $ ASR d x y)@@ -1012,7 +1142,7 @@    where     isNbitEncodeable :: Int -> Integer -> Bool-    isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)+    isNbitEncodeable n_bits i = let shift = n_bits - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)      -- N.B. MUL does not set the overflow flag.     -- These implementations are based on output from GCC 11.@@ -1075,13 +1205,16 @@ -- | Is a given number encodable as a bitmask immediate? -- -- https://stackoverflow.com/questions/30904718/range-of-immediate-values-in-armv8-a64-assembly-isAArch64Bitmask :: Integer -> Bool+isAArch64Bitmask :: Width -> Integer -> Bool -- N.B. zero and ~0 are not encodable as bitmask immediates-isAArch64Bitmask 0  = False-isAArch64Bitmask n-  | n == bit 64 - 1 = False-isAArch64Bitmask n  =-    check 64 || check 32 || check 16 || check 8+isAArch64Bitmask width n =+  assert (width `elem` [W32,W64]) $+  case n of+    0 -> False+    _ | n == bit (widthInBits width) - 1+      -> False -- 1111...1111+      | otherwise+      -> (width == W64 && check 64) || check 32 || check 16 || check 8   where     -- Check whether @n@ can be represented as a subpattern of the given     -- width.@@ -1148,20 +1281,8 @@  -- OPTIMIZATION WARNING: Addressing modes. -- Addressing options:--- LDUR/STUR: imm9: -256 - 255-getAmode platform _ (CmmRegOff reg off) | -256 <= off, off <= 255-  = return $ Amode (AddrRegImm reg' off') nilOL-    where reg' = getRegisterReg platform reg-          off' = ImmInt off--- LDR/STR: imm12: if reg is 32bit: 0 -- 16380 in multiples of 4-getAmode platform W32 (CmmRegOff reg off)-  | 0 <= off, off <= 16380, off `mod` 4 == 0-  = return $ Amode (AddrRegImm reg' off') nilOL-    where reg' = getRegisterReg platform reg-          off' = ImmInt off--- LDR/STR: imm12: if reg is 64bit: 0 -- 32760 in multiples of 8-getAmode platform W64 (CmmRegOff reg off)-  | 0 <= off, off <= 32760, off `mod` 8 == 0+getAmode platform w (CmmRegOff reg off)+  | isOffsetImm off w   = return $ Amode (AddrRegImm reg' off') nilOL     where reg' = getRegisterReg platform reg           off' = ImmInt off@@ -1170,15 +1291,15 @@ -- CmmStore (CmmMachOp (MO_Add w) [CmmLoad expr, CmmLit (CmmInt n w')]) (expr2) -- E.g. a CmmStoreOff really. This can be translated to `str $expr2, [$expr, #n ] -- for `n` in range.-getAmode _platform _ (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])-  | -256 <= off, off <= 255+getAmode _platform w (CmmMachOp (MO_Add _w) [expr, CmmLit (CmmInt off _w')])+  | isOffsetImm (fromIntegral off) w   = do (reg, _format, code) <- getSomeReg expr        return $ Amode (AddrRegImm reg (ImmInteger off)) code -getAmode _platform _ (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])-  | -256 <= -off, -off <= 255+getAmode _platform w (CmmMachOp (MO_Sub _w) [expr, CmmLit (CmmInt off _w')])+  | isOffsetImm (fromIntegral $ -off) w   = do (reg, _format, code) <- getSomeReg expr-       return $ Amode (AddrRegImm reg (ImmInteger (-off))) code+       return $ Amode (AddrRegImm reg (ImmInteger $ -off)) code  -- Generic case getAmode _platform _ expr@@ -1605,9 +1726,9 @@         MO_U_Mul2     _w -> unsupported mop          -- Memory Ordering-        -- TODO DMBSY is probably *way* too much!-        MO_ReadBarrier      ->  return (unitOL DMBSY, Nothing)-        MO_WriteBarrier     ->  return (unitOL DMBSY, Nothing)+        MO_AcquireFence     ->  return (unitOL DMBISH, Nothing)+        MO_ReleaseFence     ->  return (unitOL DMBISH, Nothing)+        MO_SeqCstFence      ->  return (unitOL DMBISH, Nothing)         MO_Touch            ->  return (nilOL, Nothing) -- Keep variables live (when using interior pointers)         -- Prefetch         MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint.

@@ -18,7 +18,6 @@  import GHC.Platform.Regs import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.CLabel@@ -79,7 +78,6 @@    -- 1. Arithmetic Instructions ------------------------------------------------   ADD dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)-  CMN l r                  -> usage (regOp l ++ regOp r, [])   CMP l r                  -> usage (regOp l ++ regOp r, [])   MSUB dst src1 src2 src3  -> usage (regOp src1 ++ regOp src2 ++ regOp src3, regOp dst)   MUL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)@@ -102,18 +100,14 @@   -- 3. Logical and Move Instructions ------------------------------------------   AND dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   ASR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)-  BIC dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)-  BICS dst src1 src2       -> usage (regOp src1 ++ regOp src2, regOp dst)-  EON dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   EOR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   LSL dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   LSR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)   MOV dst src              -> usage (regOp src, regOp dst)   MOVK dst src             -> usage (regOp src, regOp dst)+  MOVZ dst src             -> usage (regOp src, regOp dst)   MVN dst src              -> usage (regOp src, regOp dst)   ORR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)-  ROR dst src1 src2        -> usage (regOp src1 ++ regOp src2, regOp dst)-  TST src1 src2            -> usage (regOp src1 ++ regOp src2, [])   -- 4. Branch Instructions ----------------------------------------------------   J t                      -> usage (regTarget t, [])   B t                      -> usage (regTarget t, [])@@ -130,12 +124,9 @@   STLR _ src dst           -> usage (regOp src ++ regOp dst, [])   LDR _ dst src            -> usage (regOp src, regOp dst)   LDAR _ dst src           -> usage (regOp src, regOp dst)-  -- TODO is this right? see STR, which I'm only partial about being right?-  STP _ src1 src2 dst      -> usage (regOp src1 ++ regOp src2 ++ regOp dst, [])-  LDP _ dst1 dst2 src      -> usage (regOp src, regOp dst1 ++ regOp dst2)    -- 8. Synchronization Instructions --------------------------------------------  DMBSY                    -> usage ([], [])+  DMBISH                   -> usage ([], [])    -- 9. Floating Point Instructions --------------------------------------------   FCVT dst src             -> usage (regOp src, regOp dst)@@ -176,8 +167,6 @@         interesting _        (RegReal (RealRegSingle (-1))) = False         interesting platform (RegReal (RealRegSingle i))    = freeReg platform i --- Note [AArch64 Register assignments]--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- Save caller save registers -- This is x0-x18 --@@ -200,8 +189,6 @@ -- '---------------------------------------------------------------------------------------------------------------------------------------------------------------' -- IR: Indirect result location register, IP: Intra-procedure register, PL: Platform register, FP: Frame pointer, LR: Link register, SP: Stack pointer -- BR: Base, SL: SpLim------ TODO: The zero register is currently mapped to -1 but should get it's own separate number. callerSavedRegisters :: [Reg] callerSavedRegisters     = map regSingle [0..18]@@ -221,7 +208,6 @@     DELTA{}             -> instr     -- 1. Arithmetic Instructions ----------------------------------------------     ADD o1 o2 o3   -> ADD (patchOp o1) (patchOp o2) (patchOp o3)-    CMN o1 o2      -> CMN (patchOp o1) (patchOp o2)     CMP o1 o2      -> CMP (patchOp o1) (patchOp o2)     MSUB o1 o2 o3 o4 -> MSUB (patchOp o1) (patchOp o2) (patchOp o3) (patchOp o4)     MUL o1 o2 o3   -> MUL (patchOp o1) (patchOp o2) (patchOp o3)@@ -244,20 +230,15 @@      -- 3. Logical and Move Instructions ----------------------------------------     AND o1 o2 o3   -> AND  (patchOp o1) (patchOp o2) (patchOp o3)-    ANDS o1 o2 o3  -> ANDS (patchOp o1) (patchOp o2) (patchOp o3)     ASR o1 o2 o3   -> ASR  (patchOp o1) (patchOp o2) (patchOp o3)-    BIC o1 o2 o3   -> BIC  (patchOp o1) (patchOp o2) (patchOp o3)-    BICS o1 o2 o3  -> BICS (patchOp o1) (patchOp o2) (patchOp o3)-    EON o1 o2 o3   -> EON  (patchOp o1) (patchOp o2) (patchOp o3)     EOR o1 o2 o3   -> EOR  (patchOp o1) (patchOp o2) (patchOp o3)     LSL o1 o2 o3   -> LSL  (patchOp o1) (patchOp o2) (patchOp o3)     LSR o1 o2 o3   -> LSR  (patchOp o1) (patchOp o2) (patchOp o3)     MOV o1 o2      -> MOV  (patchOp o1) (patchOp o2)     MOVK o1 o2     -> MOVK (patchOp o1) (patchOp o2)+    MOVZ o1 o2     -> MOVZ (patchOp o1) (patchOp o2)     MVN o1 o2      -> MVN  (patchOp o1) (patchOp o2)     ORR o1 o2 o3   -> ORR  (patchOp o1) (patchOp o2) (patchOp o3)-    ROR o1 o2 o3   -> ROR  (patchOp o1) (patchOp o2) (patchOp o3)-    TST o1 o2      -> TST  (patchOp o1) (patchOp o2)      -- 4. Branch Instructions --------------------------------------------------     J t            -> J (patchTarget t)@@ -275,11 +256,9 @@     STLR f o1 o2   -> STLR f (patchOp o1) (patchOp o2)     LDR f o1 o2    -> LDR f (patchOp o1) (patchOp o2)     LDAR f o1 o2   -> LDAR f (patchOp o1) (patchOp o2)-    STP f o1 o2 o3 -> STP f (patchOp o1) (patchOp o2) (patchOp o3)-    LDP f o1 o2 o3 -> LDP f (patchOp o1) (patchOp o2) (patchOp o3)      -- 8. Synchronization Instructions ------------------------------------------    DMBSY          -> DMBSY+    DMBISH         -> DMBISH      -- 9. Floating Point Instructions ------------------------------------------     FCVT o1 o2     -> FCVT (patchOp o1) (patchOp o2)@@ -332,12 +311,6 @@ jumpDestsOfInstr (BCOND _ t) = [ id | TBlock id <- [t]] jumpDestsOfInstr _ = [] -canFallthroughTo :: Instr -> BlockId -> Bool-canFallthroughTo (ANN _ i) bid = canFallthroughTo i bid-canFallthroughTo (J (TBlock target)) bid = bid == target-canFallthroughTo (B (TBlock target)) bid = bid == target-canFallthroughTo _ _ = False- -- | Change the destination of this jump instruction. -- Used in the linear allocator when adding fixup blocks for join -- points.@@ -389,9 +362,8 @@     where         a .&~. b = a .&. (complement b) -        fmt = case reg of-            RegReal (RealRegSingle n) | n < 32 -> II64-            _                                  -> FF64+        fmt = fmtOfRealReg (case reg of { RegReal r -> r; _ -> panic "Expected real reg"})+         mkIp0SpillAddr imm = ANN (text "Spill: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))         mkStrSp imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))         mkStrIp0 imm = ANN (text "Spill@" <> int (off - delta)) $ STR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 16) (ImmInt imm)))@@ -416,9 +388,7 @@     where         a .&~. b = a .&. (complement b) -        fmt = case reg of-            RegReal (RealRegSingle n) | n < 32 -> II64-            _                                  -> FF64+        fmt = fmtOfRealReg (case reg of { RegReal r -> r; _ -> panic "Expected real reg"})          mkIp0SpillAddr imm = ANN (text "Reload: IP0 <- SP + " <> int imm) $ ADD ip0 sp (OpImm (ImmInt imm))         mkLdrSp imm = ANN (text "Reload@" <> int (off - delta)) $ LDR fmt (OpReg W64 reg) (OpAddr (AddrRegImm (regSingle 31) (ImmInt imm)))@@ -441,7 +411,6 @@     COMMENT{}   -> True     MULTILINE_COMMENT{} -> True     LOCATION{}  -> True-    LDATA{}     -> True     NEWBLOCK{}  -> True     DELTA{}     -> True     PUSH_STACK_FRAME -> True@@ -544,11 +513,6 @@     -- location pseudo-op (file, line, col, name)     | LOCATION Int Int Int String -    -- some static data spat out during code-    -- generation.  Will be extracted before-    -- pretty-printing.-    | LDATA   Section RawCmmStatics-     -- start a new basic block.  Useful during     -- codegen, removed later.  Preceding     -- instruction should be a jump, as per the@@ -575,7 +539,6 @@     -- | ADDS Operand Operand Operand -- rd = rn + rm     -- | ADR ...     -- | ADRP ...-    | CMN Operand Operand -- rd + op2     | CMP Operand Operand -- rd - op2     -- | MADD ...     -- | MNEG ...@@ -616,31 +579,22 @@      -- 3. Logical and Move Instructions ----------------------------------------     | AND Operand Operand Operand -- rd = rn & op2-    | ANDS Operand Operand Operand -- rd = rn & op2     | ASR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits-    | BIC Operand Operand Operand -- rd = rn & ~op2-    | BICS Operand Operand Operand -- rd = rn & ~op2-    | EON Operand Operand Operand -- rd = rn ⊕ ~op2     | EOR Operand Operand Operand -- rd = rn ⊕ op2     | LSL Operand Operand Operand -- rd = rn ≪ rm  or rd = rn ≪ #i, i is 6 bits     | LSR Operand Operand Operand -- rd = rn ≫ rm  or rd = rn ≫ #i, i is 6 bits     | MOV Operand Operand -- rd = rn  or  rd = #i     | MOVK Operand Operand     -- | MOVN Operand Operand-    -- | MOVZ Operand Operand+    | MOVZ Operand Operand     | MVN Operand Operand -- rd = ~rn-    | ORN Operand Operand Operand -- rd = rn | ~op2     | ORR Operand Operand Operand -- rd = rn | op2-    | ROR Operand Operand Operand -- rd = rn ≫ rm  or  rd = rn ≫ #i, i is 6 bits-    | TST Operand Operand -- rn & op2     -- Load and stores.     -- TODO STR/LDR might want to change to STP/LDP with XZR for the second register.     | STR Format Operand Operand -- str Xn, address-mode // Xn -> *addr     | STLR Format Operand Operand -- stlr Xn, address-mode // Xn -> *addr     | LDR Format Operand Operand -- ldr Xn, address-mode // Xn <- *addr     | LDAR Format Operand Operand -- ldar Xn, address-mode // Xn <- *addr-    | STP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn -> *addr, Xm -> *(addr + 8)-    | LDP Format Operand Operand Operand -- stp Xn, Xm, address-mode // Xn <- *addr, Xm <- *(addr + 8)      -- Conditional instructions     | CSET Operand Cond   -- if(cond) op <- 1 else op <- 0@@ -654,7 +608,7 @@     | BCOND Cond Target   -- branch with condition. b.<cond>      -- 8. Synchronization Instructions ------------------------------------------    | DMBSY+    | DMBISH     -- 9. Floating Point Instructions     -- Float ConVerT     | FCVT Operand Operand@@ -680,7 +634,6 @@       MULTILINE_COMMENT{} -> "COMMENT"       ANN{} -> "ANN"       LOCATION{} -> "LOCATION"-      LDATA{} -> "LDATA"       NEWBLOCK{} -> "NEWBLOCK"       DELTA{} -> "DELTA"       SXTB{} -> "SXTB"@@ -690,7 +643,6 @@       PUSH_STACK_FRAME{} -> "PUSH_STACK_FRAME"       POP_STACK_FRAME{} -> "POP_STACK_FRAME"       ADD{} -> "ADD"-      CMN{} -> "CMN"       CMP{} -> "CMP"       MSUB{} -> "MSUB"       MUL{} -> "MUL"@@ -705,27 +657,19 @@       SBFX{} -> "SBFX"       UBFX{} -> "UBFX"       AND{} -> "AND"-      ANDS{} -> "ANDS"       ASR{} -> "ASR"-      BIC{} -> "BIC"-      BICS{} -> "BICS"-      EON{} -> "EON"       EOR{} -> "EOR"       LSL{} -> "LSL"       LSR{} -> "LSR"       MOV{} -> "MOV"       MOVK{} -> "MOVK"+      MOVZ{} -> "MOVZ"       MVN{} -> "MVN"-      ORN{} -> "ORN"       ORR{} -> "ORR"-      ROR{} -> "ROR"-      TST{} -> "TST"       STR{} -> "STR"       STLR{} -> "STLR"       LDR{} -> "LDR"       LDAR{} -> "LDAR"-      STP{} -> "STP"-      LDP{} -> "LDP"       CSET{} -> "CSET"       CBZ{} -> "CBZ"       CBNZ{} -> "CBNZ"@@ -733,7 +677,7 @@       B{} -> "B"       BL{} -> "BL"       BCOND{} -> "BCOND"-      DMBSY{} -> "DMBSY"+      DMBISH{} -> "DMBISH"       FCVT{} -> "FCVT"       SCVTF{} -> "SCVTF"       FCVTZS{} -> "FCVTZS"@@ -788,6 +732,9 @@ wzr = OpReg W32 (RegReal (RealRegSingle (-1))) sp  = OpReg W64 (RegReal (RealRegSingle 31)) ip0 = OpReg W64 (RegReal (RealRegSingle 16))++reg_zero :: Reg+reg_zero = RegReal (RealRegSingle (-1))  _x :: Int -> Operand _x i = OpReg W64 (RegReal (RealRegSingle i))

@@ -16,7 +16,6 @@ import GHC.CmmToAsm.Utils  import GHC.Cmm hiding (topInfoTable)-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label  import GHC.Cmm.BlockId@@ -317,7 +316,6 @@          | w == W64 = text "sp"          | w == W32 = text "wsp" -    -- See Note [AArch64 Register assignments]     ppr_reg_no w i          | i < 0, w == W32 = text "wzr"          | i < 0, w == W64 = text "xzr"@@ -358,7 +356,6 @@                       -- in the final instruction stream. But we still want to be able to                       -- print it for debugging purposes.                       line (text "BLOCK " <> pprAsmLabel platform (blockLbl blockid))-  LDATA _ _  -> panic "pprInstr: LDATA"    -- Pseudo Instructions ------------------------------------------------------- @@ -372,7 +369,6 @@   ADD  o1 o2 o3     | isFloatOp o1 && isFloatOp o2 && isFloatOp o3 -> op3 (text "\tfadd") o1 o2 o3     | otherwise -> op3 (text "\tadd") o1 o2 o3-  CMN  o1 o2    -> op2 (text "\tcmn") o1 o2   CMP  o1 o2     | isFloatOp o1 && isFloatOp o2 -> op2 (text "\tfcmp") o1 o2     | otherwise -> op2 (text "\tcmp") o1 o2@@ -407,11 +403,7 @@    -- 3. Logical and Move Instructions ------------------------------------------   AND o1 o2 o3  -> op3 (text "\tand") o1 o2 o3-  ANDS o1 o2 o3 -> op3 (text "\tands") o1 o2 o3   ASR o1 o2 o3  -> op3 (text "\tasr") o1 o2 o3-  BIC o1 o2 o3  -> op3 (text "\tbic") o1 o2 o3-  BICS o1 o2 o3 -> op3 (text "\tbics") o1 o2 o3-  EON o1 o2 o3  -> op3 (text "\teon") o1 o2 o3   EOR o1 o2 o3  -> op3 (text "\teor") o1 o2 o3   LSL o1 o2 o3  -> op3 (text "\tlsl") o1 o2 o3   LSR o1 o2 o3  -> op3 (text "\tlsr") o1 o2 o3@@ -419,11 +411,9 @@     | isFloatOp o1 || isFloatOp o2 -> op2 (text "\tfmov") o1 o2     | otherwise                    -> op2 (text "\tmov") o1 o2   MOVK o1 o2    -> op2 (text "\tmovk") o1 o2+  MOVZ o1 o2    -> op2 (text "\tmovz") o1 o2   MVN o1 o2     -> op2 (text "\tmvn") o1 o2-  ORN o1 o2 o3  -> op3 (text "\torn") o1 o2 o3   ORR o1 o2 o3  -> op3 (text "\torr") o1 o2 o3-  ROR o1 o2 o3  -> op3 (text "\tror") o1 o2 o3-  TST o1 o2     -> op2 (text "\ttst") o1 o2    -- 4. Branch Instructions ----------------------------------------------------   J t            -> pprInstr platform (B t)@@ -527,11 +517,9 @@   LDR _f o1 o2 -> op2 (text "\tldr") o1 o2   LDAR _f o1 o2 -> op2 (text "\tldar") o1 o2 -  STP _f o1 o2 o3 -> op3 (text "\tstp") o1 o2 o3-  LDP _f o1 o2 o3 -> op3 (text "\tldp") o1 o2 o3-   -- 8. Synchronization Instructions --------------------------------------------  DMBSY -> line $ text "\tdmb sy"+  DMBISH -> line $ text "\tdmb ish"+   -- 9. Floating Point Instructions --------------------------------------------   FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2   SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2

@@ -17,7 +17,6 @@ import GHC.Utils.Panic import GHC.Platform --- TODO: Should this include the zero register? allMachRegNos   :: [RegNo] allMachRegNos   = [0..31] ++ [32..63] -- allocatableRegs is allMachRegNos with the fixed-use regs removed.@@ -78,6 +77,8 @@                 -- narrow to the width: a CmmInt might be out of                 -- range, but we assume that ImmInteger only contains                 -- in-range values.  A signed value should be fine here.+                -- AK: We do call this with out of range values, however+                -- it just truncates as we would expect. litToImm (CmmFloat f W32)    = ImmFloat f litToImm (CmmFloat f W64)    = ImmDouble f litToImm (CmmLabel l)        = ImmCLbl l@@ -147,6 +148,13 @@ classOfRealReg (RealRegSingle i)         | i < 32        = RcInteger         | otherwise     = RcDouble++fmtOfRealReg :: RealReg -> Format+fmtOfRealReg real_reg =+  case classOfRealReg real_reg of+            RcInteger -> II64+            RcDouble  -> FF64+            RcFloat   -> panic "No float regs on arm"  regDotColor :: RealReg -> SDoc regDotColor reg

@@ -26,7 +26,6 @@  import GHC.Cmm import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label  import GHC.Types.Unique.FM@@ -38,7 +37,6 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Utils.Misc  import Data.List (sortOn, sortBy, nub)@@ -739,10 +737,6 @@             = [masterChain]             | (rest,entry) <- breakChainAt entry masterChain             = [entry,rest]-#if __GLASGOW_HASKELL__ <= 810-            | otherwise = pprPanic "Entry point eliminated" $-                            ppr masterChain-#endif          blockList             = assert (noDups [masterChain])@@ -777,9 +771,10 @@ dropJumps _    [] = [] dropJumps info (BasicBlock lbl ins:todo)     | Just ins <- nonEmpty ins --This can happen because of shortcutting+    , [dest] <- jumpDestsOfInstr (NE.last ins)     , BasicBlock nextLbl _ : _ <- todo-    , canFallthroughTo (NE.last ins) nextLbl-    , not (mapMember nextLbl info)+    , not (mapMember dest info)+    , nextLbl == dest     = BasicBlock lbl (NE.init ins) : dropJumps info todo     | otherwise     = BasicBlock lbl ins : dropJumps info todo

@@ -48,7 +48,6 @@ import GHC.Cmm as Cmm  import GHC.Cmm.Switch-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.Dataflow.Block import qualified GHC.Cmm.Dataflow.Graph as G@@ -76,7 +75,6 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain -- DEBUGGING ONLY --import GHC.Cmm.DebugBlock --import GHC.Data.OrdList

@@ -1,7 +1,3 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE RankNTypes #-} {-# LANGUAGE Strict #-}  {- |

@@ -29,7 +29,6 @@ import System.FilePath  import qualified GHC.Cmm.Dataflow.Label as H-import qualified GHC.Cmm.Dataflow.Collections as H  -- | Generate DWARF/debug information dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]

@@ -71,16 +71,10 @@                 :: instr -> Bool  -        -- | Give the possible *local block* destinations of this jump instruction.+        -- | Give the possible destinations of this jump instruction.         --      Must be defined for all jumpish instructions.         jumpDestsOfInstr                 :: instr -> [BlockId]--        -- | Check if the instr always transfers control flow-        -- to the given block. Used by code layout to eliminate-        -- jumps that can be replaced by fall through.-        canFallthroughTo-                :: instr -> BlockId -> Bool           -- | Change the destination of this jump instruction.

@@ -55,7 +55,6 @@ import GHC.CmmToAsm.Types  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel           ( CLabel ) import GHC.Cmm.DebugBlock@@ -79,15 +78,8 @@     cmmTopCodeGen             :: RawCmmDecl -> NatM [NatCmmDecl statics instr],     generateJumpTableForInstr :: instr -> Maybe (NatCmmDecl statics instr),     getJumpDestBlockId        :: jumpDest -> Maybe BlockId,-    -- | Does this jump always jump to a single destination and is shortcutable?-    ---    -- We use this to determine shortcutable instructions - See Note [What is shortcutting]-    -- Note that if we return a destination here we *most* support the relevant shortcutting in-    -- shortcutStatics for jump tables and shortcutJump for the instructions itself.     canShortcut               :: instr -> Maybe jumpDest,-    -- | Replace references to blockIds with other destinations - used to update jump tables.     shortcutStatics           :: (BlockId -> Maybe jumpDest) -> statics -> statics,-    -- | Change the jump destination(s) of an instruction.     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,     -- | 'Module' is only for printing internal labels. See Note [Internal proc     -- labels] in CLabel.@@ -112,25 +104,6 @@     -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@     -- when possible.     }--{- Note [supporting shortcutting]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-For the concept of shortcutting see Note [What is shortcutting].--In order to support shortcutting across multiple backends uniformly we-use canShortcut, shortcutStatics and shortcutJump.--canShortcut tells us if the backend support shortcutting of a instruction-and if so what destination we should retarget instruction to instead.--shortcutStatics exists to allow us to update jump destinations in jump tables.--shortcutJump updates the instructions itself.--A backend can opt out of those by always returning Nothing for canShortcut-and implementing shortcutStatics/shortcutJump as \_ x -> x---}  {- Note [pprNatCmmDeclS and pprNatCmmDeclH] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~

@@ -60,7 +60,7 @@ import GHC.CmmToAsm.Types  -import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.CLabel import GHC.Cmm.Utils (cmmLoadBWord)

@@ -46,7 +46,6 @@    patchRegsOfInstr    = PPC.patchRegsOfInstr    isJumpishInstr      = PPC.isJumpishInstr    jumpDestsOfInstr    = PPC.jumpDestsOfInstr-   canFallthroughTo    = PPC.canFallthroughTo    patchJumpInstr      = PPC.patchJumpInstr    mkSpillInstr        = PPC.mkSpillInstr    mkLoadInstr         = PPC.mkLoadInstr

@@ -61,7 +61,6 @@ import GHC.Data.OrdList import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Panic.Plain  import Control.Monad    ( mapAndUnzipM, when ) import Data.Word@@ -504,6 +503,9 @@     Amode addr addr_code <- getAmode DS mem     return (Any II64 (\dst -> addr_code `snocOL` LA II32 dst addr)) +getRegister' config platform (CmmMachOp (MO_RelaxedRead w) [e]) =+      getRegister' config platform (CmmLoad e (cmmBits w) NaturallyAligned)+ getRegister' config platform (CmmMachOp mop [x]) -- unary MachOps   = case mop of       MO_Not rep   -> triv_ucode_int rep NOT@@ -1126,10 +1128,12 @@          -> [CmmFormal]        -- where to put the result          -> [CmmActual]        -- arguments (of mixed type)          -> NatM InstrBlock-genCCall (PrimTarget MO_ReadBarrier) _ _+genCCall (PrimTarget MO_AcquireFence) _ _  = return $ unitOL LWSYNC-genCCall (PrimTarget MO_WriteBarrier) _ _+genCCall (PrimTarget MO_ReleaseFence) _ _  = return $ unitOL LWSYNC+genCCall (PrimTarget MO_SeqCstFence) _ _+ = return $ unitOL HWSYNC  genCCall (PrimTarget MO_Touch) _ _  = return $ nilOL@@ -1766,7 +1770,7 @@                                 _ -> panic "genCall': unknown calling conv."          argReps = map (cmmExprType platform) args-        (_, argHints) = foreignTargetHints target+        (argHints, _) = foreignTargetHints target          roundTo a x | x `mod` a == 0 = x                     | otherwise = x + a - (x `mod` a)@@ -2094,8 +2098,9 @@                     MO_AddIntC {}    -> unsupported                     MO_SubIntC {}    -> unsupported                     MO_U_Mul2 {}     -> unsupported-                    MO_ReadBarrier   -> unsupported-                    MO_WriteBarrier  -> unsupported+                    MO_AcquireFence  -> unsupported+                    MO_ReleaseFence  -> unsupported+                    MO_SeqCstFence   -> unsupported                     MO_Touch         -> unsupported                     MO_Prefetch_Data _ -> unsupported                 unsupported = panic ("outOfLineCmmOp: " ++ show mop

@@ -22,7 +22,6 @@    , patchJumpInstr    , patchRegsOfInstr    , jumpDestsOfInstr-   , canFallthroughTo    , takeRegRegMoveInstr    , takeDeltaInstr    , mkRegRegMoveInstr@@ -48,7 +47,6 @@  import GHC.Platform.Regs import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Cmm.Info@@ -510,13 +508,6 @@     BL{}        -> True     JMP{}       -> True     _           -> False--canFallthroughTo :: Instr -> BlockId -> Bool-canFallthroughTo instr bid- = case instr of-        BCC _ target _      -> target == bid-        BCCFAR _ target _   -> target == bid-        _                   -> False   -- | Checks whether this instruction is a jump/branch instruction.

@@ -29,7 +29,6 @@ import GHC.CmmToAsm.Utils  import GHC.Cmm hiding (topInfoTable)-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label  import GHC.Cmm.BlockId

@@ -385,11 +385,6 @@         , RegReal _             <- r2         = graph -#if __GLASGOW_HASKELL__ <= 810-        | otherwise-        = panic "graphAddCoalesce"-#endif-  -- | Patch registers in code using the reg -> reg mapping in this graph. patchRegsFromGraph

@@ -15,7 +15,7 @@ import GHC.Platform.Reg import GHC.Cmm hiding (RegSet) import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label  import GHC.Utils.Monad import GHC.Utils.Monad.State.Strict

@@ -49,7 +49,7 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label  import Data.List (nub, foldl1', find) import Data.Maybe@@ -398,12 +398,6 @@                         $ IntSet.toList slotsReloadedByTargets                  cleanBackward liveSlotsOnEntry noReloads' (li : acc) instrs--#if __GLASGOW_HASKELL__ <= 810-        -- some other instruction-        | otherwise-        = cleanBackward liveSlotsOnEntry noReloads (li : acc) instrs-#endif   -- | Combine the associations from all the inward control flow edges.

@@ -24,7 +24,6 @@  import GHC.Data.Graph.Base -import GHC.Cmm.Dataflow.Collections (mapLookup) import GHC.Cmm.Dataflow.Label import GHC.Cmm import GHC.Types.Unique.FM

@@ -1,8 +1,3 @@-{-# LANGUAGE BangPatterns, DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} 

@@ -102,7 +102,8 @@         -> Triv VirtualReg RegClass RealReg  trivColorable platform virtualRegSqueeze realRegSqueeze RcInteger conflicts exclusions-        | let cALLOCATABLE_REGS_INTEGER+        | -- Allocatable are all regs of this class, where freeReg == True (MachRegs.h)+          let cALLOCATABLE_REGS_INTEGER                   =        (case platformArch platform of                             ArchX86       -> 3                             ArchX86_64    -> 5@@ -110,6 +111,9 @@                             ArchPPC_64 _  -> 15                             ArchARM _ _ _ -> panic "trivColorable ArchARM"                             -- N.B. x18 is reserved by the platform on AArch64/Darwin+                            -- 32 - Base - Sp - Hp - R1..R6 - SpLim - IP0 - SP - LR - FP - X18+                            -- -> 32 - 15 = 17+                            -- (one stack pointer for Haskell, one for C)                             ArchAArch64   -> 17                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"@@ -174,13 +178,12 @@                             ArchX86_64    -> 10                             -- in x86_64 there are 16 XMM registers                             -- xmm0 .. xmm15, here 10 is a-                            -- "dont need to solve conflicts" count that+                            -- "don't need to solve conflicts" count that                             -- was chosen at some point in the past.                             ArchPPC       -> 26                             ArchPPC_64 _  -> 20                             ArchARM _ _ _ -> panic "trivColorable ArchARM"-                            ArchAArch64   -> 24 -- 32 - F1 .. F4, D1..D4 - it's odd but see Note [AArch64 Register assignments] for our reg use.-                                                -- Seems we reserve different registers for D1..D4 and F1 .. F4 somehow, we should fix this.+                            ArchAArch64   -> 28 -- 32 - D1..D4                             ArchAlpha     -> panic "trivColorable ArchAlpha"                             ArchMipseb    -> panic "trivColorable ArchMipseb"                             ArchMipsel    -> panic "trivColorable ArchMipsel"

@@ -1,5 +1,3 @@-{-# LANGUAGE BangPatterns, ScopedTypeVariables #-}-{-# LANGUAGE ConstraintKinds #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -124,7 +122,7 @@ import GHC.Platform.Reg.Class (RegClass(..))  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (RegSet)  import GHC.Data.Graph.Directed

@@ -8,11 +8,11 @@  import GHC.Utils.Outputable import GHC.Utils.Panic-import GHC.Utils.Misc( HasDebugCallStack ) import GHC.Platform  import Data.Word +import GHC.Stack -- AArch64 has 32 64bit general purpose register r0..r30, and zr/sp -- AArch64 has 32 128bit floating point registers v0..v31 as part of the NEON -- extension in Armv8-A.@@ -65,7 +65,7 @@ showBits w = map (\i -> if testBit w i then '1' else '0') [0..31]  -- FR instance implementation (See Linear.FreeRegs)-allocateReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs+allocateReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs allocateReg (RealRegSingle r) (FreeRegs g f)     | r > 31 && testBit f (r - 32) = FreeRegs g (clearBit f (r - 32))     | r < 32 && testBit g r = FreeRegs (clearBit g r) f@@ -127,7 +127,7 @@ initFreeRegs :: Platform -> FreeRegs initFreeRegs platform = foldl' (flip releaseReg) noFreeRegs (allocatableRegs platform) -releaseReg :: HasDebugCallStack => RealReg -> FreeRegs -> FreeRegs+releaseReg :: HasCallStack => RealReg -> FreeRegs -> FreeRegs releaseReg (RealRegSingle r) (FreeRegs g f)   | r > 31 && testBit f (r - 32) = pprPanic "Linear.AArch64.releaseReg" (text  "can't release non-allocated reg v" <> int (r - 32))   | r < 32 && testBit g r = pprPanic "Linear.AArch64.releaseReg" (text "can't release non-allocated reg x" <> int r)

@@ -34,7 +34,7 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Supply import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import GHC.CmmToAsm.Reg.Utils  data ReadingOrWriting = Reading | Writing deriving (Eq,Ord)

@@ -23,7 +23,7 @@ import GHC.Platform.Reg  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label import GHC.Data.Graph.Directed import GHC.Utils.Panic import GHC.Utils.Monad (concatMapM)

@@ -1,10 +1,4 @@-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE DeriveFunctor #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}   {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}@@ -52,7 +46,6 @@ import GHC.CmmToAsm.Utils  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (RegSet, emptyRegSet) @@ -133,11 +126,6 @@                 Instr instr     -> isJumpishInstr instr                 _               -> False -        canFallthroughTo i bid-         = case i of-                Instr instr     -> canFallthroughTo instr bid-                _               -> False-         jumpDestsOfInstr i          = case i of                 Instr instr     -> jumpDestsOfInstr instr@@ -1006,7 +994,7 @@ livenessBack _        liveregs _        done []  = (liveregs, done)  livenessBack platform liveregs blockmap acc (instr : instrs)- = let  (liveregs', instr')     = liveness1 platform liveregs blockmap instr+ = let  !(!liveregs', instr')     = liveness1 platform liveregs blockmap instr    in   livenessBack platform liveregs' blockmap (instr' : acc) instrs  @@ -1029,15 +1017,15 @@         = (liveregs1, LiveInstr instr                         (Just $ Liveness                         { liveBorn      = emptyUniqSet-                        , liveDieRead   = mkUniqSet r_dying-                        , liveDieWrite  = mkUniqSet w_dying }))+                        , liveDieRead   = r_dying+                        , liveDieWrite  = w_dying }))          | otherwise         = (liveregs_br, LiveInstr instr                         (Just $ Liveness                         { liveBorn      = emptyUniqSet                         , liveDieRead   = mkUniqSet r_dying_br-                        , liveDieWrite  = mkUniqSet w_dying }))+                        , liveDieWrite  = w_dying }))          where             !(RU read written) = regUsageOfInstr platform instr@@ -1049,10 +1037,12 @@              -- registers that are not live beyond this point, are recorded             --  as dying here.-            r_dying     = [ reg | reg <- read, reg `notElem` written,+            r_dying     = mkUniqSet+                          [ reg | reg <- read, reg `notElem` written,                               not (elementOfUniqSet reg liveregs) ] -            w_dying     = [ reg | reg <- written,+            w_dying     = mkUniqSet+                          [ reg | reg <- written,                              not (elementOfUniqSet reg liveregs) ]              -- union in the live regs from all the jump destinations of this@@ -1072,6 +1062,6 @@             -- registers that are live only in the branch targets should             -- be listed as dying here.             live_branch_only = live_from_branch `minusUniqSet` liveregs-            r_dying_br  = nonDetEltsUniqSet (mkUniqSet r_dying `unionUniqSets`+            r_dying_br  = nonDetEltsUniqSet (r_dying `unionUniqSets`                                              live_branch_only)                           -- See Note [Unique Determinism and code generation]

@@ -7,7 +7,6 @@ import GHC.Prelude  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm hiding (topInfoTable) 

@@ -1,26 +1,35 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Strict #-}+{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}  module GHC.CmmToAsm.Wasm (ncgWasm) where  import Data.ByteString.Builder+import Data.ByteString.Lazy.Char8 (unpack) import Data.Maybe import Data.Semigroup import GHC.Cmm+import GHC.Cmm.ContFlowOpt+import GHC.Cmm.GenericOpt+import GHC.CmmToAsm.Config import GHC.CmmToAsm.Wasm.Asm import GHC.CmmToAsm.Wasm.FromCmm import GHC.CmmToAsm.Wasm.Types import GHC.Data.Stream (Stream, StreamS (..), runStream)+import GHC.Driver.DynFlags import GHC.Platform import GHC.Prelude import GHC.Settings import GHC.Types.Unique.Supply import GHC.Unit-import GHC.Utils.CliOption+import GHC.Utils.Logger+import GHC.Utils.Outputable (text) import System.IO  ncgWasm ::+  NCGConfig ->+  Logger ->   Platform ->   ToolSettings ->   UniqSupply ->@@ -28,27 +37,45 @@   Handle ->   Stream IO RawCmmGroup a ->   IO a-ncgWasm platform ts us loc h cmms = do-  (r, s) <- streamCmmGroups platform us cmms-  hPutBuilder h $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"-  hPutBuilder h $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s+ncgWasm ncg_config logger platform ts us loc h cmms = do+  (r, s) <- streamCmmGroups ncg_config platform us cmms+  outputWasm $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"+  outputWasm $ execWasmAsmM do_tail_call $ asmTellEverything TagI32 s   pure r   where     -- See Note [WasmTailCall]     do_tail_call = doTailCall ts +    outputWasm builder = do+      putDumpFileMaybe+        logger+        Opt_D_dump_asm+        "Asm Code"+        FormatASM+        (text . unpack $ toLazyByteString builder)+      hPutBuilder h builder+ streamCmmGroups ::+  NCGConfig ->   Platform ->   UniqSupply ->   Stream IO RawCmmGroup a ->   IO (a, WasmCodeGenState 'I32)-streamCmmGroups platform us cmms =-  go (initialWasmCodeGenState platform us) $-    runStream cmms+streamCmmGroups ncg_config platform us cmms =+  go (initialWasmCodeGenState platform us) $ runStream cmms   where     go s (Done r) = pure (r, s)     go s (Effect m) = m >>= go s-    go s (Yield cmm k) = go (wasmExecM (onCmmGroup cmm) s) k+    go s (Yield decls k) = go (wasmExecM (onCmmGroup $ map opt decls) s) k+      where+        -- Run the generic cmm optimizations like other NCGs, followed+        -- by a late control-flow optimization pass that does shrink+        -- the CFG block count in some cases.+        opt decl = case decl of+          CmmData {} -> decl+          CmmProc {} -> CmmProc info lbl live $ cmmCfgOpts False graph+            where+              (CmmProc info lbl live graph, _) = cmmToCmm ncg_config decl  doTailCall :: ToolSettings -> Bool doTailCall ts = Option "-mtail-call" `elem` as_args

@@ -12,6 +12,7 @@ import Data.ByteString (ByteString) import qualified Data.ByteString as BS import Data.ByteString.Builder+import qualified Data.ByteString.Char8 as BS8 import Data.Coerce import Data.Foldable import qualified GHC.Data.Word64Set as WS@@ -25,6 +26,7 @@ import GHC.Data.FastString import GHC.Float import GHC.Prelude+import GHC.Settings.Config (cProjectVersion) import GHC.Types.Basic import GHC.Types.Unique import GHC.Types.Unique.Map@@ -450,7 +452,8 @@ asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM () asmTellCtors _ [] = mempty asmTellCtors ty_word syms = do-  asmTellSectionHeader ".init_array"+  -- See Note [JSFFI initialization] for details+  asmTellSectionHeader ".init_array.101"   asmTellAlign $ alignmentFromWordType ty_word   for_ syms $ \sym ->     asmTellTabLine $@@ -485,7 +488,7 @@         asmTellVec           [ do               asmTellBS "ghc"-              asmTellBS "9.6"+              asmTellBS $ BS8.pack cProjectVersion           ]     ] 

@@ -628,6 +628,7 @@   WasmCodeGenM     w     (SomeWasmExpr w)+lower_CmmMachOp lbl (MO_RelaxedRead w0) [x] = lower_CmmExpr lbl (CmmLoad x (cmmBits w0) NaturallyAligned) lower_CmmMachOp lbl (MO_Add w0) xs = lower_MO_Bin_Homo_Trunc WasmAdd lbl w0 xs lower_CmmMachOp lbl (MO_Sub w0) xs = lower_MO_Bin_Homo_Trunc WasmSub lbl w0 xs lower_CmmMachOp lbl (MO_Eq w0) xs = lower_MO_Bin_Rel WasmEq lbl (cmmBits w0) xs@@ -1186,8 +1187,9 @@ lower_CallishMachOp lbl MO_F32_Fabs rs xs = lower_CMO_Un_Homo lbl "fabsf" rs xs lower_CallishMachOp lbl MO_F32_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrtf" rs xs lower_CallishMachOp lbl (MO_UF_Conv w0) rs xs = lower_MO_UF_Conv lbl w0 rs xs-lower_CallishMachOp _ MO_ReadBarrier _ _ = pure $ WasmStatements WasmNop-lower_CallishMachOp _ MO_WriteBarrier _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ MO_AcquireFence _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ MO_ReleaseFence _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ MO_SeqCstFence _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp _ MO_Touch _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp _ (MO_Prefetch_Data {}) _ _ = pure $ WasmStatements WasmNop lower_CallishMachOp lbl (MO_Memcpy {}) [] xs = do

@@ -51,7 +51,6 @@    patchRegsOfInstr        = X86.patchRegsOfInstr    isJumpishInstr          = X86.isJumpishInstr    jumpDestsOfInstr        = X86.jumpDestsOfInstr-   canFallthroughTo        = X86.canFallthroughTo    patchJumpInstr          = X86.patchJumpInstr    mkSpillInstr            = X86.mkSpillInstr    mkLoadInstr             = X86.mkLoadInstr

@@ -1,8 +1,6 @@-{-# LANGUAGE BangPatterns #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE NondecreasingIndentation #-}-{-# LANGUAGE TupleSections #-}  {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -67,7 +65,6 @@ import GHC.Cmm.Switch import GHC.Cmm import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph import GHC.Cmm.Dataflow.Label import GHC.Cmm.CLabel@@ -80,7 +77,6 @@ import GHC.Utils.Outputable import GHC.Utils.Constants (debugIsOn) import GHC.Utils.Panic-import GHC.Utils.Panic.Plain import GHC.Data.FastString import GHC.Utils.Misc import GHC.Types.Unique.Supply ( getUniqueM )@@ -524,7 +520,6 @@ assignReg_I64Code _ _    = panic "assignReg_I64Code(i386): invalid lvalue" - iselExpr64 :: HasDebugCallStack => CmmExpr -> NatM (RegCode64 InstrBlock) iselExpr64 (CmmLit (CmmInt i _)) = do   Reg64 rhi rlo <- getNewReg64@@ -551,7 +546,6 @@   let Reg64 hi lo = localReg64 local_reg   return (RegCode64 nilOL hi lo) --- we handle addition, but rather badly iselExpr64 (CmmMachOp (MO_Add _) [e1, CmmLit (CmmInt i _)]) = do    RegCode64 code1 r1hi r1lo <- iselExpr64 e1    Reg64 rhi rlo <- getNewReg64@@ -591,14 +585,34 @@                        SBB II32 (OpReg r2hi) (OpReg rhi) ]    return (RegCode64 code rhi rlo) -iselExpr64 (CmmMachOp (MO_UU_Conv _ W64) [expr]) = do+iselExpr64 (CmmMachOp (MO_UU_Conv W32 W64) [expr]) = do      code <- getAnyReg expr      Reg64 r_dst_hi r_dst_lo <- getNewReg64      return $ RegCode64 (code r_dst_lo `snocOL`-                          MOV II32 (OpImm (ImmInt 0)) (OpReg r_dst_hi))+                          XOR II32 (OpReg r_dst_hi) (OpReg r_dst_hi))                           r_dst_hi                           r_dst_lo +iselExpr64 (CmmMachOp (MO_UU_Conv W16 W64) [expr]) = do+     (rsrc, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVZxL II16 (OpReg rsrc) (OpReg r_dst_lo),+                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)+                          ])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_UU_Conv W8 W64) [expr]) = do+     (rsrc, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVZxL II8 (OpReg rsrc) (OpReg r_dst_lo),+                          XOR    II32 (OpReg r_dst_hi) (OpReg r_dst_hi)+                          ])+                          r_dst_hi+                          r_dst_lo+ iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do      code <- getAnyReg expr      Reg64 r_dst_hi r_dst_lo <- getNewReg64@@ -610,11 +624,208 @@                           r_dst_hi                           r_dst_lo +iselExpr64 (CmmMachOp (MO_SS_Conv W16 W64) [expr]) = do+     (r, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVSxL II16 (OpReg r) (OpReg eax),+                          CLTD II32,+                          MOV II32 (OpReg eax) (OpReg r_dst_lo),+                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_SS_Conv W8 W64) [expr]) = do+     (r, code) <- getByteReg expr+     Reg64 r_dst_hi r_dst_lo <- getNewReg64+     return $ RegCode64 (code `appOL` toOL [+                          MOVSxL II8 (OpReg r) (OpReg eax),+                          CLTD II32,+                          MOV II32 (OpReg eax) (OpReg r_dst_lo),+                          MOV II32 (OpReg edx) (OpReg r_dst_hi)])+                          r_dst_hi+                          r_dst_lo++iselExpr64 (CmmMachOp (MO_S_Neg _) [expr]) = do+   RegCode64 code rhi rlo <- iselExpr64 expr+   Reg64 rohi rolo <- getNewReg64+   let+        ocode = code `appOL`+                toOL [ MOV II32 (OpReg rlo) (OpReg rolo),+                       XOR II32 (OpReg rohi) (OpReg rohi),+                       NEGI II32 (OpReg rolo),+                       SBB II32 (OpReg rhi) (OpReg rohi) ]+   return (RegCode64 ocode rohi rolo)++-- To multiply two 64-bit numbers we use the following decomposition (in C notation):+--+--     ((r1hi << 32) + r1lo) * ((r2hi << 32) + r2lo)+--      = ((r2lo * r1hi) << 32)+--      + ((r1lo * r2hi) << 32)+--      + r1lo * r2lo+--+-- Note that @(r1hi * r2hi) << 64@ can be dropped because it overflows completely.++iselExpr64 (CmmMachOp (MO_Mul _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   tmp <- getNewRegNat II32+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV  II32 (OpReg r1lo) (OpReg eax),+                       MOV  II32 (OpReg r2lo) (OpReg tmp),+                       MOV  II32 (OpReg r1hi) (OpReg rhi),+                       IMUL II32 (OpReg tmp) (OpReg rhi),+                       MOV  II32 (OpReg r2hi) (OpReg rlo),+                       IMUL II32 (OpReg eax) (OpReg rlo),+                       ADD  II32 (OpReg rlo) (OpReg rhi),+                       MUL2 II32 (OpReg tmp),+                       ADD  II32 (OpReg edx) (OpReg rhi),+                       MOV  II32 (OpReg eax) (OpReg rlo)+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_S_MulMayOflo W64) _) = do+   -- Performance sensitive users won't use 32 bit so let's keep it simple:+   -- We always return a (usually false) positive.+   Reg64 rhi rlo <- getNewReg64+   let code = toOL   [+                       MOV  II32 (OpImm (ImmInt 1)) (OpReg rhi),+                       MOV  II32 (OpImm (ImmInt 1)) (OpReg rlo)+                     ]+   return (RegCode64 code rhi rlo)+++-- To shift a 64-bit number to the left we use the SHLD and SHL instructions.+-- We use SHLD to shift the bits in @rhi@ to the left while copying+-- high bits from @rlo@ to fill the new space in the low bits of @rhi@.+-- That leaves @rlo@ unchanged, so we use SHL to shift the bits of @rlo@ left.+-- However, both these instructions only use the lowest 5 bits from %cl to do+-- their shifting. So if the sixth bit (0x32) is set then we additionally move+-- the contents of @rlo@ to @rhi@ and clear @rlo@.++iselExpr64 (CmmMachOp (MO_Shl _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   code2 <- getAnyReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 ecx `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       SHLD II32 (OpReg ecx) (OpReg rlo) (OpReg rhi),+                       SHL II32 (OpReg ecx) (OpReg rlo),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rlo) (OpReg rhi),+                       XOR II32 (OpReg rlo) (OpReg rlo),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++-- Similar to above, however now we're shifting to the right+-- and we're doing a signed shift which means that @rhi@ needs+-- to be set to either 0 if @rhi@ is positive or 0xffffffff otherwise,+-- and if the sixth bit of %cl is set (so the shift amount is more than 32).+-- To accomplish that we shift @rhi@ by 31.++iselExpr64 (CmmMachOp (MO_S_Shr _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   (r2, code2) <- getSomeReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       MOV II32 (OpReg r2) (OpReg ecx),+                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),+                       SAR II32 (OpReg ecx) (OpReg rhi),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rhi) (OpReg rlo),+                       SAR II32 (OpImm (ImmInt 31)) (OpReg rhi),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++-- Similar to the above.++iselExpr64 (CmmMachOp (MO_U_Shr _) [e1,e2]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   (r2, code2) <- getSomeReg e2+   Reg64 rhi rlo <- getNewReg64+   lbl1 <- newBlockId+   lbl2 <- newBlockId+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       MOV II32 (OpReg r2) (OpReg ecx),+                       SHRD II32 (OpReg ecx) (OpReg rhi) (OpReg rlo),+                       SHR II32 (OpReg ecx) (OpReg rhi),+                       TEST II32 (OpImm (ImmInt 32)) (OpReg ecx),+                       JXX EQQ lbl2,+                       JXX ALWAYS lbl1,+                       NEWBLOCK lbl1,+                       MOV II32 (OpReg rhi) (OpReg rlo),+                       XOR II32 (OpReg rhi) (OpReg rhi),+                       JXX ALWAYS lbl2,+                       NEWBLOCK lbl2+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmMachOp (MO_And _) [e1,e2]) = iselExpr64ParallelBin AND e1 e2+iselExpr64 (CmmMachOp (MO_Or  _) [e1,e2]) = iselExpr64ParallelBin OR  e1 e2+iselExpr64 (CmmMachOp (MO_Xor _) [e1,e2]) = iselExpr64ParallelBin XOR e1 e2++iselExpr64 (CmmMachOp (MO_Not _) [e1]) = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       NOT II32 (OpReg rlo),+                       NOT II32 (OpReg rhi)+                     ]+   return (RegCode64 code rhi rlo)++iselExpr64 (CmmRegOff r i) = iselExpr64 (mangleIndexTree r i)+ iselExpr64 expr    = do       platform <- getPlatform-      pprPanic "iselExpr64(i386)" (pdoc platform expr)+      pprPanic "iselExpr64(i386)" (pdoc platform expr $+$ text (show expr)) +iselExpr64ParallelBin :: (Format -> Operand -> Operand -> Instr)+                      -> CmmExpr -> CmmExpr -> NatM (RegCode64 (OrdList Instr))+iselExpr64ParallelBin op e1 e2 = do+   RegCode64 code1 r1hi r1lo <- iselExpr64 e1+   RegCode64 code2 r2hi r2lo <- iselExpr64 e2+   Reg64 rhi rlo <- getNewReg64+   let+        code =  code1 `appOL`+                code2 `appOL`+                toOL [ MOV II32 (OpReg r1lo) (OpReg rlo),+                       MOV II32 (OpReg r1hi) (OpReg rhi),+                       op  II32 (OpReg r2lo) (OpReg rlo),+                       op  II32 (OpReg r2hi) (OpReg rhi)+                     ]+   return (RegCode64 code rhi rlo)  -------------------------------------------------------------------------------- getRegister :: CmmExpr -> NatM Register@@ -648,6 +859,9 @@ getRegister' platform is32Bit (CmmRegOff r n)   = getRegister' platform is32Bit $ mangleIndexTree r n +getRegister' platform is32Bit (CmmMachOp (MO_RelaxedRead w) [e])+  = getRegister' platform is32Bit (CmmLoad e (cmmBits w) NaturallyAligned)+ getRegister' platform is32Bit (CmmMachOp (MO_AlignmentCheck align _) [e])   = addAlignmentCheck align <$> getRegister' platform is32Bit e @@ -676,6 +890,18 @@   RegCode64 code _rhi rlo <- iselExpr64 x   return $ Fixed II32 rlo code +getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W8) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  ro <- getNewRegNat II8+  return $ Fixed II8 ro (code `appOL` toOL [ MOVZxL II8 (OpReg rlo) (OpReg ro) ])++getRegister' _ is32Bit (CmmMachOp (MO_UU_Conv W64 W16) [x])+ | is32Bit = do+  RegCode64 code _rhi rlo <- iselExpr64 x+  ro <- getNewRegNat II16+  return $ Fixed II16 ro (code `appOL` toOL [ MOVZxL II16 (OpReg rlo) (OpReg ro) ])+ getRegister' _ _ (CmmLit lit@(CmmFloat f w)) =   float_const_sse2  where   float_const_sse2@@ -1658,7 +1884,28 @@   MO_U_Le _ -> LEU   _other -> pprPanic "machOpToCond" (pprMachOp mo) +{-  Note [64-bit integer comparisons on 32-bit]+    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +    When doing these comparisons there are 2 kinds of+    comparisons.++    * Comparison for equality (or lack thereof)++    We use xor to check if high/low bits are+    equal. Then combine the results using or.++    * Other comparisons:++    We first compare the low registers+    and use a subtraction with borrow to compare the high registers.++    For signed numbers the condition is determined by+    the sign and overflow flags agreeing or not+    and for unsigned numbers the condition is the carry flag.++-}+ -- @cond(Int|Flt)Code@: Turn a boolean expression into a condition, to be -- passed back up the tree. @@ -1668,6 +1915,68 @@  condIntCode' :: Platform -> Cond -> CmmExpr -> CmmExpr -> NatM CondCode +-- 64-bit integer comparisons on 32-bit+-- See Note [64-bit integer comparisons on 32-bit]+condIntCode' platform cond x y+  | target32Bit platform && isWord64 (cmmExprType platform x) = do++  RegCode64 code1 r1hi r1lo <- iselExpr64 x+  RegCode64 code2 r2hi r2lo <- iselExpr64 y++  -- we mustn't clobber r1/r2 so we use temporaries+  tmp1 <- getNewRegNat II32+  tmp2 <- getNewRegNat II32++  let (cond', cmpCode) = intComparison cond r1hi r1lo r2hi r2lo tmp1 tmp2+  return $ CondCode False cond' (code1 `appOL` code2 `appOL` cmpCode)++  where+    intComparison cond r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =+      case cond of+        -- These don't occur as argument of condIntCode'+        ALWAYS  -> panic "impossible"+        NEG     -> panic "impossible"+        POS     -> panic "impossible"+        CARRY   -> panic "impossible"+        OFLO    -> panic "impossible"+        PARITY  -> panic "impossible"+        NOTPARITY -> panic "impossible"+        -- Special case #1 x == y and x != y+        EQQ -> (EQQ, cmpExact)+        NE  -> (NE, cmpExact)+        -- [x >= y]+        GE  -> (GE, cmpGE)+        GEU -> (GEU, cmpGE)+        -- [x >  y]+        GTT -> (LTT, cmpLE)+        GU  -> (LU, cmpLE)+        -- [x <= y]+        LE  -> (GE, cmpLE)+        LEU -> (GEU, cmpLE)+        -- [x <  y]+        LTT -> (LTT, cmpGE)+        LU  -> (LU, cmpGE)+      where+        cmpExact :: OrdList Instr+        cmpExact =+          toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , MOV II32 (OpReg r1_lo) (OpReg tmp2)+            , XOR II32 (OpReg r2_hi) (OpReg tmp1)+            , XOR II32 (OpReg r2_lo) (OpReg tmp2)+            , OR  II32 (OpReg tmp1)  (OpReg tmp2)+            ]+        cmpGE = toOL+            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)+            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)+            , SBB II32 (OpReg r2_hi) (OpReg tmp1)+            ]+        cmpLE = toOL+            [ MOV II32 (OpReg r2_hi) (OpReg tmp1)+            , CMP II32 (OpReg r1_lo) (OpReg r2_lo)+            , SBB II32 (OpReg r1_hi) (OpReg tmp1)+            ]+ -- memory vs immediate condIntCode' platform cond (CmmLoad x pk _) (CmmLit lit)  | is32BitLit platform lit = do@@ -1882,36 +2191,6 @@ codes are set according to the supplied comparison operation. -} -{-  Note [64-bit integer comparisons on 32-bit]-    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~--    When doing these comparisons there are 2 kinds of-    comparisons.--    * Comparison for equality (or lack thereof)--    We use xor to check if high/low bits are-    equal. Then combine the results using or and-    perform a single conditional jump based on the-    result.--    * Other comparisons:--    We map all other comparisons to the >= operation.-    Why? Because it's easy to encode it with a single-    conditional jump.--    We do this by first computing [r1_lo - r2_lo]-    and use the carry flag to compute-    [r1_high - r2_high - CF].--    At which point if r1 >= r2 then the result will be-    positive. Otherwise negative so we can branch on this-    condition.---}-- genCondBranch     :: BlockId      -- the source of the jump     -> BlockId      -- the true branch target@@ -1927,67 +2206,6 @@ genCondBranch' :: Bool -> BlockId -> BlockId -> BlockId -> CmmExpr                -> NatM InstrBlock --- 64-bit integer comparisons on 32-bit--- See Note [64-bit integer comparisons on 32-bit]-genCondBranch' is32Bit _bid true false (CmmMachOp mop [e1,e2])-  | is32Bit, Just W64 <- maybeIntComparison mop = do--  RegCode64 code1 r1hi r1lo <- iselExpr64 e1-  RegCode64 code2 r2hi r2lo <- iselExpr64 e2-  let cond = machOpToCond mop :: Cond--  -- we mustn't clobber r1/r2 so we use temporaries-  tmp1 <- getNewRegNat II32-  tmp2 <- getNewRegNat II32--  let cmpCode = intComparison cond true false r1hi r1lo r2hi r2lo tmp1 tmp2-  return $ code1 `appOL` code2 `appOL` cmpCode--  where-    intComparison cond true false r1_hi r1_lo r2_hi r2_lo tmp1 tmp2 =-      case cond of-        -- Impossible results of machOpToCond-        ALWAYS  -> panic "impossible"-        NEG     -> panic "impossible"-        POS     -> panic "impossible"-        CARRY   -> panic "impossible"-        OFLO    -> panic "impossible"-        PARITY  -> panic "impossible"-        NOTPARITY -> panic "impossible"-        -- Special case #1 x == y and x != y-        EQQ -> cmpExact-        NE  -> cmpExact-        -- [x >= y]-        GE  -> cmpGE-        GEU -> cmpGE-        -- [x >  y] <==> ![y >= x]-        GTT -> intComparison GE  false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2-        GU  -> intComparison GEU false true r2_hi r2_lo r1_hi r1_lo tmp1 tmp2-        -- [x <= y] <==> [y >= x]-        LE  -> intComparison GE  true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2-        LEU -> intComparison GEU true false r2_hi r2_lo r1_hi r1_lo tmp1 tmp2-        -- [x <  y] <==> ![x >= x]-        LTT -> intComparison GE  false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2-        LU  -> intComparison GEU false true r1_hi r1_lo r2_hi r2_lo tmp1 tmp2-      where-        cmpExact :: OrdList Instr-        cmpExact =-          toOL-            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)-            , MOV II32 (OpReg r1_lo) (OpReg tmp2)-            , XOR II32 (OpReg r2_hi) (OpReg tmp1)-            , XOR II32 (OpReg r2_lo) (OpReg tmp2)-            , OR  II32 (OpReg tmp1)  (OpReg tmp2)-            , JXX cond true-            , JXX ALWAYS false-            ]-        cmpGE = toOL-            [ MOV II32 (OpReg r1_hi) (OpReg tmp1)-            , CMP II32 (OpReg r2_lo) (OpReg r1_lo)-            , SBB II32 (OpReg r2_hi) (OpReg tmp1)-            , JXX cond true-            , JXX ALWAYS false ]- genCondBranch' _ bid id false bool = do   CondCode is_float cond cond_code <- getCondCode bool   use_sse2 <- sse2Enabled@@ -2182,8 +2400,9 @@ genSimplePrim bid (MO_Memmove align)   []      [dst,src,n]    = genMemMove bid align dst src n genSimplePrim bid (MO_Memcmp align)    [res]   [dst,src,n]    = genMemCmp  bid align res dst src n genSimplePrim bid (MO_Memset align)    []      [dst,c,n]      = genMemSet  bid align dst c n-genSimplePrim _   MO_ReadBarrier       []      []             = return nilOL -- barriers compile to no code on x86/x86-64;-genSimplePrim _   MO_WriteBarrier      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.+genSimplePrim _   MO_AcquireFence      []      []             = return nilOL -- barriers compile to no code on x86/x86-64;+genSimplePrim _   MO_ReleaseFence      []      []             = return nilOL -- we keep it this long in order to prevent earlier optimisations.+genSimplePrim _   MO_SeqCstFence       []      []             = return $ unitOL MFENCE genSimplePrim _   MO_Touch             []      [_]            = return nilOL genSimplePrim _   (MO_Prefetch_Data n) []      [src]          = genPrefetchData n src genSimplePrim _   (MO_BSwap width)     [dst]   [src]          = genByteSwap width dst src@@ -2441,11 +2660,10 @@            -> [CmmFormal]       -- ^ where to put the result            -> [CmmActual]       -- ^ arguments (of mixed type)            -> NatM InstrBlock-genCCall32 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do+genCCall32 addr conv dest_regs args = do         config <- getConfig         let platform = ncgPlatform config-            args_hints = zip args (argHints ++ repeat NoHint)-            prom_args = map (maybePromoteCArg platform W32) args_hints+            prom_args = map (maybePromoteCArg platform W32) args              -- If the size is smaller than the word, we widen things (see maybePromoteCArg)             arg_size_bytes :: CmmType -> Int@@ -2599,11 +2817,10 @@            -> [CmmFormal]       -- ^ where to put the result            -> [CmmActual]       -- ^ arguments (of mixed type)            -> NatM InstrBlock-genCCall64 addr conv@(ForeignConvention _ argHints _ _) dest_regs args = do+genCCall64 addr conv dest_regs args = do     platform <- getPlatform     -- load up the register arguments-    let args_hints = zip args (argHints ++ repeat NoHint)-    let prom_args = map (maybePromoteCArg platform W32) args_hints+    let prom_args = map (maybePromoteCArg platform W32) args      let load_args :: [CmmExpr]                   -> [Reg]         -- int regs avail for args@@ -2841,11 +3058,9 @@             assign_code dest_regs)  -maybePromoteCArg :: Platform -> Width -> (CmmExpr, ForeignHint) -> CmmExpr-maybePromoteCArg platform wto (arg, hint)- | wfrom < wto = case hint of-     SignedHint -> CmmMachOp (MO_SS_Conv wfrom wto) [arg]-     _          -> CmmMachOp (MO_UU_Conv wfrom wto) [arg]+maybePromoteCArg :: Platform -> Width -> CmmExpr -> CmmExpr+maybePromoteCArg platform wto arg+ | wfrom < wto = CmmMachOp (MO_UU_Conv wfrom wto) [arg]  | otherwise   = arg  where    wfrom = cmmExprWidth platform arg@@ -3822,13 +4037,13 @@  genMemMove :: BlockId -> p -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock genMemMove bid _align dst src n = do-  -- TODO: generate inline assembly when under a given treshold (similarly to+  -- TODO: generate inline assembly when under a given threshold (similarly to   -- memcpy and memset)   genLibCCall bid (fsLit "memmove") [] [dst,src,n]  genMemCmp :: BlockId -> p -> CmmFormal -> CmmActual -> CmmActual -> CmmActual -> NatM InstrBlock genMemCmp bid _align res dst src n = do-  -- TODO: generate inline assembly when under a given treshold (similarly to+  -- TODO: generate inline assembly when under a given threshold (similarly to   -- memcpy and memset)   genLibCCall bid (fsLit "memcmp") [res] [dst,src,n] @@ -4479,4 +4694,3 @@           , SETCC cond (OpReg dst_r)           , MOVZxL II8 (OpReg dst_r) (OpReg dst_r)           ]-

@@ -31,7 +31,6 @@    , mkSpillInstr    , mkRegRegMoveInstr    , jumpDestsOfInstr-   , canFallthroughTo    , patchRegsOfInstr    , patchJumpInstr    , isMetaInstr@@ -54,7 +53,6 @@ import GHC.CmmToAsm.Config  import GHC.Cmm.BlockId-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Platform.Regs import GHC.Cmm@@ -250,6 +248,8 @@         | SHL         Format Operand{-amount-} Operand         | SAR         Format Operand{-amount-} Operand         | SHR         Format Operand{-amount-} Operand+        | SHRD        Format Operand{-amount-} Operand Operand+        | SHLD        Format Operand{-amount-} Operand Operand          | BT          Format Imm Operand         | NOP@@ -258,7 +258,7 @@         -- We need to support the FSTP (x87 store and pop) instruction         -- so that we can correctly read off the return value of an         -- x86 CDECL C function call when its floating point.-        -- so we dont include a register argument, and just use st(0)+        -- so we don't include a register argument, and just use st(0)         -- this instruction is used ONLY for return values of C ffi calls         -- in x86_32 abi         | X87Store         Format  AddrMode -- st(0), dst@@ -402,6 +402,8 @@     SHL    _ imm dst    -> usageRM imm dst     SAR    _ imm dst    -> usageRM imm dst     SHR    _ imm dst    -> usageRM imm dst+    SHLD   _ imm dst1 dst2 -> usageRMM imm dst1 dst2+    SHRD   _ imm dst1 dst2 -> usageRMM imm dst1 dst2     BT     _ _   src    -> mkRUR (use_R src [])      PUSH   _ op         -> mkRUR (use_R op [])@@ -571,6 +573,8 @@     SHL  fmt imm dst     -> patch1 (SHL fmt imm) dst     SAR  fmt imm dst     -> patch1 (SAR fmt imm) dst     SHR  fmt imm dst     -> patch1 (SHR fmt imm) dst+    SHLD fmt imm dst1 dst2 -> patch2 (SHLD fmt imm) dst1 dst2+    SHRD fmt imm dst1 dst2 -> patch2 (SHRD fmt imm) dst1 dst2     BT   fmt imm src     -> patch1 (BT  fmt imm) src     TEST fmt src dst     -> patch2 (TEST fmt) src dst     CMP  fmt src dst     -> patch2 (CMP  fmt) src dst@@ -665,17 +669,6 @@         CALL{}          -> True         _               -> False -canFallthroughTo :: Instr -> BlockId -> Bool-canFallthroughTo insn bid-  = case insn of-    JXX _ target          -> bid == target-    JMP_TBL _ targets _ _ -> all isTargetBid targets-    _                     -> False-  where-    isTargetBid target = case target of-      Nothing                      -> True-      Just (DestBlockId target) -> target == bid-      _                  -> False  jumpDestsOfInstr         :: Instr

@@ -32,7 +32,6 @@ import GHC.CmmToAsm.Ppr  import GHC.Cmm              hiding (topInfoTable)-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Label import GHC.Cmm.BlockId import GHC.Cmm.CLabel@@ -732,6 +731,12 @@    SHR format src dst       -> pprShift (text "shr") format src dst +   SHLD format src dst1 dst2+      -> pprShift2 (text "shld") format src dst1 dst2++   SHRD format src dst1 dst2+      -> pprShift2 (text "shrd") format src dst1 dst2+    BT format imm src       -> pprFormatImmOp (text "bt") format imm src @@ -1068,6 +1073,17 @@            pprOperand platform II8 src,  -- src is 8-bit sized            comma,            pprOperand platform format dest+       ]++   pprShift2 :: Line doc -> Format -> Operand -> Operand -> Operand -> doc+   pprShift2 name format src dest1 dest2+     = line $ hcat [+           pprMnemonic name format,+           pprOperand platform II8 src,  -- src is 8-bit sized+           comma,+           pprOperand platform format dest1,+           comma,+           pprOperand platform format dest2        ]  

@@ -246,7 +246,7 @@             | otherwise             -> panic "X86.Reg.classOfRealReg registerSingle too high"  -- | Get the name of the register with this number.--- NOTE: fixme, we dont track which "way" the XMM registers are used+-- NOTE: fixme, we don't track which "way" the XMM registers are used showReg :: Platform -> RegNo -> String showReg platform n         | n >= firstxmm && n <= lastxmm  platform = "%xmm" ++ show (n-firstxmm)

@@ -38,8 +38,8 @@ import GHC.Cmm.CLabel import GHC.Cmm hiding (pprBBlock, pprStatic) import GHC.Cmm.Dataflow.Block-import GHC.Cmm.Dataflow.Collections import GHC.Cmm.Dataflow.Graph+import GHC.Cmm.Dataflow.Label import GHC.Cmm.Utils import GHC.Cmm.Switch import GHC.Cmm.InitFini@@ -261,6 +261,13 @@     CmmUnsafeForeignCall (PrimTarget MO_Touch) _results _args -> empty     CmmUnsafeForeignCall (PrimTarget (MO_Prefetch_Data _)) _results _args -> empty +    CmmUnsafeForeignCall (PrimTarget MO_ReleaseFence) [] [] ->+        text "__atomic_thread_fence(__ATOMIC_RELEASE);"+    CmmUnsafeForeignCall (PrimTarget MO_AcquireFence) [] [] ->+        text "__atomic_thread_fence(__ATOMIC_ACQUIRE);"+    CmmUnsafeForeignCall (PrimTarget MO_SeqCstFence) [] [] ->+        text "__atomic_thread_fence(__ATOMIC_SEQ_CST);"+     CmmUnsafeForeignCall target@(PrimTarget op) results args ->         fn_call       where@@ -433,6 +440,9 @@   where isMulMayOfloOp (MO_S_MulMayOflo _) = True         isMulMayOfloOp _ = False +pprMachOpApp platform (MO_RelaxedRead w) [x]+  = pprExpr platform (CmmLoad x (cmmBits w) NaturallyAligned)+ pprMachOpApp platform mop args   | Just ty <- machOpNeedsCast platform mop (map (cmmExprType platform) args)   = ty <> parens (pprMachOpApp' platform mop args)@@ -790,6 +800,11 @@         MO_SF_Conv _from to -> parens (machRep_F_CType to)         MO_FS_Conv _from to -> parens (machRep_S_CType platform to) +        MO_RelaxedRead _ -> pprTrace "offending mop:"+                                (text "MO_RelaxedRead")+                                (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"+                                      ++ " should have been handled earlier!")+         MO_S_MulMayOflo _ -> pprTrace "offending mop:"                                 (text "MO_S_MulMayOflo")                                 (panic $ "PprC.pprMachOp_for_C: MO_S_MulMayOflo"@@ -944,8 +959,9 @@         MO_F32_ExpM1    -> text "expm1f"         MO_F32_Sqrt     -> text "sqrtf"         MO_F32_Fabs     -> text "fabsf"-        MO_ReadBarrier  -> text "load_load_barrier"-        MO_WriteBarrier -> text "write_barrier"+        MO_AcquireFence -> unsupported+        MO_ReleaseFence -> unsupported+        MO_SeqCstFence  -> unsupported         MO_Memcpy _     -> text "__builtin_memcpy"         MO_Memset _     -> text "__builtin_memset"         MO_Memmove _    -> text "__builtin_memmove"@@ -1513,12 +1529,15 @@ pprCtorArray :: Platform -> InitOrFini -> [CLabel] -> SDoc pprCtorArray platform initOrFini lbls =        decls-    <> text "static __attribute__((" <> attribute <> text "))"-    <> text "void _hs_" <> attribute <> text "()"+    <> text "static __attribute__((" <> text attribute <> text "))"+    <> text "void _hs_" <> text suffix <> text "()"     <> braces body   where     body = vcat [ pprCLabel platform lbl <> text " ();" | lbl <- lbls ]     decls = vcat [ text "void" <+> pprCLabel platform lbl <> text " (void);" | lbl <- lbls ]-    attribute = case initOrFini of-                  IsInitArray -> text "constructor"-                  IsFiniArray -> text "destructor"+    (attribute, suffix) = case initOrFini of+                  IsInitArray+                    -- See Note [JSFFI initialization] for details+                    | ArchWasm32 <- platformArch platform -> ("constructor(101)", "constructor")+                    | otherwise -> ("constructor", "constructor")+                  IsFiniArray -> ("destructor", "destructor")

@@ -21,10 +21,11 @@ import GHC.CmmToLlvm.Ppr import GHC.CmmToLlvm.Regs import GHC.CmmToLlvm.Mangler+import GHC.CmmToLlvm.Version  import GHC.StgToCmm.CgUtils ( fixStgRegisters ) import GHC.Cmm-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label  import GHC.Utils.BufHandle import GHC.Driver.DynFlags@@ -196,7 +197,7 @@  cmmMetaLlvmPrelude :: LlvmM () cmmMetaLlvmPrelude = do-  metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do+  tbaa_metas <- flip mapM stgTBAA $ \(uniq, name, parent) -> do     -- Generate / lookup meta data IDs     tbaaId <- getMetaUniqueId     setUniqMeta uniq tbaaId@@ -209,9 +210,36 @@               -- just a name on its own. Previously `null` was accepted as the               -- name.               Nothing -> [ MetaStr name ]++  platform <- getPlatform   cfg <- getConfig+  let stack_alignment_metas =+          case platformArch platform of+            ArchX86_64 | llvmCgAvxEnabled cfg -> [mkStackAlignmentMeta 32]+            _                                 -> []+  module_flags_metas <- mkModuleFlagsMeta stack_alignment_metas+  let metas = tbaa_metas ++ module_flags_metas+  cfg <- getConfig   renderLlvm (ppLlvmMetas cfg metas)              (ppLlvmMetas cfg metas)++mkNamedMeta :: LMString -> [MetaExpr] -> LlvmM [MetaDecl]+mkNamedMeta name exprs = do+    (ids, decls) <- unzip <$> mapM f exprs+    return $ decls ++ [MetaNamed name ids]+  where+    f expr = do+      i <- getMetaUniqueId+      return (i, MetaUnnamed i expr)++mkModuleFlagsMeta :: [ModuleFlag] -> LlvmM [MetaDecl]+mkModuleFlagsMeta =+    mkNamedMeta "llvm.module.flags" . map moduleFlagToMetaExpr++mkStackAlignmentMeta :: Integer -> ModuleFlag+mkStackAlignmentMeta alignment =+    ModuleFlag MFBError "override-stack-alignment" (MetaLit $ LMIntLit alignment i32)+  -- ----------------------------------------------------------------------------- -- | Marks variables as used where necessary

@@ -41,6 +41,7 @@ import GHC.Llvm import GHC.CmmToLlvm.Regs import GHC.CmmToLlvm.Config+import GHC.CmmToLlvm.Version  import GHC.Cmm.CLabel import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )@@ -412,7 +413,7 @@ -- so as to make sure they have the most general type in the case that -- user code also uses these functions but with a different type than GHC -- internally. (Main offender is treating return type as 'void' instead of--- 'void *'). Fixes trac #5486.+-- 'void *'). Fixes #5486. ghcInternalFunctions :: LlvmM () ghcInternalFunctions = do     platform <- getPlatform

@@ -24,7 +24,7 @@ import GHC.Cmm.Switch import GHC.Cmm.Dataflow.Block import GHC.Cmm.Dataflow.Graph-import GHC.Cmm.Dataflow.Collections+import GHC.Cmm.Dataflow.Label  import GHC.Data.FastString import GHC.Data.OrdList@@ -34,7 +34,6 @@ import GHC.Types.Unique  import GHC.Utils.Outputable-import GHC.Utils.Panic.Plain (massert) import qualified GHC.Utils.Panic as Panic import GHC.Utils.Misc @@ -172,31 +171,17 @@         fty = LMFunction funSig     in getInstrinct2 fname fty --- | Memory barrier instruction for LLVM >= 3.0-barrier :: LlvmM StmtData-barrier = do-    let s = Fence False SyncSeqCst-    return (unitOL s, [])---- | Insert a 'barrier', unless the target platform is in the provided list of---   exceptions (where no code will be emitted instead).-barrierUnless :: [Arch] -> LlvmM StmtData-barrierUnless exs = do-    platform <- getPlatform-    if platformArch platform `elem` exs-        then return (nilOL, [])-        else barrier- -- | Foreign Calls genCall :: ForeignTarget -> [CmmFormal] -> [CmmActual] -> LlvmM StmtData  -- Barriers need to be handled specially as they are implemented as LLVM -- intrinsic functions.-genCall (PrimTarget MO_ReadBarrier) _ _ =-    barrierUnless [ArchX86, ArchX86_64]--genCall (PrimTarget MO_WriteBarrier) _ _ =-    barrierUnless [ArchX86, ArchX86_64]+genCall (PrimTarget MO_AcquireFence) _ _ = runStmtsDecls $+    statement $ Fence False SyncAcquire+genCall (PrimTarget MO_ReleaseFence) _ _ = runStmtsDecls $+    statement $ Fence False SyncRelease+genCall (PrimTarget MO_SeqCstFence) _ _ = runStmtsDecls $+    statement $ Fence False SyncSeqCst  genCall (PrimTarget MO_Touch) _ _ =     return (nilOL, [])@@ -560,7 +545,7 @@                             , MO_AddWordC w                             , MO_SubWordC w                             ]-    massert valid+    Panic.massert valid     let width = widthToLlvmInt w     -- This will do most of the work of generating the call to the intrinsic and     -- extracting the values from the struct.@@ -1009,8 +994,11 @@     -- We support MO_U_Mul2 through ordinary LLVM mul instruction, see the     -- appropriate case of genCall.     MO_U_Mul2 {}     -> unsupported-    MO_ReadBarrier   -> unsupported-    MO_WriteBarrier  -> unsupported++    MO_ReleaseFence  -> unsupported+    MO_AcquireFence  -> unsupported+    MO_SeqCstFence   -> unsupported+     MO_Touch         -> unsupported     MO_UF_Conv _     -> unsupported @@ -1442,6 +1430,8 @@             all0s = LMLitVar $ LMVectorLit (replicate len all0)         in negateVec vecty all0s LM_MO_FSub +    MO_RelaxedRead w -> exprToVar (CmmLoad x (cmmBits w) NaturallyAligned)+     MO_AlignmentCheck _ _ -> panic "-falignment-sanitisation is not supported by -fllvm"      -- Handle unsupported cases explicitly so we get a warning@@ -1699,12 +1689,9 @@      MO_VF_Neg {} -> panicOp -    MO_AlignmentCheck {} -> panicOp+    MO_RelaxedRead {} -> panicOp -#if __GLASGOW_HASKELL__ < 811-    MO_VF_Extract {} -> panicOp-    MO_V_Extract {} -> panicOp-#endif+    MO_AlignmentCheck {} -> panicOp      where         binLlvmOp ty binOp allow_y_cast = do

@@ -0,0 +1,43 @@+module GHC.CmmToLlvm.Version+  ( LlvmVersion(..)+  , supportedLlvmVersionLowerBound+  , supportedLlvmVersionUpperBound+  , parseLlvmVersion+  , llvmVersionSupported+  , llvmVersionStr+  , llvmVersionList+  )+where++import GHC.Prelude++import GHC.CmmToLlvm.Version.Type+import GHC.CmmToLlvm.Version.Bounds++import Data.Char (isDigit)+import Data.List (intercalate)+import qualified Data.List.NonEmpty as NE++parseLlvmVersion :: String -> Maybe LlvmVersion+parseLlvmVersion =+    fmap LlvmVersion . NE.nonEmpty . go [] . dropWhile (not . isDigit)+  where+    go vs s+      | null ver_str+      = reverse vs+      | '.' : rest' <- rest+      = go (read ver_str : vs) rest'+      | otherwise+      = reverse (read ver_str : vs)+      where+        (ver_str, rest) = span isDigit s++llvmVersionSupported :: LlvmVersion -> Bool+llvmVersionSupported v =+  v >= supportedLlvmVersionLowerBound && v < supportedLlvmVersionUpperBound++llvmVersionStr :: LlvmVersion -> String+llvmVersionStr = intercalate "." . map show . llvmVersionList++llvmVersionList :: LlvmVersion -> [Int]+llvmVersionList = NE.toList . llvmVersionNE

@@ -0,0 +1,19 @@+module GHC.CmmToLlvm.Version.Bounds+  ( supportedLlvmVersionLowerBound+  , supportedLlvmVersionUpperBound+  )+where++import GHC.Prelude ()++import GHC.CmmToLlvm.Version.Type++import qualified Data.List.NonEmpty as NE++-- | The (inclusive) lower bound on the LLVM Version that is currently supported.+supportedLlvmVersionLowerBound :: LlvmVersion+supportedLlvmVersionLowerBound = LlvmVersion (13 NE.:| [])++-- | The (not-inclusive) upper bound  bound on the LLVM Version that is currently supported.+supportedLlvmVersionUpperBound :: LlvmVersion+supportedLlvmVersionUpperBound = LlvmVersion (16 NE.:| [])

@@ -1,167 +1,90 @@-{-# LANGUAGE DerivingStrategies #-}-{-# LANGUAGE TupleSections #-}+{-# LANGUAGE RecordWildCards #-} --- | Adds cost-centers after the core piple has run.+-- | Adds cost-centers after the core pipline has run. module GHC.Core.LateCC-    ( addLateCostCentresMG-    , addLateCostCentresPgm-    , addLateCostCentres -- Might be useful for API users-    , Env(..)+    ( -- * Inserting cost centres+      addLateCostCenters     ) where -import Control.Applicative-import Control.Monad-import qualified Data.Set as S- import GHC.Prelude-import GHC.Types.CostCentre-import GHC.Types.CostCentre.State-import GHC.Types.Name hiding (varName)-import GHC.Types.Tickish-import GHC.Unit.Module.ModGuts-import GHC.Types.Var-import GHC.Unit.Types-import GHC.Data.FastString-import GHC.Core-import GHC.Core.Opt.Monad-import GHC.Core.Utils (mkTick)-import GHC.Types.Id-import GHC.Driver.DynFlags +import GHC.Core+import GHC.Core.LateCC.OverloadedCalls+import GHC.Core.LateCC.TopLevelBinds+import GHC.Core.LateCC.Types+import GHC.Core.LateCC.Utils+import GHC.Core.Seq+import qualified GHC.Data.Strict as Strict+import GHC.Core.Utils+import GHC.Tc.Utils.TcType+import GHC.Types.SrcLoc+import GHC.Utils.Error import GHC.Utils.Logger import GHC.Utils.Outputable-import GHC.Utils.Misc-import GHC.Utils.Error (withTiming)-import GHC.Utils.Monad.State.Strict --{- Note [Collecting late cost centres]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-Usually cost centres defined by a module are collected-during tidy by collectCostCentres. However with `-fprof-late`-we insert cost centres after inlining. So we keep a list of-all the cost centres we inserted and combine that with the list-of cost centres found during tidy.--To avoid overhead when using -fprof-inline there is a flag to stop-us from collecting them here when we run this pass before tidy.--Note [Adding late cost centres]-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~-The basic idea is very simple. For every top level binder-`f = rhs` we compile it as if the user had written-`f = {-# SCC f #-} rhs`.--If we do this after unfoldings for `f` have been created this-doesn't impact core-level optimizations at all. If we do it-before the cost centre will be included in the unfolding and-might inhibit optimizations at the call site. For this reason-we provide flags for both approaches as they have different-tradeoffs.--We also don't add a cost centre for any binder that is a constructor-worker or wrapper. These will never meaningfully enrich the resulting-profile so we improve efficiency by omitting those.---}--addLateCostCentresMG :: ModGuts -> CoreM ModGuts-addLateCostCentresMG guts = do-  dflags <- getDynFlags-  let env :: Env-      env = Env-        { thisModule = mg_module guts-        , ccState = newCostCentreState-        , countEntries = gopt Opt_ProfCountEntries dflags-        , collectCCs = False -- See Note [Collecting late cost centres]-        }-  let guts' = guts { mg_binds = fst (addLateCostCentres env (mg_binds guts))-                   }-  return guts'--addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre)-addLateCostCentresPgm dflags logger mod binds =-  withTiming logger-               (text "LateCC"<+>brackets (ppr mod))-               (\(a,b) -> a `seqList` (b `seq` ())) $ do-  let env = Env-        { thisModule = mod-        , ccState = newCostCentreState-        , countEntries = gopt Opt_ProfCountEntries dflags-        , collectCCs = True -- See Note [Collecting late cost centres]-        }-      (binds', ccs) = addLateCostCentres env binds-  when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $-    putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr binds'))-  return (binds', ccs)+-- | Late cost center insertion logic used by the driver+addLateCostCenters ::+     Logger+  -- ^ Logger+  -> LateCCConfig+  -- ^ Late cost center configuration+  -> CoreProgram+  -- ^ The program+  -> IO (CoreProgram, LateCCState (Strict.Maybe SrcSpan))+addLateCostCenters logger LateCCConfig{..} core_binds = do -addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre)-addLateCostCentres env binds =-  let (binds', state) = runState (mapM (doBind env) binds) initLateCCState-  in (binds',lcs_ccs state)+    -- If top-level late CCs are enabled via either -fprof-late or+    -- -fprof-late-overloaded, add them+    (top_level_cc_binds, top_level_late_cc_state) <-+      case lateCCConfig_whichBinds of+        LateCCNone ->+          return (core_binds, initLateCCState ())+        _ ->+          withTiming+            logger+            (text "LateTopLevelCCs" <+> brackets (ppr this_mod))+            (\(binds, late_cc_state) -> seqBinds binds `seq` late_cc_state `seq` ())+            $ {-# SCC lateTopLevelCCs #-} do+              pure $+                doLateCostCenters+                  lateCCConfig_env+                  (initLateCCState ())+                  (topLevelBindsCC top_level_cc_pred)+                  core_binds +    -- If overloaded call CCs are enabled via -fprof-late-overloaded-calls, add+    -- them+    (late_cc_binds, late_cc_state) <-+      if lateCCConfig_overloadedCalls then+        withTiming+            logger+            (text "LateOverloadedCallsCCs" <+> brackets (ppr this_mod))+            (\(binds, late_cc_state) -> seqBinds binds `seq` late_cc_state `seq` ())+            $ {-# SCC lateoverloadedCallsCCs #-} do+              pure $+                doLateCostCenters+                  lateCCConfig_env+                  (top_level_late_cc_state { lateCCState_extra = Strict.Nothing })+                  overloadedCallsCC+                  top_level_cc_binds+      else+        return+          ( top_level_cc_binds+          , top_level_late_cc_state { lateCCState_extra = Strict.Nothing }+          ) -doBind :: Env -> CoreBind -> M CoreBind-doBind env (NonRec b rhs) = NonRec b <$> doBndr env b rhs-doBind env (Rec bs) = Rec <$> mapM doPair bs+    return (late_cc_binds, late_cc_state)   where-    doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr))-    doPair (b,rhs) = (b,) <$> doBndr env b rhs--doBndr :: Env -> Id -> CoreExpr -> M CoreExpr-doBndr env bndr rhs-  -- Cost centres on constructor workers are pretty much useless-  -- so we don't emit them if we are looking at the rhs of a constructor-  -- binding.-  | Just _ <- isDataConId_maybe bndr = pure rhs-  | otherwise = doBndr' env bndr rhs----- We want to put the cost centre below the lambda as we only care about executions of the RHS.-doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr-doBndr' env bndr (Lam b rhs) = Lam b <$> doBndr' env bndr rhs-doBndr' env bndr rhs = do-    let name = idName bndr-        name_loc = nameSrcSpan name-        cc_name = getOccFS name-        count = countEntries env-    cc_flavour <- getCCFlavour cc_name-    let cc_mod = thisModule env-        bndrCC = NormalCC cc_flavour cc_name cc_mod name_loc-        note = ProfNote bndrCC count True-    addCC env bndrCC-    return $ mkTick note rhs--data LateCCState = LateCCState-    { lcs_state :: !CostCentreState-    , lcs_ccs   :: S.Set CostCentre-    }-type M = State LateCCState--initLateCCState :: LateCCState-initLateCCState = LateCCState newCostCentreState mempty--getCCFlavour :: FastString -> M CCFlavour-getCCFlavour name = mkLateCCFlavour <$> getCCIndex' name--getCCIndex' :: FastString -> M CostCentreIndex-getCCIndex' name = do-  state <- get-  let (index,cc_state') = getCCIndex name (lcs_state state)-  put (state { lcs_state = cc_state'})-  return index--addCC :: Env -> CostCentre -> M ()-addCC !env cc = do-    state <- get-    when (collectCCs env) $ do-        let ccs' = S.insert cc (lcs_ccs state)-        put (state { lcs_ccs = ccs'})--data Env = Env-  { thisModule  :: !Module-  , countEntries:: !Bool-  , ccState     :: !CostCentreState-  , collectCCs  :: !Bool-  }+    top_level_cc_pred :: CoreExpr -> Bool+    top_level_cc_pred =+        case lateCCConfig_whichBinds of+          LateCCAllBinds ->+            const True+          LateCCOverloadedBinds ->+            isOverloadedTy . exprType+          LateCCNone ->+            -- This is here for completeness, we won't actually use this+            -- predicate in this case since we'll shortcut.+            const False +    this_mod = lateCCEnv_module lateCCConfig_env

@@ -0,0 +1,204 @@+{-# LANGUAGE LambdaCase    #-}+{-# LANGUAGE TupleSections #-}++module GHC.Core.LateCC.OverloadedCalls+  ( overloadedCallsCC+  ) where++import GHC.Prelude++import Control.Monad.Trans.Class+import Control.Monad.Trans.Reader+import Control.Monad.Trans.State.Strict+import qualified GHC.Data.Strict as Strict++import GHC.Data.FastString+import GHC.Core+import GHC.Core.LateCC.Utils+import GHC.Core.LateCC.Types+import GHC.Core.Make+import GHC.Core.Predicate+import GHC.Core.Type+import GHC.Core.Utils+import GHC.Tc.Utils.TcType+import GHC.Types.Id+import GHC.Types.Name+import GHC.Types.SrcLoc+import GHC.Types.Tickish+import GHC.Types.Var+import GHC.Utils.Outputable++type OverloadedCallsCCState = Strict.Maybe SrcSpan++-- | Insert cost centres on function applications with dictionary arguments. The+-- source locations attached to the cost centres is approximated based on the+-- "closest" source note encountered in the traversal.+overloadedCallsCC :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind+overloadedCallsCC =+    processBind+  where+    processBind :: CoreBind -> LateCCM OverloadedCallsCCState CoreBind+    processBind core_bind =+        case core_bind of+          NonRec b e ->+            NonRec b <$> wrap_if_join b (processExpr e)+          Rec es ->+            Rec <$> mapM (\(b,e) -> (b,) <$> wrap_if_join b (processExpr e)) es+      where+        -- If an overloaded function is turned into a join point, we won't add+        -- SCCs directly to calls since it makes them non-tail calls. Instead,+        -- we look for join points here and add an SCC to their RHS if they are+        -- overloaded.+        wrap_if_join ::+             CoreBndr+          -> LateCCM OverloadedCallsCCState CoreExpr+          -> LateCCM OverloadedCallsCCState CoreExpr+        wrap_if_join b pexpr = do+            expr <- pexpr+            if isJoinId b && isOverloadedTy (exprType expr) then do+              let+                cc_name :: FastString+                cc_name = fsLit "join-rhs-" `appendFS` getOccFS b++              cc_srcspan <-+                fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $+                  lift $ gets lateCCState_extra++              insertCC cc_name cc_srcspan expr+            else+              return expr+++    processExpr :: CoreExpr -> LateCCM OverloadedCallsCCState CoreExpr+    processExpr expr =+      case expr of+        -- The case we care about: Application+        app@App{} -> do+          -- Here we have some application like `f v1 ... vN`, where v1 ... vN+          -- should be the function's type arguments followed by the value+          -- arguments. To determine if the `f` is an overloaded function, we+          -- check if any of the arguments v1 ... vN are dictionaries.+          let+            (f, xs) = collectArgs app+            resultTy = applyTypeToArgs empty (exprType f) xs++          -- Recursively process the arguments first for no particular reason+          args <- mapM processExpr xs+          let app' = mkCoreApps f args++          if+              -- Check if any of the arguments are dictionaries+              any isDictExpr args++              -- Avoid instrumenting dictionary functions, which may be+              -- overloaded if there are superclasses, by checking if the result+              -- type of the function is a dictionary type.+            && not (isDictTy resultTy)++              -- Avoid instrumenting constraint selectors like eq_sel+            && (typeTypeOrConstraint resultTy /= ConstraintLike)++              -- Avoid instrumenting join points.+              -- (See comment in processBind above)+            && not (isJoinVarExpr f)+          then do+            -- Extract a name and source location from the function being+            -- applied+            let+              cc_name :: FastString+              cc_name =+                fsLit $ maybe "<no name available>" getOccString (exprName app)++            cc_srcspan <-+              fmap (Strict.fromMaybe (UnhelpfulSpan UnhelpfulNoLocationInfo)) $+                lift $ gets lateCCState_extra++            insertCC cc_name cc_srcspan app'+          else+            return app'++        -- For recursive constructors of Expr, we traverse the nested Exprs+        Lam b e ->+          mkCoreLams [b] <$> processExpr e+        Let b e ->+          mkCoreLet <$> processBind b <*> processExpr e+        Case e b t alts ->+              Case+          <$> processExpr e+          <*> pure b+          <*> pure t+          <*> mapM processAlt alts+        Cast e co ->+          mkCast <$> processExpr e <*> pure co+        Tick t e -> do+          trackSourceNote t $+            mkTick t <$> processExpr e++        -- For non-recursive constructors of Expr, we do nothing+        x -> return x++    processAlt :: CoreAlt -> LateCCM OverloadedCallsCCState CoreAlt+    processAlt (Alt c bs e) = Alt c bs <$> processExpr e++    trackSourceNote :: CoreTickish -> LateCCM OverloadedCallsCCState a -> LateCCM OverloadedCallsCCState a+    trackSourceNote tick act =+      case tick of+        SourceNote rss _ -> do+          -- Prefer source notes from the current file+          in_current_file <-+            maybe False ((== EQ) . lexicalCompareFS (srcSpanFile rss)) <$>+              asks lateCCEnv_file+          if not in_current_file then+            act+          else do+            loc <- lift $ gets lateCCState_extra+            lift . modify $ \s ->+              s { lateCCState_extra =+                    Strict.Just $ RealSrcSpan rss mempty+                }+            x <- act+            lift . modify $ \s ->+              s { lateCCState_extra = loc+                }+            return x+        _ ->+          act++    -- Utility functions++    -- Extract a Name from an expression. If it is an application, attempt to+    -- extract a name from the applied function. If it is a variable, return the+    -- Name of the variable. If it is a tick/cast, attempt to extract a Name+    -- from the expression held in the tick/cast. Otherwise return Nothing.+    exprName :: CoreExpr -> Maybe Name+    exprName =+        \case+          App f _ ->+            exprName f+          Var f ->+            Just (idName f)+          Tick _ e ->+            exprName e+          Cast e _ ->+            exprName e+          _ ->+            Nothing++    -- Determine whether an expression is a dictionary+    isDictExpr :: CoreExpr -> Bool+    isDictExpr =+        maybe False isDictTy . exprType'+      where+        exprType' :: CoreExpr -> Maybe Type+        exprType' = \case+            Type{} -> Nothing+            expr -> Just $ exprType expr++    -- Determine whether an expression is a join variable+    isJoinVarExpr :: CoreExpr -> Bool+    isJoinVarExpr =+        \case+          Var var -> isJoinId var+          Tick _ e -> isJoinVarExpr e+          Cast e _ -> isJoinVarExpr e+          _ -> False

@@ -0,0 +1,106 @@+{-# LANGUAGE TupleSections #-}+module GHC.Core.LateCC.TopLevelBinds where++import GHC.Prelude++import GHC.Core+-- import GHC.Core.LateCC+import GHC.Core.LateCC.Types+import GHC.Core.LateCC.Utils+import GHC.Core.Opt.Monad+import GHC.Driver.DynFlags+import GHC.Types.Id+import GHC.Types.Name+import GHC.Unit.Module.ModGuts++{- Note [Collecting late cost centres]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Usually cost centres defined by a module are collected+during tidy by collectCostCentres. However with `-fprof-late`+we insert cost centres after inlining. So we keep a list of+all the cost centres we inserted and combine that with the list+of cost centres found during tidy.++To avoid overhead when using -fprof-inline there is a flag to stop+us from collecting them here when we run this pass before tidy.++Note [Adding late cost centres to top level bindings]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+The basic idea is very simple. For every top level binder+`f = rhs` we compile it as if the user had written+`f = {-# SCC f #-} rhs`.++If we do this after unfoldings for `f` have been created this+doesn't impact core-level optimizations at all. If we do it+before the cost centre will be included in the unfolding and+might inhibit optimizations at the call site. For this reason+we provide flags for both approaches as they have different+tradeoffs.++We also don't add a cost centre for any binder that is a constructor+worker or wrapper. These will never meaningfully enrich the resulting+profile so we improve efficiency by omitting those.++-}++-- | Add late cost centres directly to the 'ModGuts'. This is used inside the+-- core pipeline with the -fprof-late-inline flag. It should not be used after+-- tidy, since it does not manually track inserted cost centers. See+-- Note [Collecting late cost centres].+topLevelBindsCCMG :: ModGuts -> CoreM ModGuts+topLevelBindsCCMG guts = do+    dflags <- getDynFlags+    let+      env =+        LateCCEnv+          { lateCCEnv_module = mg_module guts++            -- We don't use this for topLevelBindsCC, so Nothing is okay+          , lateCCEnv_file = Nothing++          , lateCCEnv_countEntries= gopt Opt_ProfCountEntries dflags+          , lateCCEnv_collectCCs = False+          }+      guts' =+        guts+          { mg_binds =+              fst+                ( doLateCostCenters+                    env+                    (initLateCCState ())+                    (topLevelBindsCC (const True))+                    (mg_binds guts)+                )+          }+    return guts'++-- | Insert cost centres on top-level bindings in the module, depending on+-- whether or not they satisfy the given predicate.+topLevelBindsCC :: (CoreExpr -> Bool) -> CoreBind -> LateCCM s CoreBind+topLevelBindsCC pred core_bind =+    case core_bind of+      NonRec b rhs ->+        NonRec b <$> doBndr b rhs+      Rec bs ->+        Rec <$> mapM doPair bs+  where+    doPair :: ((Id, CoreExpr) -> LateCCM s (Id, CoreExpr))+    doPair (b,rhs) = (b,) <$> doBndr b rhs++    doBndr :: Id -> CoreExpr -> LateCCM s CoreExpr+    doBndr bndr rhs+      -- Cost centres on constructor workers are pretty much useless+      -- so we don't emit them if we are looking at the rhs of a constructor+      -- binding.+      | Just _ <- isDataConId_maybe bndr = pure rhs+      | otherwise = if pred rhs then addCC bndr rhs else pure rhs++    -- We want to put the cost centre below the lambda as we only care about+    -- executions of the RHS.+    addCC :: Id -> CoreExpr -> LateCCM s CoreExpr+    addCC bndr (Lam b rhs) = Lam b <$> addCC bndr rhs+    addCC bndr rhs = do+      let name = idName bndr+          cc_loc = nameSrcSpan name+          cc_name = getOccFS name+      insertCC cc_name cc_loc rhs