ghc-lib 0.20221101 → 0.20221201

raw patch · 233 files changed

+22609/−2968 lines, 233 filesdep ~ghc-lib-parserPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: ghc-lib-parser

API changes (from Hackage documentation)

Files

• compiler/CodeGen.Platform.h +2/−1
• compiler/GHC.hs +15/−13
• compiler/GHC/Builtin/PrimOps/Casts.hs +212/−0
• compiler/GHC/Builtin/Types/Literals.hs +2/−2
• compiler/GHC/Cmm/ContFlowOpt.hs +0/−1
• compiler/GHC/Cmm/DebugBlock.hs +15/−3
• compiler/GHC/Cmm/Parser.y +0/−1
• compiler/GHC/Cmm/ProcPoint.hs +0/−2
• compiler/GHC/Cmm/Reducibility.hs +224/−0
• compiler/GHC/Cmm/Utils.hs +3/−3
• compiler/GHC/CmmToAsm.hs +34/−27
• compiler/GHC/CmmToAsm/AArch64.hs +4/−2
• compiler/GHC/CmmToAsm/AArch64/CodeGen.hs +0/−4
• compiler/GHC/CmmToAsm/AArch64/Ppr.hs +81/−75
• compiler/GHC/CmmToAsm/AArch64/Regs.hs +3/−2
• compiler/GHC/CmmToAsm/BlockLayout.hs +1/−2
• compiler/GHC/CmmToAsm/Dwarf.hs +31/−32
• compiler/GHC/CmmToAsm/Dwarf/Constants.hs +27/−4
• compiler/GHC/CmmToAsm/Dwarf/Types.hs +87/−62
• compiler/GHC/CmmToAsm/Instr.hs +2/−1
• compiler/GHC/CmmToAsm/Monad.hs +36/−2
• compiler/GHC/CmmToAsm/PIC.hs +18/−16
• compiler/GHC/CmmToAsm/PPC.hs +2/−1
• compiler/GHC/CmmToAsm/PPC/CodeGen.hs +2/−2
• compiler/GHC/CmmToAsm/PPC/Instr.hs +2/−2
• compiler/GHC/CmmToAsm/PPC/Ppr.hs +128/−130
• compiler/GHC/CmmToAsm/PPC/Regs.hs +3/−2
• compiler/GHC/CmmToAsm/Ppr.hs +31/−19
• compiler/GHC/CmmToAsm/Reg/Graph/Spill.hs +1/−2
• compiler/GHC/CmmToAsm/Reg/Graph/SpillClean.hs +1/−2
• compiler/GHC/CmmToAsm/Reg/Graph/SpillCost.hs +2/−2
• compiler/GHC/CmmToAsm/Reg/Graph/TrivColorable.hs +3/−0
• compiler/GHC/CmmToAsm/Reg/Linear.hs +1/−0
• compiler/GHC/CmmToAsm/Reg/Linear/FreeRegs.hs +1/−0
• compiler/GHC/CmmToAsm/Reg/Linear/JoinToTargets.hs +4/−3
• compiler/GHC/CmmToAsm/Reg/Target.hs +5/−0
• compiler/GHC/CmmToAsm/Wasm.hs +45/−0
• compiler/GHC/CmmToAsm/Wasm/Asm.hs +511/−0
• compiler/GHC/CmmToAsm/Wasm/FromCmm.hs +1677/−0
• compiler/GHC/CmmToAsm/Wasm/Types.hs +452/−0
• compiler/GHC/CmmToAsm/Wasm/Utils.hs +35/−0
• compiler/GHC/CmmToAsm/X86.hs +2/−1
• compiler/GHC/CmmToAsm/X86/CodeGen.hs +1/−1
• compiler/GHC/CmmToAsm/X86/Instr.hs +4/−3
• compiler/GHC/CmmToAsm/X86/Ppr.hs +118/−116
• compiler/GHC/CmmToAsm/X86/Regs.hs +3/−2
• compiler/GHC/CmmToC.hs +1/−7
• compiler/GHC/CmmToLlvm.hs +2/−2
• compiler/GHC/CmmToLlvm/CodeGen.hs +0/−3
• compiler/GHC/Core/Opt/CSE.hs +7/−10
• compiler/GHC/Core/Opt/CallArity.hs +1/−1
• compiler/GHC/Core/Opt/DmdAnal.hs +144/−23
• compiler/GHC/Core/Opt/Exitify.hs +1/−1
• compiler/GHC/Core/Opt/Pipeline.hs +17/−16
• compiler/GHC/Core/Opt/SetLevels.hs +67/−53
• compiler/GHC/Core/Opt/SpecConstr.hs +10/−11
• compiler/GHC/Core/Opt/Specialise.hs +161/−94
• compiler/GHC/Core/Opt/StaticArgs.hs +7/−4
• compiler/GHC/Core/Opt/WorkWrap.hs +0/−1
• compiler/GHC/Core/Opt/WorkWrap/Utils.hs +66/−46
• compiler/GHC/CoreToStg.hs +3/−5
• compiler/GHC/CoreToStg/Prep.hs +14/−3
• compiler/GHC/Data/Graph/Collapse.hs +264/−0
• compiler/GHC/Data/Graph/Color.hs +1/−2
• compiler/GHC/Data/Graph/Inductive/Graph.hs +643/−0
• compiler/GHC/Data/Graph/Inductive/PatriciaTree.hs +343/−0
• compiler/GHC/Data/Graph/Ops.hs +1/−1
• compiler/GHC/Driver/Backpack.hs +4/−2
• compiler/GHC/Driver/CodeOutput.hs +21/−6
• compiler/GHC/Driver/Config/Cmm.hs +2/−1
• compiler/GHC/Driver/Config/Core/Opt/Simplify.hs +10/−11
• compiler/GHC/Driver/Config/StgToCmm.hs +6/−6
• compiler/GHC/Driver/Config/StgToJS.hs +32/−0
• compiler/GHC/Driver/GenerateCgIPEStub.hs +3/−4
• compiler/GHC/Driver/Main.hs +52/−32
• compiler/GHC/Driver/Make.hs +2/−3
• compiler/GHC/Driver/Pipeline.hs +87/−46
• compiler/GHC/Driver/Pipeline/Execute.hs +87/−32
• compiler/GHC/Hs/Syn/Type.hs +4/−4
• compiler/GHC/HsToCore.hs +10/−8
• compiler/GHC/HsToCore/Arrows.hs +47/−40
• compiler/GHC/HsToCore/Binds.hs +85/−47
• compiler/GHC/HsToCore/Coverage.hs +1/−1
• compiler/GHC/HsToCore/Expr.hs +6/−7
• compiler/GHC/HsToCore/Foreign/C.hs +14/−6
• compiler/GHC/HsToCore/Foreign/Call.hs +9/−12
• compiler/GHC/HsToCore/Foreign/Decl.hs +13/−9
• compiler/GHC/HsToCore/Foreign/JavaScript.hs +683/−0
• compiler/GHC/HsToCore/GuardedRHSs.hs +1/−1
• compiler/GHC/HsToCore/ListComp.hs +22/−25
• compiler/GHC/HsToCore/Match.hs +13/−10
• compiler/GHC/HsToCore/Match/Literal.hs +17/−10
• compiler/GHC/HsToCore/Monad.hs +13/−10
• compiler/GHC/HsToCore/Pmc/Desugar.hs +4/−2
• compiler/GHC/HsToCore/Pmc/Solver.hs +7/−7
• compiler/GHC/HsToCore/Pmc/Utils.hs +3/−3
• compiler/GHC/HsToCore/Quote.hs +18/−9
• compiler/GHC/HsToCore/Types.hs +1/−1
• compiler/GHC/HsToCore/Utils.hs +12/−12
• compiler/GHC/Iface/Binary.hs +69/−105
• compiler/GHC/Iface/Errors.hs +1/−1
• compiler/GHC/Iface/Ext/Binary.hs +0/−1
• compiler/GHC/Iface/Ext/Types.hs +2/−2
• compiler/GHC/Iface/Ext/Utils.hs +9/−8
• compiler/GHC/Iface/Load.hs +12/−8
• compiler/GHC/Iface/Make.hs +14/−14
• compiler/GHC/Iface/Recomp.hs +12/−12
• compiler/GHC/Iface/Rename.hs +4/−8
• compiler/GHC/Iface/Tidy.hs +0/−1
• compiler/GHC/Iface/Tidy/StaticPtrTable.hs +10/−4
• compiler/GHC/IfaceToCore.hs +21/−20
• compiler/GHC/JS/Make.hs +715/−0
• compiler/GHC/JS/Ppr.hs +294/−0
• compiler/GHC/JS/Syntax.hs +392/−0
• compiler/GHC/JS/Transform.hs +264/−0
• compiler/GHC/Linker/Static.hs +12/−7
• compiler/GHC/Llvm/Ppr.hs +2/−2
• compiler/GHC/Rename/Bind.hs +0/−1
• compiler/GHC/Rename/Expr.hs +53/−93
• compiler/GHC/Rename/Expr.hs-boot +1/−9
• compiler/GHC/Rename/Module.hs +49/−27
• compiler/GHC/Rename/Names.hs +9/−13
• compiler/GHC/Rename/Pat.hs +13/−11
• compiler/GHC/Rename/Splice.hs +18/−8
• compiler/GHC/Rename/Utils.hs +1/−1
• compiler/GHC/Runtime/Debugger.hs +2/−2
• compiler/GHC/Runtime/Eval.hs +10/−7
• compiler/GHC/Runtime/Heap/Inspect.hs +16/−11
• compiler/GHC/Runtime/Loader.hs +8/−6
• compiler/GHC/Stg/BcPrep.hs +1/−1
• compiler/GHC/Stg/InferTags/Rewrite.hs +0/−3
• compiler/GHC/Stg/Lift/Analysis.hs +1/−1
• compiler/GHC/Stg/Lift/Monad.hs +1/−1
• compiler/GHC/Stg/Subst.hs +7/−1
• compiler/GHC/Stg/Unarise.hs +337/−81
• compiler/GHC/Stg/Utils.hs +2/−3
• compiler/GHC/StgToByteCode.hs +1/−2
• compiler/GHC/StgToCmm.hs +2/−2
• compiler/GHC/StgToCmm/Env.hs +1/−0
• compiler/GHC/StgToCmm/Heap.hs +5/−11
• compiler/GHC/StgToCmm/Lit.hs +1/−1
• compiler/GHC/StgToCmm/Ticky.hs +1/−2
• compiler/GHC/StgToJS.hs +216/−0
• compiler/GHC/StgToJS/Apply.hs +1152/−0
• compiler/GHC/StgToJS/Arg.hs +285/−0
• compiler/GHC/StgToJS/Closure.hs +156/−0
• compiler/GHC/StgToJS/CodeGen.hs +367/−0
• compiler/GHC/StgToJS/CoreUtils.hs +282/−0
• compiler/GHC/StgToJS/DataCon.hs +124/−0
• compiler/GHC/StgToJS/Deps.hs +191/−0
• compiler/GHC/StgToJS/Expr.hs +1045/−0
• compiler/GHC/StgToJS/ExprCtx.hs +172/−0
• compiler/GHC/StgToJS/FFI.hs +352/−0
• compiler/GHC/StgToJS/Heap.hs +155/−0
• compiler/GHC/StgToJS/Ids.hs +238/−0
• compiler/GHC/StgToJS/Linker/Linker.hs +953/−0
• compiler/GHC/StgToJS/Linker/Types.hs +101/−0
• compiler/GHC/StgToJS/Linker/Utils.hs +308/−0
• compiler/GHC/StgToJS/Literal.hs +109/−0
• compiler/GHC/StgToJS/Monad.hs +183/−0
• compiler/GHC/StgToJS/Object.hs +622/−0
• compiler/GHC/StgToJS/Prim.hs +1509/−0
• compiler/GHC/StgToJS/Printer.hs +218/−0
• compiler/GHC/StgToJS/Profiling.hs +178/−0
• compiler/GHC/StgToJS/Regs.hs +142/−0
• compiler/GHC/StgToJS/Rts/Rts.hs +661/−0
• compiler/GHC/StgToJS/Rts/Types.hs +78/−0
• compiler/GHC/StgToJS/Sinker.hs +180/−0
• compiler/GHC/StgToJS/Stack.hs +373/−0
• compiler/GHC/StgToJS/StaticPtr.hs +28/−0
• compiler/GHC/StgToJS/StgUtils.hs +266/−0
• compiler/GHC/StgToJS/Symbols.hs +89/−0
• compiler/GHC/StgToJS/Types.hs +430/−0
• compiler/GHC/StgToJS/Utils.hs +57/−0
• compiler/GHC/SysTools/Cpp.hs +0/−1
• compiler/GHC/SysTools/Info.hs +1/−1
• compiler/GHC/SysTools/Tasks.hs +10/−0
• compiler/GHC/Tc/Deriv.hs +11/−5
• compiler/GHC/Tc/Deriv/Functor.hs +5/−5
• compiler/GHC/Tc/Deriv/Generate.hs +1/−0
• compiler/GHC/Tc/Deriv/Generics.hs +7/−3
• compiler/GHC/Tc/Deriv/Infer.hs +23/−18
• compiler/GHC/Tc/Deriv/Utils.hs +23/−17
• compiler/GHC/Tc/Errors.hs +10/−12
• compiler/GHC/Tc/Errors/Hole.hs +11/−13
• compiler/GHC/Tc/Gen/App.hs +26/−26
• compiler/GHC/Tc/Gen/Arrow.hs +6/−5
• compiler/GHC/Tc/Gen/Bind.hs +28/−24
• compiler/GHC/Tc/Gen/Default.hs +2/−1
• compiler/GHC/Tc/Gen/Expr.hs +7/−6
• compiler/GHC/Tc/Gen/Foreign.hs +41/−20
• compiler/GHC/Tc/Gen/Head.hs +33/−29
• compiler/GHC/Tc/Gen/HsType.hs +86/−81
• compiler/GHC/Tc/Gen/Match.hs +7/−7
• compiler/GHC/Tc/Gen/Pat.hs +9/−8
• compiler/GHC/Tc/Gen/Rule.hs +9/−6
• compiler/GHC/Tc/Gen/Sig.hs +16/−6
• compiler/GHC/Tc/Gen/Splice.hs +25/−24
• compiler/GHC/Tc/Instance/Class.hs +67/−44
• compiler/GHC/Tc/Instance/FunDeps.hs +12/−7
• compiler/GHC/Tc/Instance/Typeable.hs +28/−22
• compiler/GHC/Tc/Module.hs +11/−5
• compiler/GHC/Tc/Solver.hs +4/−4
• compiler/GHC/Tc/Solver/Canonical.hs +506/−336
• compiler/GHC/Tc/Solver/Interact.hs +205/−121
• compiler/GHC/Tc/Solver/Monad.hs +17/−15
• compiler/GHC/Tc/Solver/Rewrite.hs +27/−27
• compiler/GHC/Tc/TyCl.hs +35/−36
• compiler/GHC/Tc/TyCl/Build.hs +19/−18
• compiler/GHC/Tc/TyCl/Class.hs +1/−1
• compiler/GHC/Tc/TyCl/Instance.hs +21/−62
• compiler/GHC/Tc/TyCl/PatSyn.hs +26/−25
• compiler/GHC/Tc/TyCl/Utils.hs +43/−29
• compiler/GHC/Tc/Utils/Concrete.hs +7/−7
• compiler/GHC/Tc/Utils/Env.hs +2/−2
• compiler/GHC/Tc/Utils/Instantiate.hs +30/−30
• compiler/GHC/Tc/Utils/Monad.hs +18/−18
• compiler/GHC/Tc/Utils/TcMType.hs +24/−27
• compiler/GHC/Tc/Utils/Unify.hs +65/−64
• compiler/GHC/Tc/Utils/Zonk.hs +3/−3
• compiler/GHC/Tc/Validity.hs +41/−44
• compiler/GHC/ThToHs.hs +10/−8
• compiler/GHC/Types/TyThing/Ppr.hs +1/−2
• compiler/GHC/Utils/Asm.hs +3/−2
• compiler/GHC/Wasm/ControlFlow.hs +53/−0
• compiler/GHC/Wasm/ControlFlow/FromCmm.hs +352/−0
• compiler/MachRegs.h +35/−0
• compiler/ghc-llvm-version.h +1/−1
• ghc-lib.cabal +56/−2
• ghc-lib/stage0/lib/settings +1/−1
• ghc-lib/stage0/rts/build/include/ghcautoconf.h +14/−1
• libraries/ghci/GHCi/CreateBCO.hs +6/−0
• libraries/ghci/GHCi/InfoTable.hsc +2/−2

@@ -664,7 +664,8 @@ #if defined(MACHREGS_i386) || defined(MACHREGS_x86_64) \     || defined(MACHREGS_powerpc) \     || defined(MACHREGS_arm) || defined(MACHREGS_aarch64) \-    || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64)+    || defined(MACHREGS_s390x) || defined(MACHREGS_riscv64) \+    || defined(MACHREGS_wasm32) # if defined(REG_Base) globalRegMaybe BaseReg                  = Just (RealRegSingle REG_Base) # endif

@@ -97,12 +97,12 @@         modInfoSafe,         lookupGlobalName,         findGlobalAnns,-        mkPrintUnqualifiedForModule,+        mkNamePprCtxForModule,         ModIface, ModIface_(..),         SafeHaskellMode(..),          -- * Printing-        PrintUnqualified, alwaysQualify,+        NamePprCtx, alwaysQualify,          -- * Interactive evaluation @@ -119,7 +119,7 @@         setGHCiMonad, getGHCiMonad,          -- ** Inspecting the current context-        getBindings, getInsts, getPrintUnqual,+        getBindings, getInsts, getNamePprCtx,         findModule, lookupModule,         findQualifiedModule, lookupQualifiedModule,         renamePkgQualM, renameRawPkgQualM,@@ -197,7 +197,7 @@         TyCon,         tyConTyVars, tyConDataCons, tyConArity,         isClassTyCon, isTypeSynonymTyCon, isTypeFamilyTyCon, isNewTyCon,-        isPrimTyCon, isFunTyCon,+        isPrimTyCon,         isFamilyTyCon, isOpenFamilyTyCon, isOpenTypeFamilyTyCon,         tyConClass_maybe,         synTyConRhs_maybe, synTyConDefn_maybe, tyConKind,@@ -1346,9 +1346,9 @@     let (inst_env, fam_env) = ic_instances (hsc_IC hsc_env)     in return (instEnvElts inst_env, fam_env) -getPrintUnqual :: GhcMonad m => m PrintUnqualified-getPrintUnqual = withSession $ \hsc_env -> do-  return $ icPrintUnqual (hsc_unit_env hsc_env) (hsc_IC hsc_env)+getNamePprCtx :: GhcMonad m => m NamePprCtx+getNamePprCtx = withSession $ \hsc_env -> do+  return $ icNamePprCtx (hsc_unit_env hsc_env) (hsc_IC hsc_env)  -- | Container for information about a 'Module'. data ModuleInfo = ModuleInfo {@@ -1442,12 +1442,14 @@ modInfoIsExportedName :: ModuleInfo -> Name -> Bool modInfoIsExportedName minf name = elemNameSet name (availsToNameSet (minf_exports minf)) -mkPrintUnqualifiedForModule :: GhcMonad m =>-                               ModuleInfo-                            -> m (Maybe PrintUnqualified) -- XXX: returns a Maybe X-mkPrintUnqualifiedForModule minf = withSession $ \hsc_env -> do-  let mk_print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env)-  return (fmap mk_print_unqual (minf_rdr_env minf))+mkNamePprCtxForModule ::+  GhcMonad m =>+  ModuleInfo ->+  m (Maybe NamePprCtx) -- XXX: returns a Maybe X+mkNamePprCtxForModule minf = withSession $ \hsc_env -> do+  let mk_name_ppr_ctx = mkNamePprCtx ptc (hsc_unit_env hsc_env)+      ptc = initPromotionTickContext (hsc_dflags hsc_env)+  return (fmap mk_name_ppr_ctx (minf_rdr_env minf))  modInfoLookupName :: GhcMonad m =>                      ModuleInfo -> Name

@@ -0,0 +1,212 @@+{-+This module contains helpers to cast variables+between different Int/WordReps in StgLand.++-}++module GHC.Builtin.PrimOps.Casts+    ( getCasts )+where++import GHC.Prelude++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++import GHC.Builtin.PrimOps+import GHC.Plugins (HasDebugCallStack)++{- Note [PrimRep based casting]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+This module contains a number of utility functions useful when+converting between variables of differing PrimReps.++The general pattern is:+* We have two primReps `from_rep` and `to_rep`.+* We want a list of PrimOps we can apply to a variable of rep `from_rep`.+Applying the list of primOps in order takes us to `to_rep` from `from_rep` giving+us a variable of the returned type at each step.++E.g. we call `getCasts from_rep to_rep` and get back [(op1#,ty1),(op2#,ty2)].+We can use this result to construct a function of type+`StgExpr -> StgExpr` by construction an expression++    case op1# <from> of (x' :: ty1) -> case op2# x' of x' -> <rhs_hole>++Ideally backends will compile the sequence of PrimOps to a no-op. E.g. by reusing+the same register but just relabeling it as another width.+However this is might not always be possible or the required optimizations+simply not implemented in the backend. This means currently many of these casts+will be cheap but not all of them will be completely zero-cost.++-}++-- | `getCasts from_rep to_rep` gives us a list of primops which when applied in order convert from_rep to to_rep.+-- See Note [PrimRep based casting]+getCasts :: PrimRep -> PrimRep -> [(PrimOp,Type)]+getCasts from_rep to_rep+  -- No-op+  | -- pprTrace "getCasts" (ppr (from_rep,to_rep)) $+    to_rep == from_rep+  = []++  -- Float <-> Double+  | to_rep == FloatRep =+    assertPpr (from_rep == DoubleRep) (ppr from_rep <+> ppr to_rep) $+    [(DoubleToFloatOp,floatPrimTy)]+  | to_rep == DoubleRep =+    assertPpr (from_rep == FloatRep) (ppr from_rep <+> ppr to_rep) $+    [(FloatToDoubleOp,doublePrimTy)]++  -- Addr <-> Word/Int+  | to_rep == AddrRep = wordOrIntToAddrRep from_rep+  | from_rep == AddrRep = addrToWordOrIntRep to_rep++  -- Int* -> Int*+  | primRepIsInt from_rep+  , primRepIsInt to_rep+  = sizedIntToSizedInt from_rep to_rep++  -- Word* -> Word*+  | primRepIsWord from_rep+  , primRepIsWord to_rep+  = sizedWordToSizedWord from_rep to_rep++  -- Word* -> Int*+  | primRepIsWord from_rep+  , primRepIsInt to_rep+  = let (op1,r1) = wordToIntRep from_rep+    in (op1,primRepToType r1):sizedIntToSizedInt r1 to_rep++  -- Int* -> Word*+  | primRepIsInt from_rep+  , primRepIsWord to_rep+  = let (op1,r1) = intToWordRep from_rep+    in (op1,primRepToType r1):sizedWordToSizedWord r1 to_rep++  | otherwise = pprPanic "getCasts:Unexpect rep combination"+                          (ppr (from_rep,to_rep))++wordOrIntToAddrRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)]+wordOrIntToAddrRep AddrRep = [] -- No-op argument is already AddrRep+wordOrIntToAddrRep IntRep = [(IntToAddrOp, addrPrimTy)]+wordOrIntToAddrRep WordRep = [(WordToIntOp,intPrimTy), (IntToAddrOp,addrPrimTy)]+wordOrIntToAddrRep r+    | primRepIsInt r = (intToMachineInt r,intPrimTy):[(IntToAddrOp,addrPrimTy)]+    | primRepIsWord r =+        let (op1,r1) = wordToIntRep r+        in (op1, primRepToType r1):[(intToMachineInt r1,intPrimTy), (IntToAddrOp,addrPrimTy)]+    | otherwise = pprPanic "Rep not word or int rep" (ppr r)++addrToWordOrIntRep :: HasDebugCallStack => PrimRep -> [(PrimOp,Type)]+-- Machine sizes+addrToWordOrIntRep IntRep = [(AddrToIntOp, intPrimTy)]+addrToWordOrIntRep WordRep = [(AddrToIntOp,intPrimTy), (IntToWordOp,wordPrimTy)]+-- Explicitly sized reps+addrToWordOrIntRep r+    | primRepIsWord r = (AddrToIntOp,intPrimTy) : (IntToWordOp,wordPrimTy) : sizedWordToSizedWord WordRep r+    | primRepIsInt r = (AddrToIntOp,intPrimTy) : sizedIntToSizedInt IntRep r+    | otherwise = pprPanic "Target rep not word or int rep" (ppr r)+++-- WordX# -> IntX# (same size), argument is source rep+wordToIntRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep)+wordToIntRep rep+    = case rep of+        (WordRep) -> (WordToIntOp, IntRep)+        (Word8Rep) -> (Word8ToInt8Op, Int8Rep)+        (Word16Rep) -> (Word16ToInt16Op, Int16Rep)+        (Word32Rep) -> (Word32ToInt32Op, Int32Rep)+        (Word64Rep) -> (Word64ToInt64Op, Int64Rep)+        _ -> pprPanic "Rep not a wordRep" (ppr rep)++-- IntX# -> WordX#, argument is source rep+intToWordRep :: HasDebugCallStack => PrimRep -> (PrimOp,PrimRep)+intToWordRep rep+    = case rep of+        (IntRep) -> (IntToWordOp, WordRep)+        (Int8Rep) -> (Int8ToWord8Op, Word8Rep)+        (Int16Rep) -> (Int16ToWord16Op, Word16Rep)+        (Int32Rep) -> (Int32ToWord32Op, Word32Rep)+        (Int64Rep) -> (Int64ToWord64Op, Word64Rep)+        _ -> pprPanic "Rep not a wordRep" (ppr rep)++-- Casts between any size int to any other size of int+sizedIntToSizedInt :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)]+sizedIntToSizedInt r1 r2+    | r1 == r2 = []+-- Cast to Int#+sizedIntToSizedInt r IntRep = [(intToMachineInt r,intPrimTy)]+-- Cast from Int#+sizedIntToSizedInt IntRep r = [(intFromMachineInt r,primRepToType r)]+-- Sized to differently sized must go over machine word.+sizedIntToSizedInt r1 r2 = (intToMachineInt r1,intPrimTy) : [(intFromMachineInt r2,primRepToType r2)]++-- Casts between any size Word to any other size of Word+sizedWordToSizedWord :: HasDebugCallStack => PrimRep -> PrimRep -> [(PrimOp,Type)]+sizedWordToSizedWord r1 r2+    | r1 == r2 = []+-- Cast to Word#+sizedWordToSizedWord r WordRep = [(wordToMachineWord r,wordPrimTy)]+-- Cast from Word#+sizedWordToSizedWord WordRep r = [(wordFromMachineWord r, primRepToType r)]+-- Conversion between different non-machine sizes must go via machine word.+sizedWordToSizedWord r1 r2 = (wordToMachineWord r1,wordPrimTy) : [(wordFromMachineWord r2, primRepToType r2)]+++-- Prefer the definitions above this line if possible+----------------------+++-- Int*# to Int#+{-# INLINE intToMachineInt #-}+intToMachineInt :: HasDebugCallStack => PrimRep -> PrimOp+intToMachineInt r =+    assertPpr (primRepIsInt r) (ppr r) $+    case r of+        (Int8Rep) -> Int8ToIntOp+        (Int16Rep) -> Int16ToIntOp+        (Int32Rep) -> Int32ToIntOp+        (Int64Rep) -> Int64ToIntOp+        _ -> pprPanic "Source rep not int" $ ppr r++-- Int# to Int*#+{-# INLINE intFromMachineInt #-}+intFromMachineInt :: HasDebugCallStack => PrimRep -> PrimOp+intFromMachineInt r =+    assertPpr (primRepIsInt r) (ppr r) $+    case r of+        Int8Rep -> IntToInt8Op+        Int16Rep -> IntToInt16Op+        Int32Rep -> IntToInt32Op+        Int64Rep -> IntToInt64Op+        _ -> pprPanic "Dest rep not sized int" $ ppr r++-- Word# to Word*#+{-# INLINE wordFromMachineWord #-}+wordFromMachineWord :: HasDebugCallStack => PrimRep -> PrimOp+wordFromMachineWord r =+    assert (primRepIsWord r) $+    case r of+        Word8Rep -> WordToWord8Op+        Word16Rep -> WordToWord16Op+        Word32Rep -> WordToWord32Op+        Word64Rep -> WordToWord64Op+        _ -> pprPanic "Dest rep not sized word" $ ppr r++-- Word*# to Word#+{-# INLINE wordToMachineWord #-}+wordToMachineWord :: HasDebugCallStack => PrimRep -> PrimOp+wordToMachineWord r =+    assertPpr (primRepIsWord r) (text "Not a word rep:" <> ppr r) $+    case r of+        Word8Rep -> Word8ToWordOp+        Word16Rep -> Word16ToWordOp+        Word32Rep -> Word32ToWordOp+        Word64Rep -> Word64ToWordOp+        _ -> pprPanic "Dest rep not sized word" $ ppr r

@@ -29,12 +29,12 @@  import GHC.Core.Type import GHC.Data.Pair-import GHC.Tc.Utils.TcType ( TcType, tcEqType ) import GHC.Core.TyCon    ( TyCon, FamTyConFlav(..), mkFamilyTyCon                          , Injectivity(..) ) import GHC.Core.Coercion ( Role(..) ) import GHC.Tc.Types.Constraint ( Xi ) import GHC.Core.Coercion.Axiom ( CoAxiomRule(..), BuiltInSynFamily(..), TypeEqn )+import GHC.Core.TyCo.Compare   ( tcEqType ) import GHC.Types.Name          ( Name, BuiltInSyntax(..) ) import GHC.Types.Unique.FM import GHC.Builtin.Types@@ -630,7 +630,7 @@          | tc1 == promotedGTDataCon -> return GT          | otherwise                -> Nothing -known :: (Integer -> Bool) -> TcType -> Bool+known :: (Integer -> Bool) -> Type -> Bool known p x = case isNumLitTy x of               Just a  -> p a               Nothing -> False

@@ -1,6 +1,5 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE BangPatterns #-}-{-# OPTIONS_GHC -Wno-incomplete-record-updates #-} module GHC.Cmm.ContFlowOpt     ( cmmCfgOpts     , cmmCfgOptsProc

@@ -29,7 +29,8 @@    -- * Unwinding information   UnwindTable, UnwindPoint(..),-  UnwindExpr(..), toUnwindExpr+  UnwindExpr(..), toUnwindExpr,+  pprUnwindTable   ) where  import GHC.Prelude@@ -38,6 +39,7 @@ import GHC.Cmm.BlockId import GHC.Cmm.CLabel import GHC.Cmm+import GHC.Cmm.Reg ( pprGlobalReg ) import GHC.Cmm.Utils import GHC.Data.FastString ( nilFS, mkFastString ) import GHC.Unit.Module@@ -522,10 +524,18 @@ instance OutputableP Platform UnwindExpr where   pdoc = pprUnwindExpr 0 -pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc+pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc+pprUnwindTable platform u = brackets (fsep (punctuate comma (map print_entry (Map.toList u))))+  where print_entry (reg, Nothing) =+          parens (sep [pprGlobalReg reg, text "Nothing"])+        print_entry (reg, Just x)  =+          parens (sep [pprGlobalReg reg, text "Just" <+> pprUnwindExpr 0 platform x])+  -- Follow instance Outputable (Map.Map GlobalReg (Maybe UnwindExpr))++pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc pprUnwindExpr p env = \case   UwConst i     -> int i-  UwReg g 0     -> ppr g+  UwReg g 0     -> pprGlobalReg g   UwReg g x     -> pprUnwindExpr p env (UwPlus (UwReg g 0) (UwConst x))   UwDeref e     -> char '*' <> pprUnwindExpr 3 env e   UwLabel l     -> pprAsmLabel env l@@ -536,6 +546,8 @@   UwTimes e0 e1    | p <= 1     -> pprUnwindExpr 2 env e0 <> char '*' <> pprUnwindExpr 2 env e1   other         -> parens (pprUnwindExpr 0 env other)+{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-}+{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Conversion of Cmm expressions to unwind expressions. We check for -- unsupported operator usages and simplify the expression as far as

@@ -961,7 +961,6 @@         ( "ne",         MO_Ne ),         ( "mul",        MO_Mul ),         ( "mulmayoflo",  MO_S_MulMayOflo ),-        ( "mulmayoflou", MO_U_MulMayOflo ),         ( "neg",        MO_S_Neg ),         ( "quot",       MO_S_Quot ),         ( "rem",        MO_S_Rem ),

@@ -2,8 +2,6 @@ {-# LANGUAGE DisambiguateRecordFields #-} {-# LANGUAGE GADTs #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- module GHC.Cmm.ProcPoint     ( ProcPointSet, Status(..)     , callProcPoints, minimalProcPointSet

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

@@ -197,9 +197,9 @@  -- | We make a top-level decl for the embedded binary file, and return a label pointing to it mkFileEmbedLit-  :: CLabel -> FilePath -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)-mkFileEmbedLit lbl path-  = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path]))+  :: CLabel -> FilePath -> Int -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)+mkFileEmbedLit lbl path len+  = (CmmLabel lbl, CmmData (Section ReadOnlyData lbl) (CmmStaticsRaw lbl [CmmFileEmbed path len]))   -- | Build a data-segment data block

@@ -15,8 +15,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE UnboxedTuples #-} -{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}- -- | Native code generator -- -- The native-code generator has machine-independent and@@ -83,6 +81,7 @@ import qualified GHC.CmmToAsm.X86   as X86 import qualified GHC.CmmToAsm.PPC   as PPC import qualified GHC.CmmToAsm.AArch64 as AArch64+import qualified GHC.CmmToAsm.Wasm as Wasm32  import GHC.CmmToAsm.Reg.Liveness import qualified GHC.CmmToAsm.Reg.Linear                as Linear@@ -125,7 +124,6 @@ import GHC.Utils.Misc import GHC.Utils.Logger -import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.BufHandle import GHC.Utils.Outputable as Outputable import GHC.Utils.Panic@@ -145,6 +143,7 @@ import Data.Ord         ( comparing ) import Control.Monad import System.IO+import System.Directory ( getCurrentDirectory )  -------------------- nativeCodeGen :: forall a . Logger -> NCGConfig -> ModLocation -> Handle -> UniqSupply@@ -169,6 +168,7 @@       ArchRISCV64   -> panic "nativeCodeGen: No NCG for RISCV64"       ArchUnknown   -> panic "nativeCodeGen: No NCG for unknown arch"       ArchJavaScript-> panic "nativeCodeGen: No NCG for JavaScript"+      ArchWasm32    -> Wasm32.ncgWasm platform us modLoc h cmms  -- | Data accumulated during code generation. Mostly about statistics, -- but also collects debug data for DWARF generation.@@ -242,16 +242,17 @@                 -> UniqSupply                 -> NativeGenAcc statics instr                 -> IO UniqSupply-finishNativeGen logger config modLoc bufh@(BufHandle _ _ h) us ngs+finishNativeGen logger config modLoc bufh us ngs  = withTimingSilent logger (text "NCG") (`seq` ()) $ do         -- Write debug data and finish         us' <- if not (ncgDwarfEnabled config)                   then return us                   else do-                     (dwarf, us') <- dwarfGen config modLoc us (ngs_debug ngs)-                     emitNativeCode logger config bufh dwarf+                     compPath <- getCurrentDirectory+                     let (dwarf_h, us') = dwarfGen compPath config modLoc us (ngs_debug ngs)+                         (dwarf_s, _)   = dwarfGen compPath config modLoc us (ngs_debug ngs)+                     emitNativeCode logger config bufh dwarf_h dwarf_s                      return us'-        bFlush bufh          -- dump global NCG stats for graph coloring allocator         let stats = concat (ngs_colorStats ngs)@@ -284,8 +285,9 @@          -- write out the imports         let ctx = ncgAsmContext config-        printSDocLn ctx Pretty.LeftMode h-                $ makeImportsDoc config (concat (ngs_imports ngs))+        bPutHDoc bufh ctx $ makeImportsDoc config (concat (ngs_imports ngs))+        bFlush bufh+         return us'   where     dump_stats = logDumpFile logger (mkDumpStyle alwaysQualify)@@ -387,12 +389,17 @@         let newFileIds = sortBy (comparing snd) $                          nonDetEltsUFM $ fileIds' `minusUFM` fileIds             -- See Note [Unique Determinism and code generation]-            pprDecl (f,n) = text "\t.file " <> int n <+>-                            pprFilePathString (unpackFS f)+            pprDecl (f,n) = line $ text "\t.file " <> int n <+>+                                   pprFilePathString (unpackFS f) -        emitNativeCode logger config h $ vcat $-          map pprDecl newFileIds ++-          map (pprNatCmmDecl ncgImpl) native+        -- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad+        emitNativeCode logger config h+          (vcat $+           map pprDecl newFileIds +++           map (pprNatCmmDeclH ncgImpl) native)+          (vcat $+           map pprDecl newFileIds +++           map (pprNatCmmDeclS ncgImpl) native)          -- force evaluation all this stuff to avoid space leaks         let platform = ncgPlatform config@@ -415,11 +422,11 @@         go us' cmms ngs' (count + 1)  -emitNativeCode :: Logger -> NCGConfig -> BufHandle -> SDoc -> IO ()-emitNativeCode logger config h sdoc = do-+-- see Note [pprNatCmmDeclS and pprNatCmmDeclH] in GHC.CmmToAsm.Monad+emitNativeCode :: Logger -> NCGConfig -> BufHandle -> HDoc -> SDoc -> IO ()+emitNativeCode logger config h hdoc sdoc = do         let ctx = ncgAsmContext config-        {-# SCC "pprNativeCode" #-} bufLeftRenderSDoc ctx h sdoc+        {-# SCC "pprNativeCode" #-} bPutHDoc h ctx hdoc          -- dump native code         putDumpFileMaybe logger@@ -483,7 +490,7 @@          putDumpFileMaybe logger                 Opt_D_dump_asm_native "Native code" FormatASM-                (vcat $ map (pprNatCmmDecl ncgImpl) native)+                (vcat $ map (pprNatCmmDeclS ncgImpl) native)          maybeDumpCfg logger (Just nativeCfgWeights) "CFG Weights - Native" proc_name @@ -540,7 +547,7 @@                 putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM-                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)+                        (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)                  putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc_stages "Build/spill stages"@@ -584,7 +591,7 @@                 putDumpFileMaybe logger                         Opt_D_dump_asm_regalloc "Registers allocated"                         FormatCMM-                        (vcat $ map (pprNatCmmDecl ncgImpl) alloced)+                        (vcat $ map (pprNatCmmDeclS ncgImpl) alloced)                  let mPprStats =                         if logHasDumpFlag logger Opt_D_dump_asm_stats@@ -736,7 +743,7 @@  -- | Build a doc for all the imports. ---makeImportsDoc :: NCGConfig -> [CLabel] -> SDoc+makeImportsDoc :: NCGConfig -> [CLabel] -> HDoc makeImportsDoc config imports  = dyld_stubs imports             $$@@ -744,7 +751,7 @@             -- dead-stripping of code and data on a per-symbol basis.             -- There's a hack to make this work in PprMach.pprNatCmmDecl.             (if platformHasSubsectionsViaSymbols platform-             then text ".subsections_via_symbols"+             then line $ text ".subsections_via_symbols"              else Outputable.empty)             $$                 -- On recent GNU ELF systems one can mark an object file@@ -754,14 +761,14 @@                 -- security. GHC generated code does not need an executable                 -- stack so add the note in:             (if platformHasGnuNonexecStack platform-             then text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"+             then line $ text ".section .note.GNU-stack,\"\"," <> sectionType platform "progbits"              else Outputable.empty)             $$                 -- And just because every other compiler does, let's stick in                 -- an identifier directive: .ident "GHC x.y.z"             (if platformHasIdentDirective platform              then let compilerIdent = text "GHC" <+> text cProjectVersion-                   in text ".ident" <+> doubleQuotes compilerIdent+                   in line $ text ".ident" <+> doubleQuotes compilerIdent              else Outputable.empty)   where@@ -769,7 +776,7 @@          -- Generate "symbol stubs" for all external symbols that might         -- come from a dynamic library.-        dyld_stubs :: [CLabel] -> SDoc+        dyld_stubs :: [CLabel] -> HDoc         -- (Hack) sometimes two Labels pretty-print the same, but have         -- different uniques; so we compare their text versions...         dyld_stubs imps@@ -798,7 +805,7 @@ generateJumpTables ncgImpl xs = concatMap f xs     where f p@(CmmProc _ _ _ (ListGraph xs)) = p : concatMap g xs           f p = [p]-          g (BasicBlock _ xs) = catMaybes (map (generateJumpTableForInstr ncgImpl) xs)+          g (BasicBlock _ xs) = mapMaybe (generateJumpTableForInstr ncgImpl) xs  -- ----------------------------------------------------------------------------- -- Shortcut branches

@@ -11,6 +11,7 @@ import GHC.CmmToAsm.Monad import GHC.CmmToAsm.Config import GHC.CmmToAsm.Types+import GHC.Utils.Outputable (ftext)  import qualified GHC.CmmToAsm.AArch64.Instr   as AArch64 import qualified GHC.CmmToAsm.AArch64.Ppr     as AArch64@@ -28,7 +29,8 @@        ,canShortcut               = AArch64.canShortcut        ,shortcutStatics           = AArch64.shortcutStatics        ,shortcutJump              = AArch64.shortcutJump-       ,pprNatCmmDecl             = AArch64.pprNatCmmDecl config+       ,pprNatCmmDeclS            = AArch64.pprNatCmmDecl config+       ,pprNatCmmDeclH            = AArch64.pprNatCmmDecl config        ,maxSpillSlots             = AArch64.maxSpillSlots config        ,allocatableRegs           = AArch64.allocatableRegs platform        ,ncgAllocMoreStack         = AArch64.allocMoreStack platform@@ -55,5 +57,5 @@         mkJumpInstr             = AArch64.mkJumpInstr         mkStackAllocInstr       = AArch64.mkStackAllocInstr         mkStackDeallocInstr     = AArch64.mkStackDeallocInstr-        mkComment               = pure . AArch64.COMMENT+        mkComment               = pure . AArch64.COMMENT . ftext         pprInstr                = AArch64.pprInstr

@@ -910,7 +910,6 @@                       intOp True w (\d x y -> toOL [ SDIV t x y, MSUB d t y x ])          -- Unsigned multiply/divide-        MO_U_MulMayOflo _w -> unsupportedP plat expr         MO_U_Quot w -> intOp False w (\d x y -> unitOL $ UDIV d x y)         MO_U_Rem w  -> withTempIntReg w $ \t ->                        intOp False w (\d x y -> toOL [ UDIV t x y, MSUB d t y x ])@@ -962,9 +961,6 @@       -> pprPanic "getRegister' (variadic CmmMachOp): " (pdoc plat expr)    where-    unsupportedP :: OutputableP env a => env -> a -> b-    unsupportedP platform op = pprPanic "Unsupported op:" (pdoc platform op)-     isNbitEncodeable :: Int -> Integer -> Bool     isNbitEncodeable n i = let shift = n - 1 in (-1 `shiftL` shift) <= i && i < (1 `shiftL` shift)     -- This needs to check if n can be encoded as a bitmask immediate:

@@ -29,12 +29,12 @@  import GHC.Utils.Panic -pprProcAlignment :: NCGConfig -> SDoc+pprProcAlignment :: IsDoc doc => NCGConfig -> doc pprProcAlignment config = maybe empty (pprAlign platform . mkAlignment) (ncgProcAlignment config)    where       platform = ncgPlatform config -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc+pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) =   pprSectionAlign config section $$ pprDatas config dats @@ -50,42 +50,45 @@         pprLabel platform lbl $$ -- blocks guaranteed not null, so label needed         vcat (map (pprBasicBlock config top_info) blocks) $$         (if ncgDwarfEnabled config-         then pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':' else empty) $$+         then line (pprAsmLabel platform (mkAsmTempEndLabel lbl) <> char ':') else empty) $$         pprSizeDecl platform lbl      Just (CmmStaticsRaw info_lbl _) ->       pprSectionAlign config (Section Text info_lbl) $$       -- pprProcAlignment config $$       (if platformHasSubsectionsViaSymbols platform-          then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':'+          then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')           else empty) $$       vcat (map (pprBasicBlock config top_info) blocks) $$       -- above: Even the first block gets a label, because with branch-chain       -- elimination, it might be the target of a goto.       (if platformHasSubsectionsViaSymbols platform        then -- See Note [Subsections Via Symbols]-                text "\t.long "+                line+              $ text "\t.long "             <+> pprAsmLabel platform info_lbl             <+> char '-'             <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)        else empty) $$       pprSizeDecl platform info_lbl+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprLabel :: Platform -> CLabel -> SDoc+pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl =    pprGloblDecl platform lbl    $$ pprTypeDecl platform lbl-   $$ (pprAsmLabel platform lbl <> char ':')+   $$ line (pprAsmLabel platform lbl <> char ':') -pprAlign :: Platform -> Alignment -> SDoc+pprAlign :: IsDoc doc => Platform -> Alignment -> doc pprAlign _platform alignment-        = text "\t.balign " <> int (alignmentBytes alignment)+        = line $ text "\t.balign " <> int (alignmentBytes alignment)  -- | Print appropriate alignment for the given section type.-pprAlignForSection :: Platform -> SectionType -> SDoc+pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc pprAlignForSection _platform _seg     -- .balign is stable, whereas .align is platform dependent.-    = text "\t.balign 8" --  always 8+    = line (text "\t.balign 8") --  always 8  -- | Print section header and appropriate alignment for that section. --@@ -94,28 +97,28 @@ --     .section .text --     .balign 8 ---pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign _config (Section (OtherSection _) _) =      panic "AArch64.Ppr.pprSectionAlign: unknown section" pprSectionAlign config sec@(Section seg _) =-    pprSectionHeader config sec+    line (pprSectionHeader config sec)     $$ pprAlignForSection (ncgPlatform config) seg  -- | Output the ELF .size directive.-pprSizeDecl :: Platform -> CLabel -> SDoc+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl  = if osElfTarget (platformOS platform)-   then text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl+   then line (text "\t.size" <+> pprAsmLabel platform lbl <> text ", .-" <> pprAsmLabel platform lbl)    else empty -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr-              -> SDoc+pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr+              -> doc pprBasicBlock config info_env (BasicBlock blockid instrs)   = maybe_infotable $     pprLabel platform asmLbl $$     vcat (map (pprInstr platform) (id {-detectTrivialDeadlock-} optInstrs)) $$     (if  ncgDwarfEnabled config-      then pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'+      then line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':')       else empty     )   where@@ -135,7 +138,7 @@            pprLabel platform info_lbl $$            c $$            (if ncgDwarfEnabled config-             then pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':'+             then line (pprAsmLabel platform (mkAsmTempEndLabel info_lbl) <> char ':')              else empty)     -- Make sure the info table has the right .loc for the block     -- coming right after it. See Note [Info Offset]@@ -143,7 +146,7 @@       (l@LOCATION{} : _) -> pprInstr platform l       _other             -> empty -pprDatas :: NCGConfig -> RawCmmStatics -> SDoc+pprDatas :: IsDoc doc => NCGConfig -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas config (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])   | lbl == mkIndStaticInfoLabel@@ -153,29 +156,29 @@   , Just ind' <- labelInd ind   , alias `mayRedirectTo` ind'   = pprGloblDecl (ncgPlatform config) alias-    $$ text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind'+    $$ line (text ".equiv" <+> pprAsmLabel (ncgPlatform config) alias <> comma <> pprAsmLabel (ncgPlatform config) ind')  pprDatas config (CmmStaticsRaw lbl dats)   = vcat (pprLabel platform lbl : map (pprData config) dats)    where       platform = ncgPlatform config -pprData :: NCGConfig -> CmmStatic -> SDoc-pprData _config (CmmString str) = pprString str-pprData _config (CmmFileEmbed path) = pprFileEmbed path+pprData :: IsDoc doc => NCGConfig -> CmmStatic -> doc+pprData _config (CmmString str) = line (pprString str)+pprData _config (CmmFileEmbed path _) = line (pprFileEmbed path)  pprData config (CmmUninitialised bytes)- = let platform = ncgPlatform config-   in if platformOS platform == OSDarwin-         then text ".space " <> int bytes-         else text ".skip "  <> int bytes+ = line $ let platform = ncgPlatform config+          in if platformOS platform == OSDarwin+                then text ".space " <> int bytes+                else text ".skip "  <> int bytes  pprData config (CmmStaticLit lit) = pprDataItem config lit -pprGloblDecl :: Platform -> CLabel -> SDoc+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl   | not (externallyVisibleCLabel lbl) = empty-  | otherwise = text "\t.globl " <> pprAsmLabel platform lbl+  | otherwise = line (text "\t.globl " <> pprAsmLabel platform lbl)  -- Note [Always use objects for info tables] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~@@ -187,7 +190,7 @@ -- -- Fun fact: The LLVMMangler exists to patch this issue su on the LLVM side as -- well.-pprLabelType' :: Platform -> CLabel -> SDoc+pprLabelType' :: IsLine doc => Platform -> CLabel -> doc pprLabelType' platform lbl =   if isCFunctionLabel lbl || functionOkInfoTable then     text "@function"@@ -198,15 +201,15 @@       isInfoTableLabel lbl && not (isCmmInfoTableLabel lbl) && not (isConInfoTableLabel lbl)  -- this is called pprTypeAndSizeDecl in PPC.Ppr-pprTypeDecl :: Platform -> CLabel -> SDoc+pprTypeDecl :: IsDoc doc => Platform -> CLabel -> doc pprTypeDecl platform lbl     = if osElfTarget (platformOS platform) && externallyVisibleCLabel lbl-      then text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl+      then line (text ".type " <> pprAsmLabel platform lbl <> text ", " <> pprLabelType' platform lbl)       else empty -pprDataItem :: NCGConfig -> CmmLit -> SDoc+pprDataItem :: IsDoc doc => NCGConfig -> CmmLit -> doc pprDataItem config lit-  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)     where         platform = ncgPlatform config @@ -227,12 +230,12 @@          ppr_item _ _ = pprPanic "pprDataItem:ppr_item" (text $ show lit) -pprImm :: Platform -> Imm -> SDoc+pprImm :: IsLine doc => Platform -> Imm -> doc pprImm _ (ImmInt i)     = int i pprImm _ (ImmInteger i) = integer i pprImm p (ImmCLbl l)    = pprAsmLabel p l pprImm p (ImmIndex l i) = pprAsmLabel p l <> char '+' <> int i-pprImm _ (ImmLit s)     = text s+pprImm _ (ImmLit s)     = ftext s  -- TODO: See pprIm below for why this is a bad idea! pprImm _ (ImmFloat f)@@ -257,7 +260,7 @@ asmMultilineComment :: SDoc -> SDoc asmMultilineComment c = whenPprDebug $ text "/*" $+$ c $+$ text "*/" -pprIm :: Platform -> Imm -> SDoc+pprIm :: IsLine doc => Platform -> Imm -> doc pprIm platform im = case im of   ImmInt i     -> char '#' <> int i   ImmInteger i -> char '#' <> integer i@@ -283,7 +286,7 @@   ImmIndex l o -> text "[=" <> pprAsmLabel platform l <> comma <+> char '#' <> int o <> char ']'   _            -> panic "AArch64.pprIm" -pprExt :: ExtMode -> SDoc+pprExt :: IsLine doc => ExtMode -> doc pprExt EUXTB = text "uxtb" pprExt EUXTH = text "uxth" pprExt EUXTW = text "uxtw"@@ -293,13 +296,13 @@ pprExt ESXTW = text "sxtw" pprExt ESXTX = text "sxtx" -pprShift :: ShiftMode -> SDoc+pprShift :: IsLine doc => ShiftMode -> doc pprShift SLSL = text "lsl" pprShift SLSR = text "lsr" pprShift SASR = text "asr" pprShift SROR = text "ror" -pprOp :: Platform -> Operand -> SDoc+pprOp :: IsLine doc => Platform -> Operand -> doc pprOp plat op = case op of   OpReg w r           -> pprReg w r   OpRegExt w r x 0 -> pprReg w r <> comma <+> pprExt x@@ -312,7 +315,7 @@   OpAddr (AddrRegImm r1 im) -> char '[' <+> pprReg W64 r1 <> comma <+> pprImm plat im <+> char ']'   OpAddr (AddrReg r1)       -> char '[' <+> pprReg W64 r1 <+> char ']' -pprReg :: Width -> Reg -> SDoc+pprReg :: forall doc. IsLine doc => Width -> Reg -> doc pprReg w r = case r of   RegReal    (RealRegSingle i) -> ppr_reg_no w i   -- virtual regs should not show up, but this is helpful for debugging.@@ -322,7 +325,7 @@   _                            -> pprPanic "AArch64.pprReg" (text $ show r)    where-    ppr_reg_no :: Width -> Int -> SDoc+    ppr_reg_no :: Width -> Int -> doc     ppr_reg_no w 31          | w == W64 = text "sp"          | w == W32 = text "wsp"@@ -351,24 +354,27 @@ isFloatOp (OpReg _ (RegVirtual (VirtualRegD _))) = True isFloatOp _ = False -pprInstr :: Platform -> Instr -> SDoc+pprInstr :: IsDoc doc => Platform -> Instr -> doc pprInstr platform instr = case instr of   -- Meta Instructions ----------------------------------------------------------  COMMENT s  -> asmComment s-  MULTILINE_COMMENT s -> asmMultilineComment s-  ANN d i -> pprInstr platform i <+> asmDoubleslashComment d-  LOCATION file line col _name-    -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col-  DELTA d    -> asmComment $ text ("\tdelta = " ++ show d)+  -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable+  COMMENT s  -> dualDoc (asmComment s) empty+  MULTILINE_COMMENT s -> dualDoc (asmMultilineComment s) empty+  ANN d i -> dualDoc (pprInstr platform i <+> asmDoubleslashComment d) (pprInstr platform i)++  LOCATION file line' col _name+    -> line (text "\t.loc" <+> int file <+> int line' <+> int col)+  DELTA d   -> dualDoc (asmComment $ text "\tdelta = " <> int d) empty+               -- see Note [dualLine and dualDoc] in GHC.Utils.Outputable   NEWBLOCK _ -> panic "PprInstr: NEWBLOCK"   LDATA _ _  -> panic "pprInstr: LDATA"    -- Pseudo Instructions ------------------------------------------------------- -  PUSH_STACK_FRAME -> text "\tstp x29, x30, [sp, #-16]!"-                   $$ text "\tmov x29, sp"+  PUSH_STACK_FRAME -> lines_ [text "\tstp x29, x30, [sp, #-16]!",+                              text "\tmov x29, sp"] -  POP_STACK_FRAME -> text "\tldp x29, x30, [sp], #16"+  POP_STACK_FRAME -> line $ text "\tldp x29, x30, [sp], #16"   -- ===========================================================================   -- AArch64 Instruction Set   -- 1. Arithmetic Instructions ------------------------------------------------@@ -430,28 +436,28 @@    -- 4. Branch Instructions ----------------------------------------------------   J t            -> pprInstr platform (B t)-  B (TBlock bid) -> text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))-  B (TLabel lbl) -> text "\tb" <+> pprAsmLabel platform lbl-  B (TReg r)     -> text "\tbr" <+> pprReg W64 r+  B (TBlock bid) -> line $ text "\tb" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  B (TLabel lbl) -> line $ text "\tb" <+> pprAsmLabel platform lbl+  B (TReg r)     -> line $ text "\tbr" <+> pprReg W64 r -  BL (TBlock bid) _ _ -> text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))-  BL (TLabel lbl) _ _ -> text "\tbl" <+> pprAsmLabel platform lbl-  BL (TReg r)     _ _ -> text "\tblr" <+> pprReg W64 r+  BL (TBlock bid) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BL (TLabel lbl) _ _ -> line $ text "\tbl" <+> pprAsmLabel platform lbl+  BL (TReg r)     _ _ -> line $ text "\tblr" <+> pprReg W64 r -  BCOND c (TBlock bid) -> text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))-  BCOND c (TLabel lbl) -> text "\t" <> pprBcond c <+> pprAsmLabel platform lbl+  BCOND c (TBlock bid) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  BCOND c (TLabel lbl) -> line $ text "\t" <> pprBcond c <+> pprAsmLabel platform lbl   BCOND _ (TReg _)     -> panic "AArch64.ppr: No conditional branching to registers!"    -- 5. Atomic Instructions ----------------------------------------------------   -- 6. Conditional Instructions ------------------------------------------------  CSET o c  -> text "\tcset" <+> pprOp platform o <> comma <+> pprCond c+  CSET o c  -> line $ text "\tcset" <+> pprOp platform o <> comma <+> pprCond c -  CBZ o (TBlock bid) -> text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))-  CBZ o (TLabel lbl) -> text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl+  CBZ o (TBlock bid) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  CBZ o (TLabel lbl) -> line $ text "\tcbz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl   CBZ _ (TReg _)     -> panic "AArch64.ppr: No conditional (cbz) branching to registers!" -  CBNZ o (TBlock bid) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))-  CBNZ o (TLabel lbl) -> text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl+  CBNZ o (TBlock bid) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform (mkLocalBlockLabel (getUnique bid))+  CBNZ o (TLabel lbl) -> line $ text "\tcbnz" <+> pprOp platform o <> comma <+> pprAsmLabel platform lbl   CBNZ _ (TReg _)     -> panic "AArch64.ppr: No conditional (cbnz) branching to registers!"    -- 7. Load and Store Instructions --------------------------------------------@@ -532,23 +538,23 @@   LDP _f o1 o2 o3 -> op3 (text "\tldp") o1 o2 o3    -- 8. Synchronization Instructions --------------------------------------------  DMBSY -> text "\tdmb sy"+  DMBSY -> line $ text "\tdmb sy"   -- 9. Floating Point Instructions --------------------------------------------   FCVT o1 o2 -> op2 (text "\tfcvt") o1 o2   SCVTF o1 o2 -> op2 (text "\tscvtf") o1 o2   FCVTZS o1 o2 -> op2 (text "\tfcvtzs") o1 o2   FABS o1 o2 -> op2 (text "\tfabs") o1 o2- where op2 op o1 o2 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2-       op3 op o1 o2 o3 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3-       op4 op o1 o2 o3 o4 = op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4-       op_ldr o1 rest = text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]"-       op_adrp o1 rest = text "\tadrp" <+> pprOp platform o1 <> comma <+> rest-       op_add o1 rest = text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest+ where op2 op o1 o2        = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2+       op3 op o1 o2 o3     = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3+       op4 op o1 o2 o3 o4  = line $ op <+> pprOp platform o1 <> comma <+> pprOp platform o2 <> comma <+> pprOp platform o3 <> comma <+> pprOp platform o4+       op_ldr o1 rest      = line $ text "\tldr" <+> pprOp platform o1 <> comma <+> text "[" <> pprOp platform o1 <> comma <+> rest <> text "]"+       op_adrp o1 rest     = line $ text "\tadrp" <+> pprOp platform o1 <> comma <+> rest+       op_add o1 rest      = line $ text "\tadd" <+> pprOp platform o1 <> comma <+> pprOp platform o1 <> comma <+> rest -pprBcond :: Cond -> SDoc+pprBcond :: IsLine doc => Cond -> doc pprBcond c = text "b." <> pprCond c -pprCond :: Cond -> SDoc+pprCond :: IsLine doc => Cond -> doc pprCond c = case c of   ALWAYS -> text "al" -- Always   EQ     -> text "eq" -- Equal

@@ -2,6 +2,7 @@ module GHC.CmmToAsm.AArch64.Regs where  import GHC.Prelude+import GHC.Data.FastString  import GHC.Platform.Reg import GHC.Platform.Reg.Class@@ -59,7 +60,7 @@   = ImmInt      Int   | ImmInteger  Integer     -- Sigh.   | ImmCLbl     CLabel      -- AbstractC Label (with baggage)-  | ImmLit      String+  | ImmLit      FastString   | ImmIndex    CLabel Int   | ImmFloat    Rational   | ImmDouble   Rational@@ -67,7 +68,7 @@   | ImmConstantDiff Imm Imm   deriving (Eq, Show) -strImmLit :: String -> Imm+strImmLit :: FastString -> Imm strImmLit s = ImmLit s  

@@ -35,7 +35,6 @@ import GHC.Data.List.SetOps (removeDups) import GHC.Data.OrdList -import GHC.Utils.Trace import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain@@ -658,7 +657,7 @@ sequenceChain _info _weights    [x] = [x] sequenceChain  info weights     blocks@((BasicBlock entry _):_) =     let directEdges :: [CfgEdge]-        directEdges = sortBy (flip compare) $ catMaybes . map relevantWeight $ (infoEdgeList weights)+        directEdges = sortBy (flip compare) $ mapMaybe relevantWeight (infoEdgeList weights)           where             -- Apply modifiers to turn edge frequencies into useable weights             -- for computing code layout.

@@ -26,50 +26,47 @@ import Data.Ord         ( comparing ) import qualified Data.Map as Map import System.FilePath-import System.Directory ( getCurrentDirectory )  import qualified GHC.Cmm.Dataflow.Label as H import qualified GHC.Cmm.Dataflow.Collections as H  -- | Generate DWARF/debug information-dwarfGen :: NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]-            -> IO (SDoc, UniqSupply)-dwarfGen _      _      us []     = return (empty, us)-dwarfGen config modLoc us blocks = do+dwarfGen :: IsDoc doc => String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock]+            -> (doc, UniqSupply)+dwarfGen _        _      _      us []     = (empty, us)+dwarfGen compPath config modLoc us blocks =   let platform = ncgPlatform config -  -- Convert debug data structures to DWARF info records-  let procs = debugSplitProcs blocks+      -- Convert debug data structures to DWARF info records+      procs = debugSplitProcs blocks       stripBlocks dbg         | ncgDwarfStripBlockInfo config = dbg { dblBlocks = [] }         | otherwise                     = dbg-  compPath <- getCurrentDirectory-  let lowLabel = dblCLabel $ head procs+      lowLabel = dblCLabel $ head procs       highLabel = mkAsmTempProcEndLabel $ dblCLabel $ last procs       dwarfUnit = DwarfCompileUnit         { dwChildren = map (procToDwarf config) (map stripBlocks procs)         , dwName = fromMaybe "" (ml_hs_file modLoc)         , dwCompDir = addTrailingPathSeparator compPath         , dwProducer = cProjectName ++ " " ++ cProjectVersion-        , dwLowLabel = pprAsmLabel platform lowLabel-        , dwHighLabel = pprAsmLabel platform highLabel-        , dwLineLabel = dwarfLineLabel+        , dwLowLabel = lowLabel+        , dwHighLabel = highLabel         } -  -- Check whether we have any source code information, so we do not-  -- end up writing a pointer to an empty .debug_line section-  -- (dsymutil on Mac Os gets confused by this).-  let haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)+      -- Check whether we have any source code information, so we do not+      -- end up writing a pointer to an empty .debug_line section+      -- (dsymutil on Mac Os gets confused by this).+      haveSrcIn blk = isJust (dblSourceTick blk) && isJust (dblPosition blk)                       || any haveSrcIn (dblBlocks blk)       haveSrc = any haveSrcIn procs    -- .debug_abbrev section: Declare the format we're using-  let abbrevSct = pprAbbrevDecls platform haveSrc+      abbrevSct = pprAbbrevDecls platform haveSrc    -- .debug_info section: Information records on procedures and blocks-  let -- unique to identify start and end compilation unit .debug_inf+      -- unique to identify start and end compilation unit .debug_inf       (unitU, us') = takeUniqFromSupply us-      infoSct = vcat [ dwarfInfoLabel <> colon+      infoSct = vcat [ line (dwarfInfoLabel <> colon)                      , dwarfInfoSection platform                      , compileUnitHeader platform unitU                      , pprDwarfInfo platform haveSrc dwarfUnit@@ -78,21 +75,23 @@    -- .debug_line section: Generated mainly by the assembler, but we   -- need to label it-  let lineSct = dwarfLineSection platform $$-                dwarfLineLabel <> colon+      lineSct = dwarfLineSection platform $$+                line (dwarfLineLabel <> colon)    -- .debug_frame section: Information about the layout of the GHC stack-  let (framesU, us'') = takeUniqFromSupply us'+      (framesU, us'') = takeUniqFromSupply us'       frameSct = dwarfFrameSection platform $$-                 dwarfFrameLabel <> colon $$+                 line (dwarfFrameLabel <> colon) $$                  pprDwarfFrame platform (debugFrame framesU procs)    -- .aranges section: Information about the bounds of compilation units-  let aranges' | ncgSplitSections config = map mkDwarfARange procs+      aranges' | ncgSplitSections config = map mkDwarfARange procs                | otherwise               = [DwarfARange lowLabel highLabel]-  let aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU+      aranges = dwarfARangesSection platform $$ pprDwarfARanges platform aranges' unitU -  return (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')+  in (infoSct $$ abbrevSct $$ lineSct $$ frameSct $$ aranges, us'')+{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (SDoc, UniqSupply) #-}+{-# SPECIALIZE dwarfGen :: String -> NCGConfig -> ModLocation -> UniqSupply -> [DebugBlock] -> (HDoc, UniqSupply) #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Build an address range entry for one proc. -- With split sections, each proc needs its own entry, since they may get@@ -106,24 +105,24 @@  -- | Header for a compilation unit, establishing global format -- parameters-compileUnitHeader :: Platform -> Unique -> SDoc+compileUnitHeader :: IsDoc doc => Platform -> Unique -> doc compileUnitHeader platform unitU =   let cuLabel = mkAsmTempLabel unitU  -- sits right before initialLength field       length = pprAsmLabel platform (mkAsmTempEndLabel cuLabel) <> char '-' <> pprAsmLabel platform cuLabel                <> text "-4"       -- length of initialLength field-  in vcat [ pprAsmLabel platform cuLabel <> colon-          , text "\t.long " <> length  -- compilation unit size+  in vcat [ line (pprAsmLabel platform cuLabel <> colon)+          , line (text "\t.long " <> length)  -- compilation unit size           , pprHalf 3                          -- DWARF version           , sectionOffset platform dwarfAbbrevLabel dwarfAbbrevLabel                                                -- abbrevs offset-          , text "\t.byte " <> ppr (platformWordSizeInBytes platform) -- word size+          , line (text "\t.byte " <> int (platformWordSizeInBytes platform)) -- word size           ]  -- | Compilation unit footer, mainly establishing size of debug sections-compileUnitFooter :: Platform -> Unique -> SDoc+compileUnitFooter :: IsDoc doc => Platform -> Unique -> doc compileUnitFooter platform unitU =   let cuEndLabel = mkAsmTempEndLabel $ mkAsmTempLabel unitU-  in pprAsmLabel platform cuEndLabel <> colon+  in line (pprAsmLabel platform cuEndLabel <> colon)  -- | Splits the blocks by procedures. In the result all nested blocks -- will come from the same procedure as the top-level block. See

@@ -144,17 +144,29 @@  -- * Dwarf section declarations dwarfInfoSection, dwarfAbbrevSection, dwarfLineSection,-  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: Platform -> SDoc+  dwarfFrameSection, dwarfGhcSection, dwarfARangesSection :: IsDoc doc => Platform -> doc dwarfInfoSection    platform = dwarfSection platform "info" dwarfAbbrevSection  platform = dwarfSection platform "abbrev" dwarfLineSection    platform = dwarfSection platform "line" dwarfFrameSection   platform = dwarfSection platform "frame" dwarfGhcSection     platform = dwarfSection platform "ghc" dwarfARangesSection platform = dwarfSection platform "aranges"+{-# SPECIALIZE dwarfInfoSection :: Platform -> SDoc #-}+{-# SPECIALIZE dwarfInfoSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfAbbrevSection :: Platform -> SDoc #-}+{-# SPECIALIZE dwarfAbbrevSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfLineSection :: Platform -> SDoc #-}+{-# SPECIALIZE dwarfLineSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfFrameSection :: Platform -> SDoc #-}+{-# SPECIALIZE dwarfFrameSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfGhcSection :: Platform -> SDoc #-}+{-# SPECIALIZE dwarfGhcSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfARangesSection :: Platform -> SDoc #-}+{-# SPECIALIZE dwarfARangesSection :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -dwarfSection :: Platform -> String -> SDoc+dwarfSection :: IsDoc doc => Platform -> String -> doc dwarfSection platform name =-  case platformOS platform of+  line $ case platformOS platform of     os | osElfTarget os        -> text "\t.section .debug_" <> text name <> text ",\"\","           <> sectionType platform "progbits"@@ -162,13 +174,24 @@        -> text "\t.section __DWARF,__debug_" <> text name <> text ",regular,debug"        | otherwise        -> text "\t.section .debug_" <> text name <> text ",\"dr\""+{-# SPECIALIZE dwarfSection :: Platform -> String -> SDoc #-}+{-# SPECIALIZE dwarfSection :: Platform -> String -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable + -- * Dwarf section labels-dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: SDoc+dwarfInfoLabel, dwarfAbbrevLabel, dwarfLineLabel, dwarfFrameLabel :: IsLine doc => doc dwarfInfoLabel   = text ".Lsection_info" dwarfAbbrevLabel = text ".Lsection_abbrev" dwarfLineLabel   = text ".Lsection_line" dwarfFrameLabel  = text ".Lsection_frame"+{-# SPECIALIZE dwarfInfoLabel :: SDoc #-}+{-# SPECIALIZE dwarfInfoLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfAbbrevLabel :: SDoc #-}+{-# SPECIALIZE dwarfAbbrevLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfLineLabel :: SDoc #-}+{-# SPECIALIZE dwarfLineLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable+{-# SPECIALIZE dwarfFrameLabel :: SDoc #-}+{-# SPECIALIZE dwarfFrameLabel :: HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Mapping of registers to DWARF register numbers dwarfRegNo :: Platform -> Reg -> Word8

@@ -59,9 +59,8 @@                      , dwName :: String                      , dwProducer :: String                      , dwCompDir :: String-                     , dwLowLabel :: SDoc-                     , dwHighLabel :: SDoc-                     , dwLineLabel :: SDoc }+                     , dwLowLabel :: CLabel+                     , dwHighLabel :: CLabel }   | DwarfSubprogram { dwChildren :: [DwarfInfo]                     , dwName :: String                     , dwLabel :: CLabel@@ -88,13 +87,13 @@   deriving (Eq, Enum)  -- | Generate assembly for the given abbreviation code-pprAbbrev :: DwarfAbbrev -> SDoc+pprAbbrev :: IsDoc doc => DwarfAbbrev -> doc pprAbbrev = pprLEBWord . fromIntegral . fromEnum  -- | Abbreviation declaration. This explains the binary encoding we -- use for representing 'DwarfInfo'. Be aware that this must be updated -- along with 'pprDwarfInfo'.-pprAbbrevDecls :: Platform -> Bool -> SDoc+pprAbbrevDecls :: IsDoc doc => Platform -> Bool -> doc pprAbbrevDecls platform haveDebugLine =   let mkAbbrev abbr tag chld flds =         let fld (tag, form) = pprLEBWord tag $$ pprLEBWord form@@ -111,7 +110,7 @@            , (dW_AT_frame_base, dW_FORM_block1)            ]   in dwarfAbbrevSection platform $$-     dwarfAbbrevLabel <> colon $$+     line (dwarfAbbrevLabel <> colon) $$      mkAbbrev DwAbbrCompileUnit dW_TAG_compile_unit dW_CHILDREN_yes        ([(dW_AT_name,     dW_FORM_string)        , (dW_AT_producer, dW_FORM_string)@@ -144,9 +143,11 @@        , (dW_AT_ghc_span_end_col, dW_FORM_data2)        ] $$      pprByte 0+{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> SDoc #-}+{-# SPECIALIZE pprAbbrevDecls :: Platform -> Bool -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Generate assembly for DWARF data-pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc+pprDwarfInfo :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfo platform haveSrc d   = case d of       DwarfCompileUnit {}  -> hasChildren@@ -159,9 +160,11 @@         vcat (map (pprDwarfInfo platform haveSrc) (dwChildren d)) $$         pprDwarfInfoClose     noChildren = pprDwarfInfoOpen platform haveSrc d+{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> SDoc #-}+{-# SPECIALIZE pprDwarfInfo :: Platform -> Bool -> DwarfInfo -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Print a CLabel name in a ".stringz \"LABEL\""-pprLabelString :: Platform -> CLabel -> SDoc+pprLabelString :: IsDoc doc => Platform -> CLabel -> doc pprLabelString platform label =    pprString'                  -- we don't need to escape the string as labels don't contain exotic characters     $ pprCLabel platform label -- pretty-print as C label (foreign labels may be printed differently in Asm)@@ -169,22 +172,22 @@ -- | Prints assembler data corresponding to DWARF info records. Note -- that the binary format of this is parameterized in @abbrevDecls@ and -- has to be kept in synch.-pprDwarfInfoOpen :: Platform -> Bool -> DwarfInfo -> SDoc+pprDwarfInfoOpen :: IsDoc doc => Platform -> Bool -> DwarfInfo -> doc pprDwarfInfoOpen platform haveSrc (DwarfCompileUnit _ name producer compDir lowLabel-                                           highLabel lineLbl) =+                                           highLabel) =   pprAbbrev DwAbbrCompileUnit   $$ pprString name   $$ pprString producer   $$ pprData4 dW_LANG_Haskell   $$ pprString compDir      -- Offset due to Note [Info Offset]-  $$ pprWord platform (lowLabel <> text "-1")-  $$ pprWord platform highLabel+  $$ pprWord platform (pprAsmLabel platform lowLabel <> text "-1")+  $$ pprWord platform (pprAsmLabel platform highLabel)   $$ if haveSrc-     then sectionOffset platform lineLbl dwarfLineLabel+     then sectionOffset platform dwarfLineLabel dwarfLineLabel      else empty pprDwarfInfoOpen platform _ (DwarfSubprogram _ name label parent) =-  pprAsmLabel platform (mkAsmTempDieLabel label) <> colon+  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)   $$ pprAbbrev abbrev   $$ pprString name   $$ pprLabelString platform label@@ -201,11 +204,11 @@     parentValue = maybe empty pprParentDie parent     pprParentDie sym = sectionOffset platform (pprAsmLabel platform sym) dwarfInfoLabel pprDwarfInfoOpen platform _ (DwarfBlock _ label Nothing) =-  pprAsmLabel platform (mkAsmTempDieLabel label) <> colon+  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)   $$ pprAbbrev DwAbbrBlockWithoutCode   $$ pprLabelString platform label pprDwarfInfoOpen platform _ (DwarfBlock _ label (Just marker)) =-  pprAsmLabel platform (mkAsmTempDieLabel label) <> colon+  line (pprAsmLabel platform (mkAsmTempDieLabel label) <> colon)   $$ pprAbbrev DwAbbrBlock   $$ pprLabelString platform label   $$ pprWord platform (pprAsmLabel platform marker)@@ -219,7 +222,7 @@   $$ pprHalf (fromIntegral $ srcSpanEndCol ss)  -- | Close a DWARF info record with children-pprDwarfInfoClose :: SDoc+pprDwarfInfoClose :: IsDoc doc => doc pprDwarfInfoClose = pprAbbrev DwAbbrNull  -- | A DWARF address range. This is used by the debugger to quickly locate@@ -233,7 +236,7 @@  -- | Print assembler directives corresponding to a DWARF @.debug_aranges@ -- address table entry.-pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc+pprDwarfARanges :: IsDoc doc => Platform -> [DwarfARange] -> Unique -> doc pprDwarfARanges platform arngs unitU =   let wordSize = platformWordSizeInBytes platform       paddingSize = 4 :: Int@@ -243,7 +246,7 @@       pad n = vcat $ replicate n $ pprByte 0       -- Fix for #17428       initialLength = 8 + paddingSize + (1 + length arngs) * 2 * wordSize-  in pprDwWord (ppr initialLength)+  in pprDwWord (int initialLength)      $$ pprHalf 2      $$ sectionOffset platform (pprAsmLabel platform $ mkAsmTempLabel $ unitU) dwarfInfoLabel      $$ pprByte (fromIntegral wordSize)@@ -254,8 +257,10 @@      -- terminus      $$ pprWord platform (char '0')      $$ pprWord platform (char '0')+{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> SDoc #-}+{-# SPECIALIZE pprDwarfARanges :: Platform -> [DwarfARange] -> Unique -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprDwarfARange :: Platform -> DwarfARange -> SDoc+pprDwarfARange :: IsDoc doc => Platform -> DwarfARange -> doc pprDwarfARange platform arng =     -- Offset due to Note [Info Offset].     pprWord platform (pprAsmLabel platform (dwArngStartLabel arng) <> text "-1")@@ -299,7 +304,7 @@ -- | Header for the @.debug_frame@ section. Here we emit the "Common -- Information Entry" record that establishes general call frame -- parameters and the default stack layout.-pprDwarfFrame :: Platform -> DwarfFrame -> SDoc+pprDwarfFrame :: forall doc. IsDoc doc => Platform -> DwarfFrame -> doc pprDwarfFrame platform DwarfFrame{dwCieLabel=cieLabel,dwCieInit=cieInit,dwCieProcs=procs}   = let cieStartLabel= mkAsmTempDerivedLabel cieLabel (fsLit "_start")         cieEndLabel = mkAsmTempEndLabel cieLabel@@ -307,7 +312,7 @@         spReg       = dwarfGlobalRegNo platform Sp         retReg      = dwarfReturnRegNo platform         wordSize    = platformWordSizeInBytes platform-        pprInit :: (GlobalReg, Maybe UnwindExpr) -> SDoc+        pprInit :: (GlobalReg, Maybe UnwindExpr) -> doc         pprInit (g, uw) = pprSetUnwind platform g (Nothing, uw)          -- Preserve C stack pointer: This necessary to override that default@@ -316,9 +321,9 @@           ArchX86    -> pprByte dW_CFA_same_value $$ pprLEBWord 4           ArchX86_64 -> pprByte dW_CFA_same_value $$ pprLEBWord 7           _          -> empty-    in vcat [ pprAsmLabel platform cieLabel <> colon+    in vcat [ line (pprAsmLabel platform cieLabel <> colon)             , pprData4' length -- Length of CIE-            , pprAsmLabel platform cieStartLabel <> colon+            , line (pprAsmLabel platform cieStartLabel <> colon)             , pprData4' (text "-1")                                -- Common Information Entry marker (-1 = 0xf..f)             , pprByte 3        -- CIE version (we require DWARF 3)@@ -346,23 +351,25 @@             , pprLEBWord 0             ] $$        wordAlign platform $$-       pprAsmLabel platform cieEndLabel <> colon $$+       line (pprAsmLabel platform cieEndLabel <> colon) $$        -- Procedure unwind tables        vcat (map (pprFrameProc platform cieLabel cieInit) procs)+{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> SDoc #-}+{-# SPECIALIZE pprDwarfFrame :: Platform -> DwarfFrame -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Writes a "Frame Description Entry" for a procedure. This consists -- mainly of referencing the CIE and writing state machine -- instructions to describe how the frame base (CFA) changes.-pprFrameProc :: Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> SDoc+pprFrameProc :: IsDoc doc => Platform -> CLabel -> UnwindTable -> DwarfFrameProc -> doc pprFrameProc platform frameLbl initUw (DwarfFrameProc procLbl hasInfo blocks)   = let fdeLabel    = mkAsmTempDerivedLabel procLbl (fsLit "_fde")         fdeEndLabel = mkAsmTempDerivedLabel procLbl (fsLit "_fde_end")         procEnd     = mkAsmTempProcEndLabel procLbl         ifInfo str  = if hasInfo then text str else empty                       -- see Note [Info Offset]-    in vcat [ whenPprDebug $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon+    in vcat [ whenPprDebug $ line $ text "# Unwinding for" <+> pprAsmLabel platform procLbl <> colon             , pprData4' (pprAsmLabel platform fdeEndLabel <> char '-' <> pprAsmLabel platform fdeLabel)-            , pprAsmLabel platform fdeLabel <> colon+            , line (pprAsmLabel platform fdeLabel <> colon)             , pprData4' (pprAsmLabel platform frameLbl <> char '-' <> dwarfFrameLabel)    -- Reference to CIE             , pprWord platform (pprAsmLabel platform procLbl <> ifInfo "-1") -- Code pointer             , pprWord platform (pprAsmLabel platform procEnd <> char '-' <>@@ -370,17 +377,17 @@             ] $$        vcat (S.evalState (mapM (pprFrameBlock platform) blocks) initUw) $$        wordAlign platform $$-       pprAsmLabel platform fdeEndLabel <> colon+       line (pprAsmLabel platform fdeEndLabel <> colon)  -- | Generates unwind information for a block. We only generate -- instructions where unwind information actually changes. This small -- optimisations saves a lot of space, as subsequent blocks often have -- the same unwind information.-pprFrameBlock :: Platform -> DwarfFrameBlock -> S.State UnwindTable SDoc+pprFrameBlock :: forall doc. IsDoc doc => Platform -> DwarfFrameBlock -> S.State UnwindTable doc pprFrameBlock platform (DwarfFrameBlock hasInfo uws0) =     vcat <$> zipWithM pprFrameDecl (True : repeat False) uws0   where-    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable SDoc+    pprFrameDecl :: Bool -> UnwindPoint -> S.State UnwindTable doc     pprFrameDecl firstDecl (UnwindPoint lbl uws) = S.state $ \oldUws ->         let -- Did a register's unwind expression change?             isChanged :: GlobalReg -> Maybe UnwindExpr@@ -450,12 +457,12 @@ -- | Generate code for setting the unwind information for a register, -- optimized using its known old value in the table. Note that "Sp" is -- special: We see it as synonym for the CFA.-pprSetUnwind :: Platform+pprSetUnwind :: IsDoc doc => Platform              -> GlobalReg                 -- ^ the register to produce an unwinding table entry for              -> (Maybe UnwindExpr, Maybe UnwindExpr)                 -- ^ the old and new values of the register-             -> SDoc+             -> doc pprSetUnwind plat g  (_, Nothing)   = pprUndefUnwind plat g pprSetUnwind _    Sp (Just (UwReg s _), Just (UwReg s' o')) | s == s'@@ -495,13 +502,13 @@  -- | Print the register number of the given 'GlobalReg' as an unsigned LEB128 -- encoded number.-pprLEBRegNo :: Platform -> GlobalReg -> SDoc+pprLEBRegNo :: IsDoc doc => Platform -> GlobalReg -> doc pprLEBRegNo plat = pprLEBWord . fromIntegral . dwarfGlobalRegNo plat  -- | Generates a DWARF expression for the given unwind expression. If -- @spIsCFA@ is true, we see @Sp@ as the frame base CFA where it gets -- mentioned.-pprUnwindExpr :: Platform -> Bool -> UnwindExpr -> SDoc+pprUnwindExpr :: IsDoc doc => Platform -> Bool -> UnwindExpr -> doc pprUnwindExpr platform spIsCFA expr   = let pprE (UwConst i)           | i >= 0 && i < 32 = pprByte (dW_OP_lit0 + fromIntegral i)@@ -517,84 +524,100 @@         pprE (UwPlus u1 u2)   = pprE u1 $$ pprE u2 $$ pprByte dW_OP_plus         pprE (UwMinus u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_minus         pprE (UwTimes u1 u2)  = pprE u1 $$ pprE u2 $$ pprByte dW_OP_mul-    in text "\t.uleb128 2f-1f" $$ -- DW_FORM_block length+    in line (text "\t.uleb128 2f-1f") $$ -- DW_FORM_block length        -- computed as the difference of the following local labels 2: and 1:-       text "1:" $$+       line (text "1:") $$        pprE expr $$-       text "2:"+       line (text "2:")  -- | Generate code for re-setting the unwind information for a -- register to @undefined@-pprUndefUnwind :: Platform -> GlobalReg -> SDoc+pprUndefUnwind :: IsDoc doc => Platform -> GlobalReg -> doc pprUndefUnwind plat g  = pprByte dW_CFA_undefined $$                          pprLEBRegNo plat g   -- | Align assembly at (machine) word boundary-wordAlign :: Platform -> SDoc+wordAlign :: IsDoc doc => Platform -> doc wordAlign plat =-  text "\t.align " <> case platformOS plat of+  line $ text "\t.align " <> case platformOS plat of     OSDarwin -> case platformWordSize plat of       PW8 -> char '3'       PW4 -> char '2'-    _other   -> ppr (platformWordSizeInBytes plat)+    _other   -> int (platformWordSizeInBytes plat)+{-# SPECIALIZE wordAlign :: Platform -> SDoc #-}+{-# SPECIALIZE wordAlign :: Platform -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Assembly for a single byte of constant DWARF data-pprByte :: Word8 -> SDoc-pprByte x = text "\t.byte " <> ppr (fromIntegral x :: Word)+pprByte :: IsDoc doc => Word8 -> doc+pprByte x = line $ text "\t.byte " <> integer (fromIntegral x)+{-# SPECIALIZE pprByte :: Word8 -> SDoc #-}+{-# SPECIALIZE pprByte :: Word8 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Assembly for a two-byte constant integer-pprHalf :: Word16 -> SDoc-pprHalf x = text "\t.short" <+> ppr (fromIntegral x :: Word)+pprHalf :: IsDoc doc => Word16 -> doc+pprHalf x = line $ text "\t.short" <+> integer (fromIntegral x)+{-# SPECIALIZE pprHalf :: Word16 -> SDoc #-}+{-# SPECIALIZE pprHalf :: Word16 -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Assembly for a constant DWARF flag-pprFlag :: Bool -> SDoc+pprFlag :: IsDoc doc => Bool -> doc pprFlag f = pprByte (if f then 0xff else 0x00)  -- | Assembly for 4 bytes of dynamic DWARF data-pprData4' :: SDoc -> SDoc-pprData4' x = text "\t.long " <> x+pprData4' :: IsDoc doc => Line doc -> doc+pprData4' x = line (text "\t.long " <> x)+{-# SPECIALIZE pprData4' :: SDoc -> SDoc #-}+{-# SPECIALIZE pprData4' :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Assembly for 4 bytes of constant DWARF data-pprData4 :: Word -> SDoc-pprData4 = pprData4' . ppr+pprData4 :: IsDoc doc => Word -> doc+pprData4 = pprData4' . integer . fromIntegral  -- | Assembly for a DWARF word of dynamic data. This means 32 bit, as -- we are generating 32 bit DWARF.-pprDwWord :: SDoc -> SDoc+pprDwWord :: IsDoc doc => Line doc -> doc pprDwWord = pprData4'+{-# SPECIALIZE pprDwWord :: SDoc -> SDoc #-}+{-# SPECIALIZE pprDwWord :: HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Assembly for a machine word of dynamic data. Depends on the -- architecture we are currently generating code for.-pprWord :: Platform -> SDoc -> SDoc+pprWord :: IsDoc doc => Platform -> Line doc -> doc pprWord plat s =-  case platformWordSize plat of+  line $ case platformWordSize plat of     PW4 -> text "\t.long " <> s     PW8 -> text "\t.quad " <> s+{-# SPECIALIZE pprWord :: Platform -> SDoc -> SDoc #-}+{-# SPECIALIZE pprWord :: Platform -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Prints a number in "little endian base 128" format. The idea is -- to optimize for small numbers by stopping once all further bytes -- would be 0. The highest bit in every byte signals whether there -- are further bytes to read.-pprLEBWord :: Word -> SDoc+pprLEBWord :: IsDoc doc => Word -> doc pprLEBWord x | x < 128   = pprByte (fromIntegral x)              | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$                            pprLEBWord (x `shiftR` 7)+{-# SPECIALIZE pprLEBWord :: Word -> SDoc #-}+{-# SPECIALIZE pprLEBWord :: Word -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Same as @pprLEBWord@, but for a signed number-pprLEBInt :: Int -> SDoc+pprLEBInt :: IsDoc doc => Int -> doc pprLEBInt x | x >= -64 && x < 64                         = pprByte (fromIntegral (x .&. 127))             | otherwise = pprByte (fromIntegral $ 128 .|. (x .&. 127)) $$                           pprLEBInt (x `shiftR` 7)+{-# SPECIALIZE pprLEBInt :: Int -> SDoc #-}+{-# SPECIALIZE pprLEBInt :: Int -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Generates a dynamic null-terminated string. If required the -- caller needs to make sure that the string is escaped properly.-pprString' :: SDoc -> SDoc-pprString' str = text "\t.asciz \"" <> str <> char '"'+pprString' :: IsDoc doc => Line doc -> doc+pprString' str = line (text "\t.asciz \"" <> str <> char '"')  -- | Generate a string constant. We take care to escape the string.-pprString :: String -> SDoc+pprString :: IsDoc doc => String -> doc pprString str   = pprString' $ hcat $ map escapeChar $     if str `lengthIs` utf8EncodedLength str@@ -602,7 +625,7 @@     else map (chr . fromIntegral) $ BS.unpack $ utf8EncodeByteString str  -- | Escape a single non-unicode character-escapeChar :: Char -> SDoc+escapeChar :: IsLine doc => Char -> doc escapeChar '\\' = text "\\\\" escapeChar '\"' = text "\\\"" escapeChar '\n' = text "\\n"@@ -621,9 +644,11 @@ -- us to just reference the target directly, and will figure out on -- their own that we actually need an offset. Finally, Windows has -- a special directive to refer to relative offsets. Fun.-sectionOffset :: Platform -> SDoc -> SDoc -> SDoc+sectionOffset :: IsDoc doc => Platform -> Line doc -> Line doc -> doc sectionOffset plat target section =   case platformOS plat of     OSDarwin  -> pprDwWord (target <> char '-' <> section)-    OSMinGW32 -> text "\t.secrel32 " <> target+    OSMinGW32 -> line (text "\t.secrel32 " <> target)     _other    -> pprDwWord target+{-# SPECIALIZE sectionOffset :: Platform -> SDoc -> SDoc -> SDoc #-}+{-# SPECIALIZE sectionOffset :: Platform -> HLine -> HLine -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable

@@ -15,6 +15,7 @@ import GHC.Cmm.BlockId  import GHC.CmmToAsm.Config+import GHC.Data.FastString  -- | Holds a list of source and destination registers used by a --      particular instruction.@@ -160,4 +161,4 @@         pprInstr :: Platform -> instr -> SDoc          -- Create a comment instruction-        mkComment :: SDoc -> [instr]+        mkComment :: FastString -> [instr]

@@ -67,7 +67,7 @@ import GHC.Types.Unique         ( Unique ) import GHC.Unit.Module -import GHC.Utils.Outputable (SDoc, ppr)+import GHC.Utils.Outputable (SDoc, HDoc, ppr) import GHC.Utils.Panic      (pprPanic) import GHC.Utils.Monad.State.Strict (State (..), runState, state) import GHC.Utils.Misc@@ -84,7 +84,9 @@     shortcutJump              :: (BlockId -> Maybe jumpDest) -> instr -> instr,     -- | 'Module' is only for printing internal labels. See Note [Internal proc     -- labels] in CLabel.-    pprNatCmmDecl             :: NatCmmDecl statics instr -> SDoc,+    pprNatCmmDeclS            :: NatCmmDecl statics instr -> SDoc,+    pprNatCmmDeclH            :: NatCmmDecl statics instr -> HDoc,+        -- see Note [pprNatCmmDeclS and pprNatCmmDeclH]     maxSpillSlots             :: Int,     allocatableRegs           :: [RealReg],     ncgAllocMoreStack         :: Int -> NatCmmDecl statics instr@@ -102,6 +104,38 @@     -- ^ Turn the sequence of @jcc l1; jmp l2@ into @jncc l2; \<block_l1>@     -- when possible.     }++{- Note [pprNatCmmDeclS and pprNatCmmDeclH]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~+Each NcgImpl provides two implementations of its CmmDecl printer, pprNatCmmDeclS+and pprNatCmmDeclH, which are specialized to SDoc and HDoc, respectively+(see Note [SDoc versus HDoc] in GHC.Utils.Outputable). These are both internally+implemented as a single, polymorphic function, but they need to be stored using+monomorphic types to ensure the specialized versions are used, which is+essential for performance (see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable).++One might wonder why we bother with pprNatCmmDeclS and SDoc at all, since we+have a perfectly serviceable HDoc-based implementation that is more efficient.+However, it turns out we benefit from keeping both, for two (related) reasons:++  1. Although we absolutely want to take care to use pprNatCmmDeclH for actual+     code generation (the improved performance there is why we have HDoc at+     all!), we also sometimes print assembly for debug dumps, when requested via+     -ddump-asm. In this case, it’s more convenient to produce an SDoc, which+     can be concatenated with other SDocs for consistency with the general-+     purpose dump file infrastructure.++  2. Some debug information is sometimes useful to include in -ddump-asm that is+     neither necessary nor useful in normal code generation, and it turns out to+     be tricky to format neatly using the one-line-at-a-time model of HLine/HDoc.++Therefore, we provide both pprNatCmmDeclS and pprNatCmmDeclH, and we sometimes+include additional information in the SDoc variant using dualDoc+(see Note [dualLine and dualDoc] in GHC.Utils.Outputable). However, it is+absolutely *critical* that pprNatCmmDeclS is not actually used unless -ddump-asm+is provided, as that would rather defeat the whole point. (Fortunately, the+difference in allocations between the two implementations is so vast that such a+mistake would readily show up in performance tests). -}  data NatM_State         = NatM_State {

@@ -532,11 +532,11 @@ -- -- We don't need to declare any offset tables. -- However, for PIC on x86, we need a small helper function.-pprGotDeclaration :: NCGConfig -> SDoc+pprGotDeclaration :: NCGConfig -> HDoc pprGotDeclaration config = case (arch,os) of    (ArchX86, OSDarwin)         | ncgPIC config-        -> vcat [+        -> lines_ [                 text ".section __TEXT,__textcoal_nt,coalesced,no_toc",                 text ".weak_definition ___i686.get_pc_thunk.ax",                 text ".private_extern ___i686.get_pc_thunk.ax",@@ -548,7 +548,7 @@     -- Emit XCOFF TOC section    (_, OSAIX)-        -> vcat $ [ text ".toc"+        -> lines_ [ text ".toc"                   , text ".tc ghc_toc_table[TC],.LCTOC1"                   , text ".csect ghc_toc_table[RW]"                     -- See Note [.LCTOC1 in PPC PIC code]@@ -558,16 +558,16 @@     -- PPC 64 ELF v1 needs a Table Of Contents (TOC)    (ArchPPC_64 ELF_V1, _)-        -> text ".section \".toc\",\"aw\""+        -> line $ text ".section \".toc\",\"aw\""     -- In ELF v2 we also need to tell the assembler that we want ABI    -- version 2. This would normally be done at the top of the file    -- right after a file directive, but I could not figure out how    -- to do that.    (ArchPPC_64 ELF_V2, _)-        -> vcat [ text ".abiversion 2",-                  text ".section \".toc\",\"aw\""-                ]+        -> lines_ [ text ".abiversion 2",+                    text ".section \".toc\",\"aw\""+                  ]     (arch, os)         | osElfTarget os@@ -577,7 +577,7 @@          | osElfTarget os         , arch /= ArchPPC_64 ELF_V1 && arch /= ArchPPC_64 ELF_V2-        -> vcat [+        -> lines_ [                 -- See Note [.LCTOC1 in PPC PIC code]                 text ".section \".got2\",\"aw\"",                 text ".LCTOC1 = .+32768" ]@@ -595,13 +595,13 @@ -- and one for non-PIC. -- -pprImportedSymbol :: NCGConfig -> CLabel -> SDoc+pprImportedSymbol :: NCGConfig -> CLabel -> HDoc pprImportedSymbol config importedLbl = case (arch,os) of    (ArchX86, OSDarwin)         | Just (CodeStub, lbl) <- dynamicLinkerLabelInfo importedLbl         -> if not pic              then-              vcat [+              lines_ [                   text ".symbol_stub",                   text "L" <> ppr_lbl lbl <> text "$stub:",                       text "\t.indirect_symbol" <+> ppr_lbl lbl,@@ -614,7 +614,7 @@                       text "\tjmp dyld_stub_binding_helper"               ]              else-              vcat [+              lines_ [                   text ".section __TEXT,__picsymbolstub2,"                       <> text "symbol_stubs,pure_instructions,25",                   text "L" <> ppr_lbl lbl <> text "$stub:",@@ -631,7 +631,8 @@                       text "\tpushl %eax",                       text "\tjmp dyld_stub_binding_helper"               ]-           $+$ vcat [        text ".section __DATA, __la_sym_ptr"+           $$ lines_ [+                text ".section __DATA, __la_sym_ptr"                     <> (if pic then int 2 else int 3)                     <> text ",lazy_symbol_pointers",                 text "L" <> ppr_lbl lbl <> text "$lazy_ptr:",@@ -640,7 +641,7 @@                     <> text "$stub_binder"]          | Just (SymbolPtr, lbl) <- dynamicLinkerLabelInfo importedLbl-        -> vcat [+        -> lines_ [                 text ".non_lazy_symbol_pointer",                 char 'L' <> ppr_lbl lbl <> text "$non_lazy_ptr:",                 text "\t.indirect_symbol" <+> ppr_lbl lbl,@@ -667,7 +668,7 @@     (_, OSAIX) -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)-              -> vcat [+              -> lines_ [                    text "LC.." <> ppr_lbl lbl <> char ':',                    text "\t.long" <+> ppr_lbl lbl ]             _ -> empty@@ -705,7 +706,7 @@         | osElfTarget os         -> case dynamicLinkerLabelInfo importedLbl of             Just (SymbolPtr, lbl)-              -> vcat [+              -> lines_ [                    text ".LC_" <> ppr_lbl lbl <> char ':',                    text "\t.quad" <+> ppr_lbl lbl ]             _ -> empty@@ -718,7 +719,7 @@                          W64 -> text "\t.quad"                          _ -> panic "Unknown wordRep in pprImportedSymbol" -                 in vcat [+                 in lines_ [                       text ".section \".got2\", \"aw\"",                       text ".LC_" <> ppr_lbl lbl <> char ':',                       symbolSize <+> ppr_lbl lbl ]@@ -729,6 +730,7 @@    _ -> panic "PIC.pprImportedSymbol: no match"  where    platform = ncgPlatform config+   ppr_lbl :: CLabel -> HLine    ppr_lbl  = pprAsmLabel   platform    arch     = platformArch  platform    os       = platformOS    platform

@@ -28,7 +28,8 @@    , canShortcut               = PPC.canShortcut    , shortcutStatics           = PPC.shortcutStatics    , shortcutJump              = PPC.shortcutJump-   , pprNatCmmDecl             = PPC.pprNatCmmDecl config+   , pprNatCmmDeclH            = PPC.pprNatCmmDecl config+   , pprNatCmmDeclS            = PPC.pprNatCmmDecl config    , maxSpillSlots             = PPC.maxSpillSlots config    , allocatableRegs           = PPC.allocatableRegs platform    , ncgAllocMoreStack         = PPC.allocMoreStack platform

@@ -162,7 +162,7 @@   config <- getConfig   platform <- getPlatform   case stmt of-    CmmComment s   -> return (unitOL (COMMENT $ ftext s))+    CmmComment s   -> return (unitOL (COMMENT s))     CmmTick {}     -> return nilOL     CmmUnwind {}   -> return nilOL @@ -407,7 +407,7 @@ getRegister' _ platform (CmmReg (CmmGlobal PicBaseReg))   | OSAIX <- platformOS platform = do         let code dst = toOL [ LD II32 dst tocAddr ]-            tocAddr = AddrRegImm toc (ImmLit "ghc_toc_table[TC]")+            tocAddr = AddrRegImm toc (ImmLit (fsLit "ghc_toc_table[TC]"))         return (Any II32 code)   | target32Bit platform = do       reg <- getPicBaseNat $ archWordFormat (target32Bit platform)

@@ -52,7 +52,6 @@ import GHC.Cmm import GHC.Cmm.Info import GHC.Cmm.CLabel-import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Platform import GHC.Types.Unique.FM (listToUFM, lookupUFM)@@ -60,6 +59,7 @@  import Data.Foldable (toList) import qualified Data.List.NonEmpty as NE+import GHC.Data.FastString (FastString) import Data.Maybe (fromMaybe)  @@ -179,7 +179,7 @@  data Instr     -- comment pseudo-op-    = COMMENT SDoc+    = COMMENT FastString      -- location pseudo-op (file, line, col, name)     | LOCATION Int Int Int String

@@ -46,7 +46,7 @@ -- ----------------------------------------------------------------------------- -- Printing this stuff out -pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc+pprNatCmmDecl :: IsDoc doc => NCGConfig -> NatCmmDecl RawCmmStatics Instr -> doc pprNatCmmDecl config (CmmData section dats) =   pprSectionAlign config section   $$ pprDatas (ncgPlatform config) dats@@ -63,15 +63,15 @@             _ -> pprLabel platform lbl) $$ -- blocks guaranteed not null,                                            -- so label needed          vcat (map (pprBasicBlock config top_info) blocks) $$-         ppWhen (ncgDwarfEnabled config) (pprAsmLabel platform (mkAsmTempEndLabel lbl)-                                          <> char ':' $$-                                          pprProcEndLabel platform lbl) $$+         ppWhen (ncgDwarfEnabled config) (line (pprAsmLabel platform (mkAsmTempEndLabel lbl)+                                                <> char ':') $$+                                          line (pprProcEndLabel platform lbl)) $$          pprSizeDecl platform lbl      Just (CmmStaticsRaw info_lbl _) ->       pprSectionAlign config (Section Text info_lbl) $$       (if platformHasSubsectionsViaSymbols platform-          then pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':'+          then line (pprAsmLabel platform (mkDeadStripPreventer info_lbl) <> char ':')           else empty) $$       vcat (map (pprBasicBlock config top_info) blocks) $$       -- above: Even the first block gets a label, because with branch-chain@@ -79,18 +79,20 @@       (if platformHasSubsectionsViaSymbols platform        then        -- See Note [Subsections Via Symbols] in X86/Ppr.hs-                text "\t.long "-            <+> pprAsmLabel platform info_lbl-            <+> char '-'-            <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl)+                line (text "\t.long "+                      <+> pprAsmLabel platform info_lbl+                      <+> char '-'+                      <+> pprAsmLabel platform (mkDeadStripPreventer info_lbl))        else empty) $$       pprSizeDecl platform info_lbl+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> SDoc #-}+{-# SPECIALIZE pprNatCmmDecl :: NCGConfig -> NatCmmDecl RawCmmStatics Instr -> HDoc #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Output the ELF .size directive.-pprSizeDecl :: Platform -> CLabel -> SDoc+pprSizeDecl :: IsDoc doc => Platform -> CLabel -> doc pprSizeDecl platform lbl  = if osElfTarget (platformOS platform)-   then text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl+   then line (text "\t.size" <+> prettyLbl <> text ", .-" <> codeLbl)    else empty   where     prettyLbl = pprAsmLabel platform lbl@@ -98,47 +100,45 @@       | platformArch platform == ArchPPC_64 ELF_V1 = char '.' <> prettyLbl       | otherwise                                  = prettyLbl -pprFunctionDescriptor :: Platform -> CLabel -> SDoc-pprFunctionDescriptor platform lab = pprGloblDecl platform lab-                        $$  text "\t.section \".opd\", \"aw\""-                        $$  text "\t.align 3"-                        $$  pprAsmLabel platform lab <> char ':'-                        $$  text "\t.quad ."-                        <>  pprAsmLabel platform lab-                        <>  text ",.TOC.@tocbase,0"-                        $$  text "\t.previous"-                        $$  text "\t.type"-                        <+> pprAsmLabel platform lab-                        <>  text ", @function"-                        $$  char '.' <> pprAsmLabel platform lab <> char ':'+pprFunctionDescriptor :: IsDoc doc => Platform -> CLabel -> doc+pprFunctionDescriptor platform lab =+  vcat [pprGloblDecl platform lab,+        line (text "\t.section \".opd\", \"aw\""),+        line (text "\t.align 3"),+        line (pprAsmLabel platform lab <> char ':'),+        line (text "\t.quad ."+              <>  pprAsmLabel platform lab+              <>  text ",.TOC.@tocbase,0"),+        line (text "\t.previous"),+        line (text "\t.type"+              <+> pprAsmLabel platform lab+              <>  text ", @function"),+        line (char '.' <> pprAsmLabel platform lab <> char ':')] -pprFunctionPrologue :: Platform -> CLabel ->SDoc-pprFunctionPrologue platform lab =  pprGloblDecl platform lab-                        $$  text ".type "-                        <> pprAsmLabel platform lab-                        <> text ", @function"-                        $$ pprAsmLabel platform lab <> char ':'-                        $$ text "0:\taddis\t" <> pprReg toc-                        <> text ",12,.TOC.-0b@ha"-                        $$ text "\taddi\t" <> pprReg toc-                        <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"-                        $$ text "\t.localentry\t" <> pprAsmLabel platform lab-                        <> text ",.-" <> pprAsmLabel platform lab+pprFunctionPrologue :: IsDoc doc => Platform -> CLabel -> doc+pprFunctionPrologue platform lab =+  vcat [pprGloblDecl platform lab,+        line (text ".type " <> pprAsmLabel platform lab <> text ", @function"),+        line (pprAsmLabel platform lab <> char ':'),+        line (text "0:\taddis\t" <> pprReg toc <> text ",12,.TOC.-0b@ha"),+        line (text "\taddi\t" <> pprReg toc <> char ',' <> pprReg toc <> text ",.TOC.-0b@l"),+        line (text "\t.localentry\t" <> pprAsmLabel platform lab <>+              text ",.-" <> pprAsmLabel platform lab)] -pprProcEndLabel :: Platform -> CLabel -- ^ Procedure name-                -> SDoc+pprProcEndLabel :: IsLine doc => Platform -> CLabel -- ^ Procedure name+                -> doc pprProcEndLabel platform lbl =     pprAsmLabel platform (mkAsmTempProcEndLabel lbl) <> char ':' -pprBasicBlock :: NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr-              -> SDoc+pprBasicBlock :: IsDoc doc => NCGConfig -> LabelMap RawCmmStatics -> NatBasicBlock Instr+              -> doc pprBasicBlock config info_env (BasicBlock blockid instrs)   = maybe_infotable $$     pprLabel platform asmLbl $$     vcat (map (pprInstr platform) instrs) $$     ppWhen (ncgDwarfEnabled config) (-      pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'-      <> pprProcEndLabel platform asmLbl+      line (pprAsmLabel platform (mkAsmTempEndLabel asmLbl) <> char ':'+            <> pprProcEndLabel platform asmLbl)     )   where     asmLbl = blockLbl blockid@@ -152,7 +152,7 @@   -pprDatas :: Platform -> RawCmmStatics -> SDoc+pprDatas :: IsDoc doc => Platform -> RawCmmStatics -> doc -- See Note [emit-time elimination of static indirections] in "GHC.Cmm.CLabel". pprDatas platform (CmmStaticsRaw alias [CmmStaticLit (CmmLabel lbl), CmmStaticLit ind, _, _])   | lbl == mkIndStaticInfoLabel@@ -162,38 +162,38 @@   , Just ind' <- labelInd ind   , alias `mayRedirectTo` ind'   = pprGloblDecl platform alias-    $$ text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind'+    $$ line (text ".equiv" <+> pprAsmLabel platform alias <> comma <> pprAsmLabel platform ind') pprDatas platform (CmmStaticsRaw lbl dats) = vcat (pprLabel platform lbl : map (pprData platform) dats) -pprData :: Platform -> CmmStatic -> SDoc+pprData :: IsDoc doc => Platform -> CmmStatic -> doc pprData platform d = case d of-   CmmString str          -> pprString str-   CmmFileEmbed path      -> pprFileEmbed path-   CmmUninitialised bytes -> text ".space " <> int bytes+   CmmString str          -> line (pprString str)+   CmmFileEmbed path _    -> line (pprFileEmbed path)+   CmmUninitialised bytes -> line (text ".space " <> int bytes)    CmmStaticLit lit       -> pprDataItem platform lit -pprGloblDecl :: Platform -> CLabel -> SDoc+pprGloblDecl :: IsDoc doc => Platform -> CLabel -> doc pprGloblDecl platform lbl   | not (externallyVisibleCLabel lbl) = empty-  | otherwise = text ".globl " <> pprAsmLabel platform lbl+  | otherwise = line (text ".globl " <> pprAsmLabel platform lbl) -pprTypeAndSizeDecl :: Platform -> CLabel -> SDoc+pprTypeAndSizeDecl :: IsLine doc => Platform -> CLabel -> doc pprTypeAndSizeDecl platform lbl   = if platformOS platform == OSLinux && externallyVisibleCLabel lbl     then text ".type " <>          pprAsmLabel platform lbl <> text ", @object"     else empty -pprLabel :: Platform -> CLabel -> SDoc+pprLabel :: IsDoc doc => Platform -> CLabel -> doc pprLabel platform lbl =    pprGloblDecl platform lbl-   $$ pprTypeAndSizeDecl platform lbl-   $$ (pprAsmLabel platform lbl <> char ':')+   $$ line (pprTypeAndSizeDecl platform lbl)+   $$ line (pprAsmLabel platform lbl <> char ':')  -- ----------------------------------------------------------------------------- -- pprInstr: print an 'Instr' -pprReg :: Reg -> SDoc+pprReg :: forall doc. IsLine doc => Reg -> doc  pprReg r   = case r of@@ -204,7 +204,7 @@       RegVirtual (VirtualRegD  u)  -> text "%vD_"   <> pprUniqueAlways u    where-    ppr_reg_no :: Int -> SDoc+    ppr_reg_no :: Int -> doc     ppr_reg_no i          | i <= 31   = int i      -- GPRs          | i <= 63   = int (i-32) -- FPRs@@ -212,7 +212,7 @@   -pprFormat :: Format -> SDoc+pprFormat :: IsLine doc => Format -> doc pprFormat x  = case x of                 II8  -> text "b"@@ -223,7 +223,7 @@                 FF64 -> text "fd"  -pprCond :: Cond -> SDoc+pprCond :: IsLine doc => Cond -> doc pprCond c  = case c of {                 ALWAYS  -> text "";@@ -234,13 +234,13 @@                 GU      -> text "gt";  LEU   -> text "le"; }  -pprImm :: Platform -> Imm -> SDoc+pprImm :: IsLine doc => Platform -> Imm -> doc pprImm platform = \case    ImmInt i       -> int i    ImmInteger i   -> integer i    ImmCLbl l      -> pprAsmLabel platform l    ImmIndex l i   -> pprAsmLabel platform l <> char '+' <> int i-   ImmLit s       -> text s+   ImmLit s       -> ftext s    ImmFloat f     -> float $ fromRational f    ImmDouble d    -> double $ fromRational d    ImmConstantSum a b   -> pprImm platform a <> char '+' <> pprImm platform b@@ -264,7 +264,7 @@    HIGHESTA i  -> pprImm platform i <> text "@highesta"  -pprAddr :: Platform -> AddrMode -> SDoc+pprAddr :: IsLine doc => Platform -> AddrMode -> doc pprAddr platform = \case    AddrRegReg r1 r2             -> pprReg r1 <> char ',' <+> pprReg r2    AddrRegImm r1 (ImmInt i)     -> hcat [ int i, char '(', pprReg r1, char ')' ]@@ -272,14 +272,14 @@    AddrRegImm r1 imm            -> hcat [ pprImm platform imm, char '(', pprReg r1, char ')' ]  -pprSectionAlign :: NCGConfig -> Section -> SDoc+pprSectionAlign :: IsDoc doc => NCGConfig -> Section -> doc pprSectionAlign config sec@(Section seg _) =-   pprSectionHeader config sec $$+   line (pprSectionHeader config sec) $$    pprAlignForSection (ncgPlatform config) seg  -- | Print appropriate alignment for the given section type.-pprAlignForSection :: Platform -> SectionType -> SDoc-pprAlignForSection platform seg =+pprAlignForSection :: IsDoc doc => Platform -> SectionType -> doc+pprAlignForSection platform seg = line $  let ppc64    = not $ target32Bit platform  in case seg of        Text              -> text ".align 2"@@ -304,9 +304,9 @@         | otherwise      -> text ".align 2"        OtherSection _    -> panic "PprMach.pprSectionAlign: unknown section" -pprDataItem :: Platform -> CmmLit -> SDoc+pprDataItem :: IsDoc doc => Platform -> CmmLit -> doc pprDataItem platform lit-  = vcat (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)+  = lines_ (ppr_item (cmmTypeFormat $ cmmLitType platform lit) lit)     where         imm = litToImm lit         archPPC_64 = not $ target32Bit platform@@ -333,21 +333,21 @@                 = panic "PPC.Ppr.pprDataItem: no match"  -asmComment :: SDoc -> SDoc+asmComment :: IsLine doc => doc -> doc asmComment c = whenPprDebug $ text "#" <+> c  -pprInstr :: Platform -> Instr -> SDoc+pprInstr :: IsDoc doc => Platform -> Instr -> doc pprInstr platform instr = case instr of     COMMENT s-      -> asmComment s+      -> line (asmComment (ftext s)) -   LOCATION file line col _name-      -> text "\t.loc" <+> ppr file <+> ppr line <+> ppr col+   LOCATION file line' col _name+      -> line (text "\t.loc" <+> int file <+> int line' <+> int col)     DELTA d-      -> asmComment $ text ("\tdelta = " ++ show d)+      -> line (asmComment $ text ("\tdelta = " ++ show d))     NEWBLOCK _       -> panic "PprMach.pprInstr: NEWBLOCK"@@ -374,7 +374,7 @@ -}     LD fmt reg addr-      -> hcat [+      -> line $ hcat [            char '\t',            text "l",            (case fmt of@@ -403,7 +403,7 @@       -> panic "PPC.Ppr.pprInstr LDFAR: no match"     LDR fmt reg1 addr-      -> hcat [+      -> line $ hcat [            text "\tl",            case fmt of              II32 -> char 'w'@@ -416,7 +416,7 @@            ]     LA fmt reg addr-      -> hcat [+      -> line $ hcat [            char '\t',            text "l",            (case fmt of@@ -436,7 +436,7 @@            ]     ST fmt reg addr-      -> hcat [+      -> line $ hcat [            char '\t',            text "st",            pprFormat fmt,@@ -457,7 +457,7 @@       -> panic "PPC.Ppr.pprInstr STFAR: no match"     STU fmt reg addr-      -> hcat [+      -> line $ hcat [            char '\t',            text "st",            pprFormat fmt,@@ -471,7 +471,7 @@            ]     STC fmt reg1 addr-      -> hcat [+      -> line $ hcat [            text "\tst",            case fmt of              II32 -> char 'w'@@ -484,7 +484,7 @@            ]     LIS reg imm-      -> hcat [+      -> line $ hcat [            char '\t',            text "lis",            char '\t',@@ -494,7 +494,7 @@            ]     LI reg imm-      -> hcat [+      -> line $ hcat [            char '\t',            text "li",            char '\t',@@ -505,7 +505,7 @@     MR reg1 reg2     | reg1 == reg2 -> empty-    | otherwise    -> hcat [+    | otherwise    -> line $ hcat [         char '\t',         case targetClassOfReg platform reg1 of             RcInteger -> text "mr"@@ -517,7 +517,7 @@         ]     CMP fmt reg ri-      -> hcat [+      -> line $ hcat [            char '\t',            op,            char '\t',@@ -535,7 +535,7 @@                ]     CMPL fmt reg ri-      -> hcat [+      -> line $ hcat [            char '\t',            op,            char '\t',@@ -553,7 +553,7 @@                   ]     BCC cond blockid prediction-      -> hcat [+      -> line $ hcat [            char '\t',            text "b",            pprCond cond,@@ -568,7 +568,7 @@                  Just False -> char '-'     BCCFAR cond blockid prediction-      -> vcat [+      -> lines_ [            hcat [                text "\tb",                pprCond (condNegate cond),@@ -590,15 +590,13 @@      -- We never jump to ForeignLabels; if we ever do, c.f. handling for "BL"      | isForeignLabel lbl -> panic "PPC.Ppr.pprInstr: JMP to ForeignLabel"      | otherwise ->-       hcat [ -- an alias for b that takes a CLabel-           char '\t',-           text "b",-           char '\t',+       line $ hcat [ -- an alias for b that takes a CLabel+           text "\tb\t",            pprAsmLabel platform lbl        ]     MTCTR reg-      -> hcat [+      -> line $ hcat [            char '\t',            text "mtctr",            char '\t',@@ -606,7 +604,7 @@         ]     BCTR _ _ _-      -> hcat [+      -> line $ hcat [            char '\t',            text "bctr"          ]@@ -623,18 +621,18 @@              -- but when profiling the codegen inserts calls via              -- 'emitRtsCallGen' which are 'CmmLabel's even though              -- they'd technically be more like 'ForeignLabel's.-             hcat [+             line $ hcat [                text "\tbl\t.",                pprAsmLabel platform lbl              ]            _ ->-             hcat [+             line $ hcat [                text "\tbl\t",                pprAsmLabel platform lbl              ]     BCTRL _-      -> hcat [+      -> line $ hcat [              char '\t',              text "bctrl"          ]@@ -643,7 +641,7 @@       -> pprLogic platform (text "add") reg1 reg2 ri     ADDIS reg1 reg2 imm-      -> hcat [+      -> line $ hcat [            char '\t',            text "addis",            char '\t',@@ -673,7 +671,7 @@       -> pprLogic platform (text "subfo") reg1 reg2 (RIReg reg3)     SUBFC reg1 reg2 ri-      -> hcat [+      -> line $ hcat [            char '\t',            text "subf",            case ri of@@ -694,7 +692,7 @@       -> pprMul platform fmt reg1 reg2 ri     MULLO fmt reg1 reg2 reg3-      -> hcat [+      -> line $ hcat [              char '\t',              text "mull",              case fmt of@@ -711,13 +709,13 @@     MFOV fmt reg       -> vcat [-           hcat [+           line $ hcat [                char '\t',                text "mfxer",                char '\t',                pprReg reg                ],-           hcat [+           line $ hcat [                char '\t',                text "extr",                case fmt of@@ -737,7 +735,7 @@            ]     MULHU fmt reg1 reg2 reg3-      -> hcat [+      -> line $ hcat [             char '\t',             text "mulh",             case fmt of@@ -758,7 +756,7 @@         -- for some reason, "andi" doesn't exist.         -- we'll use "andi." instead.    AND reg1 reg2 (RIImm imm)-      -> hcat [+      -> line $ hcat [             char '\t',             text "andi.",             char '\t',@@ -785,7 +783,7 @@       -> pprLogic platform (text "xor") reg1 reg2 ri     ORIS reg1 reg2 imm-      -> hcat [+      -> line $ hcat [             char '\t',             text "oris",             char '\t',@@ -797,7 +795,7 @@         ]     XORIS reg1 reg2 imm-      -> hcat [+      -> line $ hcat [             char '\t',             text "xoris",             char '\t',@@ -809,7 +807,7 @@         ]     EXTS fmt reg1 reg2-      -> hcat [+      -> line $ hcat [            char '\t',            text "exts",            pprFormat fmt,@@ -820,7 +818,7 @@          ]     CNTLZ fmt reg1 reg2-      -> hcat [+      -> line $ hcat [            char '\t',            text "cntlz",            case fmt of@@ -881,7 +879,7 @@          in pprLogic platform op reg1 reg2 (limitShiftRI fmt ri)     RLWINM reg1 reg2 sh mb me-      -> hcat [+      -> line $ hcat [              text "\trlwinm\t",              pprReg reg1,              text ", ",@@ -895,7 +893,7 @@          ]     CLRLI fmt reg1 reg2 n-      -> hcat [+      -> line $ hcat [             text "\tclrl",             pprFormat fmt,             text "i ",@@ -907,7 +905,7 @@         ]     CLRRI fmt reg1 reg2 n-      -> hcat [+      -> line $ hcat [             text "\tclrr",             pprFormat fmt,             text "i ",@@ -937,7 +935,7 @@       -> pprUnary (text "fneg") reg1 reg2     FCMP reg1 reg2-      -> hcat [+      -> line $ hcat [            char '\t',            text "fcmpu\t0, ",                -- Note: we're using fcmpu, not fcmpo@@ -965,7 +963,7 @@       -> pprUnary (text "frsp") reg1 reg2     CRNOR dst src1 src2-      -> hcat [+      -> line $ hcat [            text "\tcrnor\t",            int dst,            text ", ",@@ -975,7 +973,7 @@          ]     MFCR reg-      -> hcat [+      -> line $ hcat [              char '\t',              text "mfcr",              char '\t',@@ -983,7 +981,7 @@          ]     MFLR reg-      -> hcat [+      -> line $ hcat [            char '\t',            text "mflr",            char '\t',@@ -991,25 +989,25 @@          ]     FETCHPC reg-      -> vcat [+      -> lines_ [              text "\tbcl\t20,31,1f",              hcat [ text "1:\tmflr\t", pprReg reg ]          ]     HWSYNC-      -> text "\tsync"+      -> line $ text "\tsync"     ISYNC-      -> text "\tisync"+      -> line $ text "\tisync"     LWSYNC-      -> text "\tlwsync"+      -> line $ text "\tlwsync"     NOP-      -> text "\tnop"+      -> line $ text "\tnop" -pprLogic :: Platform -> SDoc -> Reg -> Reg -> RI -> SDoc-pprLogic platform op reg1 reg2 ri = hcat [+pprLogic :: IsDoc doc => Platform -> Line doc -> Reg -> Reg -> RI -> doc+pprLogic platform op reg1 reg2 ri = line $ hcat [         char '\t',         op,         case ri of@@ -1024,8 +1022,8 @@     ]  -pprMul :: Platform -> Format -> Reg -> Reg -> RI -> SDoc-pprMul platform fmt reg1 reg2 ri = hcat [+pprMul :: IsDoc doc => Platform -> Format -> Reg -> Reg -> RI -> doc+pprMul platform fmt reg1 reg2 ri = line $ hcat [         char '\t',         text "mull",         case ri of@@ -1043,8 +1041,8 @@     ]  -pprDiv :: Format -> Bool -> Reg -> Reg -> Reg -> SDoc-pprDiv fmt sgn reg1 reg2 reg3 = hcat [+pprDiv :: IsDoc doc => Format -> Bool -> Reg -> Reg -> Reg -> doc+pprDiv fmt sgn reg1 reg2 reg3 = line $ hcat [         char '\t',         text "div",         case fmt of@@ -1061,8 +1059,8 @@     ]  -pprUnary :: SDoc -> Reg -> Reg -> SDoc-pprUnary op reg1 reg2 = hcat [+pprUnary :: IsDoc doc => Line doc -> Reg -> Reg -> doc+pprUnary op reg1 reg2 = line $ hcat [         char '\t',         op,         char '\t',@@ -1072,8 +1070,8 @@     ]  -pprBinaryF :: SDoc -> Format -> Reg -> Reg -> Reg -> SDoc-pprBinaryF op fmt reg1 reg2 reg3 = hcat [+pprBinaryF :: IsDoc doc => Line doc -> Format -> Reg -> Reg -> Reg -> doc+pprBinaryF op fmt reg1 reg2 reg3 = line $ hcat [         char '\t',         op,         pprFFormat fmt,@@ -1085,12 +1083,12 @@         pprReg reg3     ] -pprRI :: Platform -> RI -> SDoc+pprRI :: IsLine doc => Platform -> RI -> doc pprRI _        (RIReg r) = pprReg r pprRI platform (RIImm r) = pprImm platform r  -pprFFormat :: Format -> SDoc+pprFFormat :: IsLine doc => Format -> doc pprFFormat FF64     = empty pprFFormat FF32     = char 's' pprFFormat _        = panic "PPC.Ppr.pprFFormat: no match"

@@ -47,6 +47,7 @@ where  import GHC.Prelude+import GHC.Data.FastString  import GHC.Platform.Reg import GHC.Platform.Reg.Class@@ -133,7 +134,7 @@         = ImmInt        Int         | ImmInteger    Integer     -- Sigh.         | ImmCLbl       CLabel      -- AbstractC Label (with baggage)-        | ImmLit        String+        | ImmLit        FastString         | ImmIndex    CLabel Int         | ImmFloat      Rational         | ImmDouble     Rational@@ -146,7 +147,7 @@         | HIGHESTA Imm  -strImmLit :: String -> Imm+strImmLit :: FastString -> Imm strImmLit s = ImmLit s  

@@ -27,7 +27,6 @@ import GHC.Cmm import GHC.CmmToAsm.Config import GHC.Utils.Outputable as SDoc-import qualified GHC.Utils.Ppr as Pretty import GHC.Utils.Panic import GHC.Platform @@ -89,7 +88,7 @@ -- Print as a string and escape non-printable characters. -- This is similar to charToC in GHC.Utils.Misc -pprASCII :: ByteString -> SDoc+pprASCII :: forall doc. IsLine doc => ByteString -> doc pprASCII str   -- Transform this given literal bytestring to escaped string and construct   -- the literal SDoc directly.@@ -98,19 +97,19 @@   --   -- We work with a `Doc` instead of an `SDoc` because there is no need to carry   -- an `SDocContext` that we don't use. It leads to nicer (STG) code.-  = docToSDoc (BS.foldr f Pretty.empty str)+  = BS.foldr f empty str     where-       f :: Word8 -> Pretty.Doc -> Pretty.Doc-       f w s = do1 w Pretty.<> s+       f :: Word8 -> doc -> doc+       f w s = do1 w <> s -       do1 :: Word8 -> Pretty.Doc-       do1 w | 0x09 == w = Pretty.text "\\t"-             | 0x0A == w = Pretty.text "\\n"-             | 0x22 == w = Pretty.text "\\\""-             | 0x5C == w = Pretty.text "\\\\"+       do1 :: Word8 -> doc+       do1 w | 0x09 == w = text "\\t"+             | 0x0A == w = text "\\n"+             | 0x22 == w = text "\\\""+             | 0x5C == w = text "\\\\"                -- ASCII printable characters range-             | w >= 0x20 && w <= 0x7E = Pretty.char (chr' w)-             | otherwise = Pretty.sizedText 4 xs+             | w >= 0x20 && w <= 0x7E = char (chr' w)+             | otherwise = text xs                 where                  !xs = [ '\\', x0, x1, x2] -- octal                  !x0 = chr' (ord0 + (w `unsafeShiftR` 6) .&. 0x07)@@ -122,20 +121,25 @@        -- so we bypass the check in "chr"        chr' :: Word8 -> Char        chr' (W8# w#) = C# (chr# (word2Int# (word8ToWord# w#)))-+{-# SPECIALIZE pprASCII :: ByteString -> SDoc #-}+{-# SPECIALIZE pprASCII :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Emit a ".string" directive-pprString :: ByteString -> SDoc+pprString :: IsLine doc => ByteString -> doc pprString bs = text "\t.string " <> doubleQuotes (pprASCII bs)+{-# SPECIALIZE pprString :: ByteString -> SDoc #-}+{-# SPECIALIZE pprString :: ByteString -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- | Emit a ".incbin" directive -- -- A NULL byte is added after the binary data.-pprFileEmbed :: FilePath -> SDoc+pprFileEmbed :: IsLine doc => FilePath -> doc pprFileEmbed path    = text "\t.incbin "      <> pprFilePathString path -- proper escape (see #16389)      <> text "\n\t.byte 0"+{-# SPECIALIZE pprFileEmbed :: FilePath -> SDoc #-}+{-# SPECIALIZE pprFileEmbed :: FilePath -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  {- Note [Embedding large binary blobs]@@ -193,14 +197,16 @@ -- identical strings in the linker. With -split-sections each string also gets -- a unique section to allow strings from unused code to be GC'd. -pprSectionHeader :: NCGConfig -> Section -> SDoc+pprSectionHeader :: IsLine doc => NCGConfig -> Section -> doc pprSectionHeader config (Section t suffix) =  case platformOS (ncgPlatform config) of    OSAIX     -> pprXcoffSectionHeader t    OSDarwin  -> pprDarwinSectionHeader t    _         -> pprGNUSectionHeader config t suffix+{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> SDoc #-}+{-# SPECIALIZE pprSectionHeader :: NCGConfig -> Section -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc+pprGNUSectionHeader :: IsLine doc => NCGConfig -> SectionType -> CLabel -> doc pprGNUSectionHeader config t suffix =   hcat [text ".section ", header, subsection, flags]   where@@ -244,10 +250,12 @@                     -> empty         | otherwise -> text ",\"aMS\"," <> sectionType platform "progbits" <> text ",1"       _ -> empty+{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> SDoc #-}+{-# SPECIALIZE pprGNUSectionHeader :: NCGConfig -> SectionType -> CLabel -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable  -- XCOFF doesn't support relocating label-differences, so we place all -- RO sections into .text[PR] sections-pprXcoffSectionHeader :: SectionType -> SDoc+pprXcoffSectionHeader :: IsLine doc => SectionType -> doc pprXcoffSectionHeader t = case t of   Text                    -> text ".csect .text[PR]"   Data                    -> text ".csect .data[RW]"@@ -256,8 +264,10 @@   CString                 -> text ".csect .text[PR] # CString"   UninitialisedData       -> text ".csect .data[BS]"   _                       -> panic "pprXcoffSectionHeader: unknown section type"+{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> SDoc #-}+{-# SPECIALIZE pprXcoffSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable -pprDarwinSectionHeader :: SectionType -> SDoc+pprDarwinSectionHeader :: IsLine doc => SectionType -> doc pprDarwinSectionHeader t = case t of   Text                    -> text ".text"   Data                    -> text ".data"@@ -268,3 +278,5 @@   FiniArray               -> panic "pprDarwinSectionHeader: fini not supported"   CString                 -> text ".section\t__TEXT,__cstring,cstring_literals"   OtherSection _          -> panic "pprDarwinSectionHeader: unknown section type"+{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> SDoc #-}+{-# SPECIALIZE pprDarwinSectionHeader :: SectionType -> HLine #-} -- see Note [SPECIALIZE to HDoc] in GHC.Utils.Outputable

@@ -147,8 +147,7 @@                                 $ mapLookup blockId slotMap                  moreSlotsLive   = IntSet.fromList-                                $ catMaybes-                                $ map (lookupUFM regSlotMap)+                                $ mapMaybe (lookupUFM regSlotMap)                                 $ nonDetEltsUniqSet regsLive                     -- See Note [Unique Determinism and code generation] 

@@ -390,8 +390,7 @@         = do                 let slotsReloadedByTargets                         = IntSet.unions-                        $ catMaybes-                        $ map (flip mapLookup liveSlotsOnEntry)+                        $ mapMaybe (flip mapLookup liveSlotsOnEntry)                         $ targets                  let noReloads'

@@ -130,8 +130,8 @@                  -- Increment counts for what regs were read/written from.                 let (RU read written)   = regUsageOfInstr platform instr-                mapM_ (incUses scale) $ catMaybes $ map takeVirtualReg $ nub read-                mapM_ (incDefs scale) $ catMaybes $ map takeVirtualReg $ nub written+                mapM_ (incUses scale) $ mapMaybe takeVirtualReg $ nub read+                mapM_ (incDefs scale) $ mapMaybe takeVirtualReg $ nub written                  -- Compute liveness for entry to next instruction.                 let liveDieRead_virt    = takeVirtuals (liveDieRead  live)

@@ -119,6 +119,7 @@                             ArchS390X     -> panic "trivColorable ArchS390X"                             ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"+                            ArchWasm32    -> panic "trivColorable ArchWasm32"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_INTEGER                                 (virtualRegSqueeze RcInteger)@@ -152,6 +153,7 @@                             ArchS390X     -> panic "trivColorable ArchS390X"                             ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"+                            ArchWasm32    -> panic "trivColorable ArchWasm32"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_FLOAT                                 (virtualRegSqueeze RcFloat)@@ -184,6 +186,7 @@                             ArchS390X     -> panic "trivColorable ArchS390X"                             ArchRISCV64   -> panic "trivColorable ArchRISCV64"                             ArchJavaScript-> panic "trivColorable ArchJavaScript"+                            ArchWasm32    -> panic "trivColorable ArchWasm32"                             ArchUnknown   -> panic "trivColorable ArchUnknown")         , count2        <- accSqueeze 0 cALLOCATABLE_REGS_DOUBLE                                 (virtualRegSqueeze RcDouble)

@@ -225,6 +225,7 @@       ArchMipsel     -> panic "linearRegAlloc ArchMipsel"       ArchRISCV64    -> panic "linearRegAlloc ArchRISCV64"       ArchJavaScript -> panic "linearRegAlloc ArchJavaScript"+      ArchWasm32     -> panic "linearRegAlloc ArchWasm32"       ArchUnknown    -> panic "linearRegAlloc ArchUnknown"  where   go :: (FR regs, Outputable regs)

@@ -78,4 +78,5 @@    ArchMipsel    -> panic "maxSpillSlots ArchMipsel"    ArchRISCV64   -> panic "maxSpillSlots ArchRISCV64"    ArchJavaScript-> panic "maxSpillSlots ArchJavaScript"+   ArchWasm32    -> panic "maxSpillSlots ArchWasm32"    ArchUnknown   -> panic "maxSpillSlots ArchUnknown"

@@ -31,6 +31,8 @@ import GHC.Types.Unique.FM import GHC.Types.Unique.Set +import GHC.Utils.Outputable+ -- | For a jump instruction at the end of a block, generate fixup code so its --      vregs are in the correct regs for its destination. --@@ -375,6 +377,5 @@               -- we don't handle memory to memory moves.               -- they shouldn't happen because we don't share               -- stack slots between vregs.-              panic ("makeMove " ++ show vreg ++ " (" ++ show src ++ ") ("-                  ++ show dst ++ ")"-                  ++ " we don't handle mem->mem moves.")+              pprPanic "makeMove: we don't handle mem->mem moves"+                 (ppr vreg <+> parens (ppr src) <+> parens (ppr dst))

@@ -51,6 +51,7 @@       ArchMipsel    -> panic "targetVirtualRegSqueeze ArchMipsel"       ArchRISCV64   -> panic "targetVirtualRegSqueeze ArchRISCV64"       ArchJavaScript-> panic "targetVirtualRegSqueeze ArchJavaScript"+      ArchWasm32    -> panic "targetVirtualRegSqueeze ArchWasm32"       ArchUnknown   -> panic "targetVirtualRegSqueeze ArchUnknown"  @@ -69,6 +70,7 @@       ArchMipsel    -> panic "targetRealRegSqueeze ArchMipsel"       ArchRISCV64   -> panic "targetRealRegSqueeze ArchRISCV64"       ArchJavaScript-> panic "targetRealRegSqueeze ArchJavaScript"+      ArchWasm32    -> panic "targetRealRegSqueeze ArchWasm32"       ArchUnknown   -> panic "targetRealRegSqueeze ArchUnknown"  targetClassOfRealReg :: Platform -> RealReg -> RegClass@@ -86,6 +88,7 @@       ArchMipsel    -> panic "targetClassOfRealReg ArchMipsel"       ArchRISCV64   -> panic "targetClassOfRealReg ArchRISCV64"       ArchJavaScript-> panic "targetClassOfRealReg ArchJavaScript"+      ArchWasm32    -> panic "targetClassOfRealReg ArchWasm32"       ArchUnknown   -> panic "targetClassOfRealReg ArchUnknown"  targetMkVirtualReg :: Platform -> Unique -> Format -> VirtualReg@@ -103,6 +106,7 @@       ArchMipsel    -> panic "targetMkVirtualReg ArchMipsel"       ArchRISCV64   -> panic "targetMkVirtualReg ArchRISCV64"       ArchJavaScript-> panic "targetMkVirtualReg ArchJavaScript"+      ArchWasm32    -> panic "targetMkVirtualReg ArchWasm32"       ArchUnknown   -> panic "targetMkVirtualReg ArchUnknown"  targetRegDotColor :: Platform -> RealReg -> SDoc@@ -120,6 +124,7 @@       ArchMipsel    -> panic "targetRegDotColor ArchMipsel"       ArchRISCV64   -> panic "targetRegDotColor ArchRISCV64"       ArchJavaScript-> panic "targetRegDotColor ArchJavaScript"+      ArchWasm32    -> panic "targetRegDotColor ArchWasm32"       ArchUnknown   -> panic "targetRegDotColor ArchUnknown"  

@@ -0,0 +1,45 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE Strict #-}++module GHC.CmmToAsm.Wasm (ncgWasm) where++import Data.ByteString.Builder+import Data.Maybe+import Data.Semigroup+import GHC.Cmm+import GHC.CmmToAsm.Wasm.Asm+import GHC.CmmToAsm.Wasm.FromCmm+import GHC.CmmToAsm.Wasm.Types+import GHC.Data.Stream (Stream, StreamS (..), runStream)+import GHC.Platform+import GHC.Prelude+import GHC.Types.Unique.Supply+import GHC.Unit+import System.IO++ncgWasm ::+  Platform ->+  UniqSupply ->+  ModLocation ->+  Handle ->+  Stream IO RawCmmGroup a ->+  IO a+ncgWasm platform us loc h cmms = do+  (r, s) <- streamCmmGroups platform us cmms+  hPutBuilder h $ "# " <> string7 (fromJust $ ml_hs_file loc) <> "\n\n"+  hPutBuilder h $ execWasmAsmM $ asmTellEverything TagI32 s+  pure r++streamCmmGroups ::+  Platform ->+  UniqSupply ->+  Stream IO RawCmmGroup a ->+  IO (a, WasmCodeGenState 'I32)+streamCmmGroups 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

@@ -0,0 +1,511 @@+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE Strict #-}++module GHC.CmmToAsm.Wasm.Asm (asmTellEverything, execWasmAsmM) where++import Control.Monad+import Control.Monad.Trans.Reader+import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Builder+import Data.Coerce+import Data.Foldable+import qualified Data.IntSet as IS+import Data.Maybe+import Data.Semigroup+import GHC.Cmm+import GHC.CmmToAsm.Ppr+import GHC.CmmToAsm.Wasm.FromCmm+import GHC.CmmToAsm.Wasm.Types+import GHC.CmmToAsm.Wasm.Utils+import GHC.Data.FastString+import GHC.Float+import GHC.Prelude+import GHC.Types.Basic+import GHC.Types.Unique+import GHC.Types.Unique.Map+import GHC.Utils.Monad.State.Strict+import GHC.Utils.Outputable hiding ((<>))+import GHC.Utils.Panic (panic)++-- | Reads current indentation, appends result to state+newtype WasmAsmM a = WasmAsmM (Builder -> State Builder a)+  deriving+    ( Functor,+      Applicative,+      Monad+    )+    via (ReaderT Builder (State Builder))++instance Semigroup a => Semigroup (WasmAsmM a) where+  (<>) = liftA2 (<>)++instance Monoid a => Monoid (WasmAsmM a) where+  mempty = pure mempty++-- | Default indent level is none+execWasmAsmM :: WasmAsmM a -> Builder+execWasmAsmM (WasmAsmM m) = execState (m mempty) mempty++-- | Increase indent level by a tab+asmWithTab :: WasmAsmM a -> WasmAsmM a+asmWithTab (WasmAsmM m) = WasmAsmM $ \t -> m $! char7 '\t' <> t++-- | Writes a single line starting with the current indent+asmTellLine :: Builder -> WasmAsmM ()+asmTellLine b = WasmAsmM $ \t -> modify $ \acc -> acc <> t <> b <> char7 '\n'++-- | Writes a single line break+asmTellLF :: WasmAsmM ()+asmTellLF = WasmAsmM $ \_ -> modify $ \acc -> acc <> char7 '\n'++-- | Writes a line starting with a single tab, ignoring current indent+-- level+asmTellTabLine :: Builder -> WasmAsmM ()+asmTellTabLine b =+  WasmAsmM $ \_ -> modify $ \acc -> acc <> char7 '\t' <> b <> char7 '\n'++asmFromWasmType :: WasmTypeTag t -> Builder+asmFromWasmType ty = case ty of+  TagI32 -> "i32"+  TagI64 -> "i64"+  TagF32 -> "f32"+  TagF64 -> "f64"++asmFromSomeWasmType :: SomeWasmType -> Builder+asmFromSomeWasmType (SomeWasmType t) = asmFromWasmType t++asmFromSomeWasmTypes :: [SomeWasmType] -> Builder+asmFromSomeWasmTypes ts = "(" <> builderCommas asmFromSomeWasmType ts <> ")"++asmFromFuncType :: [SomeWasmType] -> [SomeWasmType] -> Builder+asmFromFuncType arg_tys ret_tys =+  asmFromSomeWasmTypes arg_tys <> " -> " <> asmFromSomeWasmTypes ret_tys++asmTellFuncType ::+  SymName -> ([SomeWasmType], [SomeWasmType]) -> WasmAsmM ()+asmTellFuncType sym (arg_tys, ret_tys) =+  asmTellTabLine $+    ".functype "+      <> asmFromSymName sym+      <> " "+      <> asmFromFuncType arg_tys ret_tys++asmTellLocals :: [SomeWasmType] -> WasmAsmM ()+asmTellLocals [] = mempty+asmTellLocals local_tys =+  asmTellTabLine $ ".local " <> builderCommas asmFromSomeWasmType local_tys++asmFromSymName :: SymName -> Builder+asmFromSymName = shortByteString . coerce fastStringToShortByteString++asmTellDefSym :: SymName -> WasmAsmM ()+asmTellDefSym sym = do+  asmTellTabLine $ ".hidden " <> asm_sym+  asmTellTabLine $ ".globl " <> asm_sym+  where+    asm_sym = asmFromSymName sym++asmTellDataSectionContent :: WasmTypeTag w -> DataSectionContent -> WasmAsmM ()+asmTellDataSectionContent ty_word c = asmTellTabLine $ case c of+  DataI8 i -> ".int8 " <> integerDec i+  DataI16 i -> ".int16 " <> integerDec i+  DataI32 i -> ".int32 " <> integerDec i+  DataI64 i -> ".int64 " <> integerDec i+  DataF32 f -> ".int32 0x" <> word32Hex (castFloatToWord32 f)+  DataF64 d -> ".int64 0x" <> word64Hex (castDoubleToWord64 d)+  DataSym sym o ->+    ( case ty_word of+        TagI32 -> ".int32 "+        TagI64 -> ".int64 "+        _ -> panic "asmTellDataSectionContent: unreachable"+    )+      <> asmFromSymName sym+      <> ( case compare o 0 of+             EQ -> mempty+             GT -> "+" <> intDec o+             LT -> intDec o+         )+  DataSkip i -> ".skip " <> intDec i+  DataASCII s+    | not (BS.null s) && BS.last s == 0 ->+        ".asciz \""+          <> string7+            (showSDocOneLine defaultSDocContext $ pprASCII $ BS.init s)+          <> "\""+    | otherwise ->+        ".ascii \""+          <> string7+            (showSDocOneLine defaultSDocContext $ pprASCII s)+          <> "\""+  DataIncBin f _ ->+    ".incbin "+      <> string7+        (showSDocOneLine defaultSDocContext $ pprFilePathString f)++dataSectionContentSize :: WasmTypeTag w -> DataSectionContent -> Int+dataSectionContentSize ty_word c = case c of+  DataI8 {} -> 1+  DataI16 {} -> 2+  DataI32 {} -> 4+  DataI64 {} -> 8+  DataF32 {} -> 4+  DataF64 {} -> 8+  DataSym {} -> alignmentBytes $ alignmentFromWordType ty_word+  DataSkip i -> i+  DataASCII s -> BS.length s+  DataIncBin _ l -> l++dataSectionSize :: WasmTypeTag w -> [DataSectionContent] -> Int+dataSectionSize ty_word =+  coerce+    . foldMap'+      (Sum . dataSectionContentSize ty_word)++asmTellAlign :: Alignment -> WasmAsmM ()+asmTellAlign a = case alignmentBytes a of+  1 -> mempty+  i -> asmTellTabLine $ ".p2align " <> intDec (countTrailingZeros i)++asmTellSectionHeader :: Builder -> WasmAsmM ()+asmTellSectionHeader k = asmTellTabLine $ ".section " <> k <> ",\"\",@"++asmTellDataSection ::+  WasmTypeTag w -> IS.IntSet -> SymName -> DataSection -> WasmAsmM ()+asmTellDataSection ty_word def_syms sym DataSection {..} = do+  when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym+  asmTellSectionHeader sec_name+  asmTellAlign dataSectionAlignment+  asmTellTabLine asm_size+  asmTellLine $ asm_sym <> ":"+  for_ dataSectionContents $ asmTellDataSectionContent ty_word+  asmTellLF+  where+    asm_sym = asmFromSymName sym++    sec_name =+      ( case dataSectionKind of+          SectionData -> ".data."+          SectionROData -> ".rodata."+      )+        <> asm_sym++    asm_size =+      ".size "+        <> asm_sym+        <> ", "+        <> intDec+          (dataSectionSize ty_word dataSectionContents)++asmFromWasmBlockType :: WasmTypeTag w -> WasmFunctionType pre post -> Builder+asmFromWasmBlockType+  _+  (WasmFunctionType {ft_pops = TypeListNil, ft_pushes = TypeListNil}) =+    mempty+asmFromWasmBlockType+  TagI32+  ( WasmFunctionType+      { ft_pops = TypeListNil,+        ft_pushes = TypeListCons TagI32 TypeListNil+      }+    ) =+    " i32"+asmFromWasmBlockType+  TagI64+  ( WasmFunctionType+      { ft_pops = TypeListNil,+        ft_pushes = TypeListCons TagI64 TypeListNil+      }+    ) =+    " i64"+asmFromWasmBlockType _ _ = panic "asmFromWasmBlockType: invalid block type"++asmFromAlignmentSpec :: AlignmentSpec -> Builder+asmFromAlignmentSpec NaturallyAligned = mempty+asmFromAlignmentSpec Unaligned = ":p2align=0"++asmTellWasmInstr :: WasmTypeTag w -> WasmInstr w pre post -> WasmAsmM ()+asmTellWasmInstr ty_word instr = case instr of+  WasmComment c -> asmTellLine $ stringUtf8 $ "# " <> c+  WasmNop -> mempty+  WasmDrop -> asmTellLine "drop"+  WasmUnreachable -> asmTellLine "unreachable"+  WasmConst TagI32 i -> asmTellLine $ "i32.const " <> integerDec i+  WasmConst TagI64 i -> asmTellLine $ "i64.const " <> integerDec i+  WasmConst {} -> panic "asmTellWasmInstr: unreachable"+  WasmSymConst sym ->+    asmTellLine $+      ( case ty_word of+          TagI32 -> "i32.const "+          TagI64 -> "i64.const "+          _ -> panic "asmTellWasmInstr: unreachable"+      )+        <> asmFromSymName sym+  WasmLoad ty (Just w) s o align ->+    asmTellLine $+      asmFromWasmType ty+        <> ".load"+        <> intDec w+        <> ( case s of+               Signed -> "_s"+               Unsigned -> "_u"+           )+        <> " "+        <> intDec o+        <> asmFromAlignmentSpec align+  WasmLoad ty Nothing _ o align ->+    asmTellLine $+      asmFromWasmType ty+        <> ".load"+        <> " "+        <> intDec o+        <> asmFromAlignmentSpec align+  WasmStore ty (Just w) o align ->+    asmTellLine $+      asmFromWasmType ty+        <> ".store"+        <> intDec w+        <> " "+        <> intDec o+        <> asmFromAlignmentSpec align+  WasmStore ty Nothing o align ->+    asmTellLine $+      asmFromWasmType ty+        <> ".store"+        <> " "+        <> intDec o+        <> asmFromAlignmentSpec align+  WasmGlobalGet _ sym -> asmTellLine $ "global.get " <> asmFromSymName sym+  WasmGlobalSet _ sym -> asmTellLine $ "global.set " <> asmFromSymName sym+  WasmLocalGet _ i -> asmTellLine $ "local.get " <> intDec i+  WasmLocalSet _ i -> asmTellLine $ "local.set " <> intDec i+  WasmLocalTee _ i -> asmTellLine $ "local.tee " <> intDec i+  WasmCCall sym -> asmTellLine $ "call " <> asmFromSymName sym+  WasmCCallIndirect arg_tys ret_tys ->+    asmTellLine $+      "call_indirect "+        <> asmFromFuncType+          (someWasmTypesFromTypeList arg_tys)+          (someWasmTypesFromTypeList ret_tys)+  WasmConcat instr0 instr1 -> do+    asmTellWasmInstr ty_word instr0+    asmTellWasmInstr ty_word instr1+  WasmReinterpret t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".reinterpret_" <> asmFromWasmType t0+  WasmTruncSat Signed t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_s"+  WasmTruncSat Unsigned t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".trunc_sat_" <> asmFromWasmType t0 <> "_u"+  WasmConvert Signed t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_s"+  WasmConvert Unsigned t0 t1 ->+    asmTellLine $+      asmFromWasmType t1 <> ".convert_" <> asmFromWasmType t0 <> "_u"+  WasmAdd ty -> asmTellLine $ asmFromWasmType ty <> ".add"+  WasmSub ty -> asmTellLine $ asmFromWasmType ty <> ".sub"+  WasmMul ty -> asmTellLine $ asmFromWasmType ty <> ".mul"+  WasmDiv _ TagF32 -> asmTellLine "f32.div"+  WasmDiv _ TagF64 -> asmTellLine "f64.div"+  WasmDiv Signed ty -> asmTellLine $ asmFromWasmType ty <> ".div_s"+  WasmDiv Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".div_u"+  WasmRem Signed ty -> asmTellLine $ asmFromWasmType ty <> ".rem_s"+  WasmRem Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".rem_u"+  WasmAnd ty -> asmTellLine $ asmFromWasmType ty <> ".and"+  WasmOr ty -> asmTellLine $ asmFromWasmType ty <> ".or"+  WasmXor ty -> asmTellLine $ asmFromWasmType ty <> ".xor"+  WasmEq ty -> asmTellLine $ asmFromWasmType ty <> ".eq"+  WasmNe ty -> asmTellLine $ asmFromWasmType ty <> ".ne"+  WasmLt _ TagF32 -> asmTellLine "f32.lt"+  WasmLt _ TagF64 -> asmTellLine "f64.lt"+  WasmLt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".lt_s"+  WasmLt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".lt_u"+  WasmGt _ TagF32 -> asmTellLine "f32.gt"+  WasmGt _ TagF64 -> asmTellLine "f64.gt"+  WasmGt Signed ty -> asmTellLine $ asmFromWasmType ty <> ".gt_s"+  WasmGt Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".gt_u"+  WasmLe _ TagF32 -> asmTellLine "f32.le"+  WasmLe _ TagF64 -> asmTellLine "f64.le"+  WasmLe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".le_s"+  WasmLe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".le_u"+  WasmGe _ TagF32 -> asmTellLine "f32.ge"+  WasmGe _ TagF64 -> asmTellLine "f64.ge"+  WasmGe Signed ty -> asmTellLine $ asmFromWasmType ty <> ".ge_s"+  WasmGe Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".ge_u"+  WasmShl ty -> asmTellLine $ asmFromWasmType ty <> ".shl"+  WasmShr Signed ty -> asmTellLine $ asmFromWasmType ty <> ".shr_s"+  WasmShr Unsigned ty -> asmTellLine $ asmFromWasmType ty <> ".shr_u"+  WasmI32Extend8S -> asmTellLine "i32.extend8_s"+  WasmI32Extend16S -> asmTellLine "i32.extend16_s"+  WasmI64Extend8S -> asmTellLine "i64.extend8_s"+  WasmI64Extend16S -> asmTellLine "i64.extend16_s"+  WasmI64Extend32S -> asmTellLine "i64.extend32_s"+  WasmI64ExtendI32 Signed -> asmTellLine "i64.extend_i32_s"+  WasmI64ExtendI32 Unsigned -> asmTellLine "i64.extend_i32_u"+  WasmI32WrapI64 -> asmTellLine "i32.wrap_i64"+  WasmF32DemoteF64 -> asmTellLine "f32.demote_f64"+  WasmF64PromoteF32 -> asmTellLine "f64.promote_f32"+  WasmAbs ty -> asmTellLine $ asmFromWasmType ty <> ".abs"+  WasmCond t -> do+    asmTellLine "if"+    asmWithTab $ asmTellWasmInstr ty_word t+    asmTellLine "end_if"++asmTellWasmControl ::+  WasmTypeTag w ->+  WasmControl+    (WasmStatements w)+    (WasmExpr w a)+    pre+    post ->+  WasmAsmM ()+asmTellWasmControl ty_word c = case c of+  WasmPush _ (WasmExpr e) -> asmTellWasmInstr ty_word e+  WasmBlock bt c -> do+    asmTellLine $ "block" <> asmFromWasmBlockType ty_word bt+    asmWithTab $ asmTellWasmControl ty_word c+    asmTellLine "end_block"+  WasmLoop bt c -> do+    asmTellLine $ "loop" <> asmFromWasmBlockType ty_word bt+    asmWithTab $ asmTellWasmControl ty_word c+    -- asmTellLine "br 0"+    asmTellLine "end_loop"+  WasmIfTop bt t f -> do+    asmTellLine $ "if" <> asmFromWasmBlockType ty_word bt+    asmWithTab $ asmTellWasmControl ty_word t+    asmTellLine "else"+    asmWithTab $ asmTellWasmControl ty_word f+    asmTellLine "end_if"+  WasmBr i -> asmTellLine $ "br " <> intDec i+  WasmFallthrough -> mempty+  WasmBrTable (WasmExpr e) _ ts t -> do+    asmTellWasmInstr ty_word e+    asmTellLine $ "br_table {" <> builderCommas intDec (ts <> [t]) <> "}"+  WasmReturnTop _ -> asmTellLine "return"+  WasmActions (WasmStatements a) -> asmTellWasmInstr ty_word a+  WasmSeq c0 c1 -> do+    asmTellWasmControl ty_word c0+    asmTellWasmControl ty_word c1++asmTellFunc ::+  WasmTypeTag w ->+  IS.IntSet ->+  SymName ->+  (([SomeWasmType], [SomeWasmType]), FuncBody w) ->+  WasmAsmM ()+asmTellFunc ty_word def_syms sym (func_ty, FuncBody {..}) = do+  when (getKey (getUnique sym) `IS.member` def_syms) $ asmTellDefSym sym+  asmTellSectionHeader $ ".text." <> asm_sym+  asmTellLine $ asm_sym <> ":"+  asmTellFuncType sym func_ty+  asmTellLocals funcLocals+  asmWithTab $ asmTellWasmControl ty_word funcBody+  asmTellTabLine "end_function"+  asmTellLF+  where+    asm_sym = asmFromSymName sym++asmTellGlobals :: WasmTypeTag w -> WasmAsmM ()+asmTellGlobals ty_word = do+  for_ supportedCmmGlobalRegs $ \reg ->+    let (sym, ty) = fromJust $ globalInfoFromCmmGlobalReg ty_word reg+     in asmTellTabLine $+          ".globaltype "+            <> asmFromSymName sym+            <> ", "+            <> asmFromSomeWasmType ty+  asmTellLF++asmTellCtors :: WasmTypeTag w -> [SymName] -> WasmAsmM ()+asmTellCtors _ [] = mempty+asmTellCtors ty_word syms = do+  asmTellSectionHeader ".init_array"+  asmTellAlign $ alignmentFromWordType ty_word+  for_ syms $ \sym ->+    asmTellTabLine $+      ( case ty_word of+          TagI32 -> ".int32 "+          TagI64 -> ".int64 "+          _ -> panic "asmTellCtors: unreachable"+      )+        <> asmFromSymName sym+  asmTellLF++asmTellBS :: ByteString -> WasmAsmM ()+asmTellBS s = do+  asmTellTabLine $ ".int8 " <> intDec (BS.length s)+  asmTellTabLine $+    ".ascii \""+      <> string7+        (showSDocOneLine defaultSDocContext $ pprASCII s)+      <> "\""++asmTellVec :: [WasmAsmM ()] -> WasmAsmM ()+asmTellVec xs = do+  asmTellTabLine $ ".int8 " <> intDec (length xs)+  sequence_ xs++asmTellProducers :: WasmAsmM ()+asmTellProducers = do+  asmTellSectionHeader ".custom_section.producers"+  asmTellVec+    [ do+        asmTellBS "processed-by"+        asmTellVec+          [ do+              asmTellBS "ghc"+              asmTellBS "9.6"+          ]+    ]++asmTellTargetFeatures :: WasmAsmM ()+asmTellTargetFeatures = do+  asmTellSectionHeader ".custom_section.target_features"+  asmTellVec+    [ do+        asmTellTabLine ".int8 0x2b"+        asmTellBS feature+      | feature <-+          [ "bulk-memory",+            "mutable-globals",+            "nontrapping-fptoint",+            "reference-types",+            "sign-ext"+          ]+    ]++asmTellEverything :: WasmTypeTag w -> WasmCodeGenState w -> WasmAsmM ()+asmTellEverything ty_word WasmCodeGenState {..} = do+  asmTellGlobals ty_word+  asm_functypes+  asm_funcs+  asm_data_secs+  asm_ctors+  asmTellProducers+  asmTellTargetFeatures+  where+    asm_functypes = do+      for_+        (detEltsUniqMap $ funcTypes `minusUniqMap` funcBodies)+        (uncurry asmTellFuncType)+      asmTellLF++    asm_funcs = do+      for_+        (detEltsUniqMap $ intersectUniqMap_C (,) funcTypes funcBodies)+        (uncurry $ asmTellFunc ty_word defaultSyms)+      asmTellLF++    asm_data_secs = do+      for_+        (detEltsUniqMap dataSections)+        (uncurry (asmTellDataSection ty_word defaultSyms))+      asmTellLF++    asm_ctors = asmTellCtors ty_word ctors

@@ -0,0 +1,1677 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE Strict #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UnboxedTuples #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -Wno-unrecognised-pragmas #-}++{-# HLINT ignore "Use camelCase" #-}+module GHC.CmmToAsm.Wasm.FromCmm where++import Control.Monad+import qualified Data.ByteString as BS+import Data.Foldable+import Data.Functor+import qualified Data.IntSet as IS+import Data.Semigroup+import Data.String+import Data.Traversable+import Data.Type.Equality+import GHC.Cmm+import GHC.Cmm.CLabel+import GHC.Cmm.Dataflow.Block+import GHC.Cmm.Dataflow.Label+import GHC.Cmm.InitFini+import GHC.CmmToAsm.Wasm.Types+import GHC.CmmToAsm.Wasm.Utils+import GHC.Float+import GHC.Platform+import GHC.Prelude+import GHC.StgToCmm.CgUtils+import GHC.Types.Basic+import GHC.Types.ForeignCall+import GHC.Types.Unique+import GHC.Types.Unique.FM+import GHC.Types.Unique.Map+import GHC.Utils.Outputable hiding ((<>))+import GHC.Utils.Panic+import GHC.Wasm.ControlFlow.FromCmm++-- | Calculate the wasm representation type from a 'CmmType'. This is+-- a lossy conversion, and sometimes we need to pass the original+-- 'CmmType' or at least its 'Width' around, so to properly add+-- subword truncation or extension logic.+someWasmTypeFromCmmType :: CmmType -> SomeWasmType+someWasmTypeFromCmmType t+  | isWord32 t = SomeWasmType TagI32+  | isWord64 t = SomeWasmType TagI64+  | t `cmmEqType` b16 = SomeWasmType TagI32+  | t `cmmEqType` b8 = SomeWasmType TagI32+  | isFloat64 t = SomeWasmType TagF64+  | isFloat32 t = SomeWasmType TagF32+  | otherwise =+      panic $+        "someWasmTypeFromCmmType: unsupported CmmType "+          <> showSDocOneLine defaultSDocContext (ppr t)++-- | Calculate the optional memory narrowing of a 'CmmLoad' or+-- 'CmmStore'.+wasmMemoryNarrowing :: WasmTypeTag t -> CmmType -> Maybe Int+wasmMemoryNarrowing ty ty_cmm = case (# ty, typeWidth ty_cmm #) of+  (# TagI32, W8 #) -> Just 8+  (# TagI32, W16 #) -> Just 16+  (# TagI32, W32 #) -> Nothing+  (# TagI64, W8 #) -> Just 8+  (# TagI64, W16 #) -> Just 16+  (# TagI64, W32 #) -> Just 32+  (# TagI64, W64 #) -> Nothing+  (# TagF32, W32 #) -> Nothing+  (# TagF64, W64 #) -> Nothing+  _ -> panic "wasmMemoryNarrowing: unreachable"++-- | Despite this is used by the WebAssembly native codegen, we use+-- 'pprCLabel' instead of 'pprAsmLabel' when emitting the textual+-- symbol name. Either one would work, but 'pprCLabel' makes the+-- output assembly code looks closer to the unregisterised codegen+-- output, which can be handy when using the unregisterised codegen as+-- a source of truth when debugging the native codegen.+symNameFromCLabel :: CLabel -> SymName+symNameFromCLabel lbl =+  fromString $+    showSDocOneLine defaultSDocContext {sdocStyle = PprCode} $+      pprCLabel genericPlatform lbl++-- | Calculate a symbol's visibility.+symVisibilityFromCLabel :: CLabel -> SymVisibility+symVisibilityFromCLabel lbl+  | externallyVisibleCLabel lbl = SymDefault+  | otherwise = SymStatic++-- | Calculate a symbol's kind, see haddock docs of 'SymKind' for more+-- explanation.+symKindFromCLabel :: CLabel -> SymKind+symKindFromCLabel lbl+  | isCFunctionLabel lbl = SymFunc+  | otherwise = SymData++-- | Calculate a data section's kind, see haddock docs of+-- 'DataSectionKind' for more explanation.+dataSectionKindFromCmmSection :: Section -> DataSectionKind+dataSectionKindFromCmmSection s = case sectionProtection s of+  ReadWriteSection -> SectionData+  _ -> SectionROData++-- | Calculate the natural alignment size given the platform word+-- type.+alignmentFromWordType :: WasmTypeTag w -> Alignment+alignmentFromWordType TagI32 = mkAlignment 4+alignmentFromWordType TagI64 = mkAlignment 8+alignmentFromWordType _ = panic "alignmentFromWordType: unreachable"++-- | Calculate a data section's alignment. Closures needs to be+-- naturally aligned; info tables need to align to 2, so to get 1 tag+-- bit as forwarding pointer marker. The rest have no alignment+-- requirements.+alignmentFromCmmSection :: WasmTypeTag w -> CLabel -> Alignment+alignmentFromCmmSection t lbl+  | isStaticClosureLabel lbl = alignmentFromWordType t+  | isInfoTableLabel lbl = mkAlignment 2+  | otherwise = mkAlignment 1++-- | Lower a 'CmmStatic'.+lower_CmmStatic :: CmmStatic -> WasmCodeGenM w DataSectionContent+lower_CmmStatic s = case s of+  CmmStaticLit (CmmInt i W8) -> pure $ DataI8 $ naturalNarrowing W8 i+  CmmStaticLit (CmmInt i W16) -> pure $ DataI16 $ naturalNarrowing W16 i+  CmmStaticLit (CmmInt i W32) -> pure $ DataI32 $ naturalNarrowing W32 i+  CmmStaticLit (CmmInt i W64) -> pure $ DataI64 $ naturalNarrowing W64 i+  CmmStaticLit (CmmFloat f W32) -> pure $ DataF32 $ fromRational f+  CmmStaticLit (CmmFloat d W64) -> pure $ DataF64 $ fromRational d+  CmmStaticLit (CmmLabel lbl) ->+    onAnySym lbl+      $> DataSym+        (symNameFromCLabel lbl)+        0+  CmmStaticLit (CmmLabelOff lbl o) ->+    onAnySym lbl+      $> DataSym+        (symNameFromCLabel lbl)+        o+  CmmUninitialised i -> pure $ DataSkip i+  CmmString b -> pure $ DataASCII b+  CmmFileEmbed f l -> pure $ DataIncBin f l+  _ -> panic "lower_CmmStatic: unreachable"++{-+Note [Register mapping on WebAssembly]+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~++Unlike typical ISAs, WebAssembly doesn't expose a fixed set of+registers. For now, we map each Cmm LocalReg to a wasm local, and each+Cmm GlobalReg to a wasm global. The wasm globals are defined in+rts/wasm/Wasm.S, and must be kept in sync with+'globalInfoFromCmmGlobalReg' and 'supportedCmmGlobalRegs' here.++There are some other Cmm GlobalRegs which are still represented by+StgRegTable fields instead of wasm globals (e.g. HpAlloc). It's cheap+to add wasm globals, but other parts of rts logic only work with the+StgRegTable fields, so we also need to instrument StgRun/StgReturn to+sync the wasm globals with the StgRegTable. It's not really worth the+trouble.++-}+globalInfoFromCmmGlobalReg :: WasmTypeTag w -> GlobalReg -> Maybe GlobalInfo+globalInfoFromCmmGlobalReg t reg = case reg of+  VanillaReg i _+    | i >= 1 && i <= 10 -> Just (fromString $ "__R" <> show i, ty_word)+  FloatReg i+    | i >= 1 && i <= 6 ->+        Just (fromString $ "__F" <> show i, SomeWasmType TagF32)+  DoubleReg i+    | i >= 1 && i <= 6 ->+        Just (fromString $ "__D" <> show i, SomeWasmType TagF64)+  LongReg i+    | i == 1 -> Just (fromString $ "__L" <> show i, SomeWasmType TagI64)+  Sp -> Just ("__Sp", ty_word)+  SpLim -> Just ("__SpLim", ty_word)+  Hp -> Just ("__Hp", ty_word)+  HpLim -> Just ("__HpLim", ty_word)+  CCCS -> Just ("__CCCS", ty_word)+  _ -> Nothing+  where+    ty_word = SomeWasmType t++supportedCmmGlobalRegs :: [GlobalReg]+supportedCmmGlobalRegs =+  [VanillaReg i VGcPtr | i <- [1 .. 10]]+    <> [FloatReg i | i <- [1 .. 6]]+    <> [DoubleReg i | i <- [1 .. 6]]+    <> [LongReg i | i <- [1 .. 1]]+    <> [Sp, SpLim, Hp, HpLim, CCCS]++-- | Allocate a fresh symbol for an internal data section.+allocDataSection :: DataSection -> WasmCodeGenM w SymName+allocDataSection sec = do+  u <- wasmUniq+  let sym = fromString $ ".L" <> show u+  wasmModifyM $ \s ->+    s+      { dataSections =+          addToUniqMap (dataSections s) sym sec+      }+  pure sym++-- | Print a debug message to stderr by calling @fputs()@. We don't+-- bother to check @fputs()@ return value.+wasmDebugMsg :: String -> WasmCodeGenM w (WasmStatements w)+wasmDebugMsg msg = do+  ty_word_cmm <- wasmWordCmmTypeM+  sym_buf <-+    allocDataSection+      DataSection+        { dataSectionKind =+            SectionROData,+          dataSectionAlignment =+            mkAlignment 1,+          dataSectionContents =+            [DataASCII $ fromString $ msg <> "\NUL"]+        }+  onFuncSym "fputs" [ty_word_cmm, ty_word_cmm] [b32]+  pure $+    WasmStatements $+      WasmSymConst sym_buf+        `WasmConcat` WasmSymConst "__stderr_FILE"+        `WasmConcat` WasmCCall "fputs"+        `WasmConcat` WasmDrop++-- | Truncate a subword.+truncSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t+truncSubword W8 ty (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmConst ty 0xFF `WasmConcat` WasmAnd ty+truncSubword W16 ty (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmConst ty 0xFFFF `WasmConcat` WasmAnd ty+truncSubword _ _ expr = expr++-- | Sign-extend a subword.+extendSubword :: Width -> WasmTypeTag t -> WasmExpr w t -> WasmExpr w t+extendSubword W8 TagI32 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI32Extend8S+extendSubword W16 TagI32 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI32Extend16S+extendSubword W8 TagI64 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI64Extend8S+extendSubword W16 TagI64 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI64Extend16S+extendSubword W32 TagI64 (WasmExpr instr) =+  WasmExpr $ instr `WasmConcat` WasmI64Extend32S+extendSubword _ _ expr = expr++-- | Lower a binary homogeneous operation. Homogeneous: result type is+-- the same with operand types.+lower_MO_Bin_Homo ::+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : t : pre)+      (t : pre)+  ) ->+  CLabel ->+  CmmType ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Homo op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+    pure $+      SomeWasmExpr ty $+        WasmExpr $+          x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Homo _ _ _ _ = panic "lower_MO_Bin_Homo: unreachable"++-- | Lower a binary homogeneous operation, and truncate the result if+-- it's a subword.+lower_MO_Bin_Homo_Trunc ::+  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) ->+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Homo_Trunc op lbl w0 [x, y] =+  case someWasmTypeFromCmmType (cmmBits w0) of+    SomeWasmType ty -> do+      WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+      WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+      pure $+        SomeWasmExpr ty $+          truncSubword w0 ty $+            WasmExpr $+              x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Homo_Trunc _ _ _ _ = panic "lower_MO_Bin_Homo_Trunc: unreachable"++-- | Lower a binary homogeneous operation, first sign extending the+-- operands, then truncating the result.+lower_MO_Bin_Homo_Ext_Trunc ::+  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (t : pre)) ->+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Homo_Ext_Trunc op lbl w0 [x, y] =+  case someWasmTypeFromCmmType (cmmBits w0) of+    SomeWasmType ty -> do+      WasmExpr x_instr <-+        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x+      WasmExpr y_instr <-+        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y+      pure $+        SomeWasmExpr ty $+          truncSubword w0 ty $+            WasmExpr $+              x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Homo_Ext_Trunc _ _ _ _ =+  panic "lower_MO_Bin_Homo_Ext_Trunc: unreachable"++-- | Lower a relational binary operation, first sign extending the+-- operands. Relational: result type is a boolean (word type).+lower_MO_Bin_Rel_Ext ::+  (forall pre t. WasmTypeTag t -> WasmInstr w (t : t : pre) (w : pre)) ->+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Rel_Ext op lbl w0 [x, y] =+  case someWasmTypeFromCmmType (cmmBits w0) of+    SomeWasmType ty -> do+      WasmExpr x_instr <-+        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x+      WasmExpr y_instr <-+        extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty y+      ty_word <- wasmWordTypeM+      pure $+        SomeWasmExpr ty_word $+          WasmExpr $+            x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Rel_Ext _ _ _ _ = panic "lower_MO_Bin_Rel_Ext: unreachable"++-- | Lower a relational binary operation.+lower_MO_Bin_Rel ::+  ( forall pre t.+    WasmTypeTag t ->+    WasmInstr+      w+      (t : t : pre)+      (w : pre)+  ) ->+  CLabel ->+  CmmType ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Bin_Rel op lbl t0 [x, y] = case someWasmTypeFromCmmType t0 of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+    ty_word <- wasmWordTypeM+    pure $+      SomeWasmExpr ty_word $+        WasmExpr $+          x_instr `WasmConcat` y_instr `WasmConcat` op ty+lower_MO_Bin_Rel _ _ _ _ = panic "lower_MO_Bin_Rel: unreachable"++-- | Cast a shiftL/shiftR RHS to the same type as LHS. Because we may+-- have a 64-bit LHS and 32-bit RHS, but wasm shift operators are+-- homogeneous.+shiftRHSCast ::+  CLabel ->+  WasmTypeTag t ->+  CmmExpr ->+  WasmCodeGenM+    w+    (WasmExpr w t)+shiftRHSCast lbl t1 x = do+  SomeWasmExpr t0 (WasmExpr x_instr) <- lower_CmmExpr lbl x+  if+      | Just Refl <- t0 `testEquality` t1 -> pure $ WasmExpr x_instr+      | TagI32 <- t0,+        TagI64 <- t1 ->+          pure $ WasmExpr $ x_instr `WasmConcat` WasmI64ExtendI32 Unsigned+      | otherwise -> panic "shiftRHSCast: unreachable"++-- | Lower a 'MO_Shl' operation, truncating the result.+lower_MO_Shl ::+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_Shl lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- shiftRHSCast lbl ty y+    pure $+      SomeWasmExpr ty $+        truncSubword w0 ty $+          WasmExpr $+            x_instr `WasmConcat` y_instr `WasmConcat` WasmShl ty+lower_MO_Shl _ _ _ = panic "lower_MO_Shl: unreachable"++-- | Lower a 'MO_U_Shr' operation.+lower_MO_U_Shr ::+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_U_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- shiftRHSCast lbl ty y+    pure $+      SomeWasmExpr ty $+        WasmExpr $+          x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Unsigned ty+lower_MO_U_Shr _ _ _ = panic "lower_MO_U_Shr: unreachable"++-- | Lower a 'MO_S_Shr' operation, first sign-extending the LHS, then+-- truncating the result.+lower_MO_S_Shr ::+  CLabel ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_S_Shr lbl w0 [x, y] = case someWasmTypeFromCmmType (cmmBits w0) of+  SomeWasmType ty -> do+    WasmExpr x_instr <- extendSubword w0 ty <$> lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- shiftRHSCast lbl ty y+    pure $+      SomeWasmExpr ty $+        truncSubword w0 ty $+          WasmExpr $+            x_instr `WasmConcat` y_instr `WasmConcat` WasmShr Signed ty+lower_MO_S_Shr _ _ _ = panic "lower_MO_S_Shr: unreachable"++-- | Lower a 'MO_MulMayOflo' operation. It's translated to a ccall to+-- @hs_mulIntMayOflo@ function in @ghc-prim/cbits/mulIntMayOflo@,+-- otherwise it's quite non-trivial to implement as inline assembly.+lower_MO_MulMayOflo ::+  CLabel -> Width -> [CmmExpr] -> WasmCodeGenM w (SomeWasmExpr w)+lower_MO_MulMayOflo lbl w0 [x, y] = case someWasmTypeFromCmmType ty_cmm of+  SomeWasmType ty -> do+    WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+    WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+    onFuncSym "hs_mulIntMayOflo" [ty_cmm, ty_cmm] [ty_cmm]+    pure $+      SomeWasmExpr ty $+        WasmExpr $+          x_instr+            `WasmConcat` y_instr+            `WasmConcat` WasmCCall "hs_mulIntMayOflo"+  where+    ty_cmm = cmmBits w0+lower_MO_MulMayOflo _ _ _ = panic "lower_MO_MulMayOflo: unreachable"++-- | Lower an unary conversion operation.+lower_MO_Un_Conv ::+  ( forall pre t0 t1.+    WasmTypeTag t0 ->+    WasmTypeTag t1 ->+    WasmInstr w (t0 : pre) (t1 : pre)+  ) ->+  CLabel ->+  CmmType ->+  CmmType ->+  [CmmExpr] ->+  WasmCodeGenM w (SomeWasmExpr w)+lower_MO_Un_Conv op lbl t0 t1 [x] =+  case (# someWasmTypeFromCmmType t0, someWasmTypeFromCmmType t1 #) of+    (# SomeWasmType ty0, SomeWasmType ty1 #) -> do+      WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty0 x+      pure $ SomeWasmExpr ty1 $ WasmExpr $ x_instr `WasmConcat` op ty0 ty1+lower_MO_Un_Conv _ _ _ _ _ = panic "lower_MO_Un_Conv: unreachable"++-- | Lower a 'MO_SS_Conv' operation.+lower_MO_SS_Conv ::+  CLabel ->+  Width ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_SS_Conv lbl w0 w1 [x]+  | w0 == w1 = lower_CmmExpr lbl x+lower_MO_SS_Conv lbl w0 w1 [CmmLoad ptr _ align]+  | w0 < w1,+    w1 <= W32 = do+      (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr+      pure $+        SomeWasmExpr TagI32 $+          truncSubword w1 TagI32 $+            WasmExpr $+              ptr_instr+                `WasmConcat` WasmLoad+                  TagI32+                  (wasmMemoryNarrowing TagI32 (cmmBits w0))+                  Signed+                  o+                  align+  | w0 > w1 =+      SomeWasmExpr TagI32+        <$> lower_CmmLoad_Typed+          lbl+          ptr+          TagI32+          (cmmBits w1)+          align+lower_MO_SS_Conv lbl w0 W64 [CmmLoad ptr _ align] = do+  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr $+        ptr_instr+          `WasmConcat` WasmLoad+            TagI64+            (wasmMemoryNarrowing TagI64 (cmmBits w0))+            Signed+            o+            align+lower_MO_SS_Conv lbl w0 w1 [x]+  | w0 < w1,+    w1 <= W32 = do+      x_expr <- lower_CmmExpr_Typed lbl TagI32 x+      pure $+        SomeWasmExpr TagI32 $+          truncSubword w1 TagI32 $+            extendSubword w0 TagI32 x_expr+  | W32 >= w0,+    w0 > w1 = do+      x_expr <- lower_CmmExpr_Typed lbl TagI32 x+      pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr+lower_MO_SS_Conv lbl W32 W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr $+        x_instr `WasmConcat` WasmI64ExtendI32 Signed+lower_MO_SS_Conv lbl w0 W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagI64 $+      extendSubword w0 TagI64 $+        WasmExpr $+          x_instr `WasmConcat` WasmI64ExtendI32 Unsigned+lower_MO_SS_Conv lbl W64 w1 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x+  pure $+    SomeWasmExpr TagI32 $+      truncSubword w1 TagI32 $+        WasmExpr $+          x_instr `WasmConcat` WasmI32WrapI64+lower_MO_SS_Conv _ _ _ _ = panic "lower_MO_SS_Conv: unreachable"++-- | Lower a 'MO_UU_Conv' operation.+lower_MO_UU_Conv ::+  CLabel ->+  Width ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_UU_Conv lbl w0 w1 [CmmLoad ptr _ align] =+  case someWasmTypeFromCmmType (cmmBits w1) of+    SomeWasmType ty ->+      SomeWasmExpr ty+        <$> lower_CmmLoad_Typed+          lbl+          ptr+          ty+          (cmmBits (min w0 w1))+          align+lower_MO_UU_Conv lbl w0 w1 [x]+  | w0 == w1 = lower_CmmExpr lbl x+  | w0 < w1, w1 <= W32 = lower_CmmExpr lbl x+  | W32 >= w0,+    w0 > w1 = do+      x_expr <- lower_CmmExpr_Typed lbl TagI32 x+      pure $ SomeWasmExpr TagI32 $ truncSubword w1 TagI32 x_expr+lower_MO_UU_Conv lbl _ W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI32 x+  pure $+    SomeWasmExpr TagI64 $+      WasmExpr $+        x_instr `WasmConcat` WasmI64ExtendI32 Unsigned+lower_MO_UU_Conv lbl W64 w1 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagI64 x+  pure $+    SomeWasmExpr TagI32 $+      truncSubword w1 TagI32 $+        WasmExpr $+          x_instr `WasmConcat` WasmI32WrapI64+lower_MO_UU_Conv _ _ _ _ = panic "lower_MO_UU_Conv: unreachable"++-- | Lower a 'MO_FF_Conv' operation.+lower_MO_FF_Conv ::+  CLabel ->+  Width ->+  Width ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_MO_FF_Conv lbl W32 W64 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF32 x+  pure $+    SomeWasmExpr TagF64 $+      WasmExpr $+        x_instr `WasmConcat` WasmF64PromoteF32+lower_MO_FF_Conv lbl W64 W32 [x] = do+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl TagF64 x+  pure $+    SomeWasmExpr TagF32 $+      WasmExpr $+        x_instr `WasmConcat` WasmF32DemoteF64+lower_MO_FF_Conv _ _ _ _ = panic "lower_MO_FF_Conv: unreachable"++-- | Lower a 'CmmMachOp'.+lower_CmmMachOp ::+  CLabel ->+  MachOp ->+  [CmmExpr] ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+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+lower_CmmMachOp lbl (MO_Ne w0) xs = lower_MO_Bin_Rel WasmNe lbl (cmmBits w0) xs+lower_CmmMachOp lbl (MO_Mul w0) xs = lower_MO_Bin_Homo_Trunc WasmMul lbl w0 xs+lower_CmmMachOp lbl (MO_S_MulMayOflo w0) xs = lower_MO_MulMayOflo lbl w0 xs+lower_CmmMachOp lbl (MO_S_Quot w0) xs =+  lower_MO_Bin_Homo_Ext_Trunc+    (WasmDiv Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Rem w0) xs =+  lower_MO_Bin_Homo_Ext_Trunc+    (WasmRem Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Neg w0) [x] =+  lower_CmmMachOp+    lbl+    (MO_Sub w0)+    [CmmLit $ CmmInt 0 w0, x]+lower_CmmMachOp lbl (MO_U_Quot w0) xs =+  lower_MO_Bin_Homo+    (WasmDiv Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_U_Rem w0) xs =+  lower_MO_Bin_Homo+    (WasmRem Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_S_Ge w0) xs =+  lower_MO_Bin_Rel_Ext+    (WasmGe Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Le w0) xs =+  lower_MO_Bin_Rel_Ext+    (WasmLe Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Gt w0) xs =+  lower_MO_Bin_Rel_Ext+    (WasmGt Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_S_Lt w0) xs =+  lower_MO_Bin_Rel_Ext+    (WasmLt Signed)+    lbl+    w0+    xs+lower_CmmMachOp lbl (MO_U_Ge w0) xs =+  lower_MO_Bin_Rel+    (WasmGe Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_U_Le w0) xs =+  lower_MO_Bin_Rel+    (WasmLe Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_U_Gt w0) xs =+  lower_MO_Bin_Rel+    (WasmGt Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_U_Lt w0) xs =+  lower_MO_Bin_Rel+    (WasmLt Unsigned)+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_F_Add w0) xs =+  lower_MO_Bin_Homo+    WasmAdd+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Sub w0) xs =+  lower_MO_Bin_Homo+    WasmSub+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Neg w0) [x] =+  lower_CmmMachOp+    lbl+    (MO_F_Sub w0)+    [CmmLit $ CmmFloat 0 w0, x]+lower_CmmMachOp lbl (MO_F_Mul w0) xs =+  lower_MO_Bin_Homo+    WasmMul+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Quot w0) xs =+  lower_MO_Bin_Homo+    (WasmDiv Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Eq w0) xs =+  lower_MO_Bin_Rel+    WasmEq+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Ne w0) xs =+  lower_MO_Bin_Rel+    WasmNe+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Ge w0) xs =+  lower_MO_Bin_Rel+    (WasmGe Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Le w0) xs =+  lower_MO_Bin_Rel+    (WasmLe Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Gt w0) xs =+  lower_MO_Bin_Rel+    (WasmGt Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_F_Lt w0) xs =+  lower_MO_Bin_Rel+    (WasmLt Signed)+    lbl+    (cmmFloat w0)+    xs+lower_CmmMachOp lbl (MO_And w0) xs =+  lower_MO_Bin_Homo+    WasmAnd+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_Or w0) xs = lower_MO_Bin_Homo WasmOr lbl (cmmBits w0) xs+lower_CmmMachOp lbl (MO_Xor w0) xs =+  lower_MO_Bin_Homo+    WasmXor+    lbl+    (cmmBits w0)+    xs+lower_CmmMachOp lbl (MO_Not w0) [x] =+  lower_CmmMachOp+    lbl+    (MO_Xor w0)+    [x, CmmLit $ CmmInt (widthMax w0) w0]+lower_CmmMachOp lbl (MO_Shl w0) xs = lower_MO_Shl lbl w0 xs+lower_CmmMachOp lbl (MO_U_Shr w0) xs = lower_MO_U_Shr lbl w0 xs+lower_CmmMachOp lbl (MO_S_Shr w0) xs = lower_MO_S_Shr lbl w0 xs+lower_CmmMachOp lbl (MO_SF_Conv w0 w1) xs =+  lower_MO_Un_Conv+    (WasmConvert Signed)+    lbl+    (cmmBits w0)+    (cmmFloat w1)+    xs+lower_CmmMachOp lbl (MO_FS_Conv w0 w1) xs =+  lower_MO_Un_Conv+    (WasmTruncSat Signed)+    lbl+    (cmmFloat w0)+    (cmmBits w1)+    xs+lower_CmmMachOp lbl (MO_SS_Conv w0 w1) xs = lower_MO_SS_Conv lbl w0 w1 xs+lower_CmmMachOp lbl (MO_UU_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs+lower_CmmMachOp lbl (MO_XX_Conv w0 w1) xs = lower_MO_UU_Conv lbl w0 w1 xs+lower_CmmMachOp lbl (MO_FF_Conv w0 w1) xs = lower_MO_FF_Conv lbl w0 w1 xs+lower_CmmMachOp _ _ _ = panic "lower_CmmMachOp: unreachable"++-- | Lower a 'CmmLit'. Note that we don't emit 'f32.const' or+-- 'f64.const' for the time being, and instead emit their relative bit+-- pattern as int literals, then use an reinterpret cast. This is+-- simpler than dealing with textual representation of floating point+-- values.+lower_CmmLit :: CmmLit -> WasmCodeGenM w (SomeWasmExpr w)+lower_CmmLit lit = do+  ty_word <- wasmWordTypeM+  case lit of+    CmmInt i w -> case someWasmTypeFromCmmType (cmmBits w) of+      SomeWasmType ty ->+        pure $+          SomeWasmExpr ty $+            WasmExpr $+              WasmConst ty $+                naturalNarrowing w i+    CmmFloat f W32 ->+      pure $+        SomeWasmExpr TagF32 $+          WasmExpr $+            WasmConst+              TagI32+              (toInteger $ castFloatToWord32 $ fromRational f)+              `WasmConcat` WasmReinterpret TagI32 TagF32+    CmmFloat f W64 ->+      pure $+        SomeWasmExpr TagF64 $+          WasmExpr $+            WasmConst+              TagI64+              (toInteger $ castDoubleToWord64 $ fromRational f)+              `WasmConcat` WasmReinterpret TagI64 TagF64+    CmmLabel lbl' -> do+      onAnySym lbl'+      let sym = symNameFromCLabel lbl'+      pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst sym+    CmmLabelOff lbl' o -> do+      onAnySym lbl'+      let sym = symNameFromCLabel lbl'+      pure $+        SomeWasmExpr ty_word $+          WasmExpr $+            WasmSymConst sym+              `WasmConcat` WasmConst ty_word (toInteger o)+              `WasmConcat` WasmAdd ty_word+    _ -> panic "lower_CmmLit: unreachable"++--  | Lower a 'CmmReg'. Some of the logic here wouldn't be needed if+--  we have run 'fixStgRegisters' on the wasm NCG's input Cmm, but we+--  haven't run it yet for certain reasons.+lower_CmmReg :: CLabel -> CmmReg -> WasmCodeGenM w (SomeWasmExpr w)+lower_CmmReg _ (CmmLocal reg) = do+  (reg_i, SomeWasmType ty) <- onCmmLocalReg reg+  pure $ SomeWasmExpr ty $ WasmExpr $ WasmLocalGet ty reg_i+lower_CmmReg _ (CmmGlobal EagerBlackholeInfo) = do+  ty_word <- wasmWordTypeM+  pure $+    SomeWasmExpr ty_word $+      WasmExpr $+        WasmSymConst "stg_EAGER_BLACKHOLE_info"+lower_CmmReg _ (CmmGlobal GCEnter1) = do+  ty_word <- wasmWordTypeM+  ty_word_cmm <- wasmWordCmmTypeM+  onFuncSym "__stg_gc_enter_1" [] [ty_word_cmm]+  pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_enter_1"+lower_CmmReg _ (CmmGlobal GCFun) = do+  ty_word <- wasmWordTypeM+  ty_word_cmm <- wasmWordCmmTypeM+  onFuncSym "__stg_gc_fun" [] [ty_word_cmm]+  pure $ SomeWasmExpr ty_word $ WasmExpr $ WasmSymConst "__stg_gc_fun"+lower_CmmReg lbl (CmmGlobal BaseReg) = do+  platform <- wasmPlatformM+  lower_CmmExpr lbl $ regTableOffset platform 0+lower_CmmReg lbl (CmmGlobal reg) = do+  ty_word <- wasmWordTypeM+  if+      | Just (sym_global, SomeWasmType ty) <-+          globalInfoFromCmmGlobalReg ty_word reg ->+          pure $ SomeWasmExpr ty $ WasmExpr $ WasmGlobalGet ty sym_global+      | otherwise -> do+          platform <- wasmPlatformM+          case someWasmTypeFromCmmType $ globalRegType platform reg of+            SomeWasmType ty -> do+              (WasmExpr ptr_instr, o) <-+                lower_CmmExpr_Ptr lbl $+                  get_GlobalReg_addr platform reg+              pure $+                SomeWasmExpr ty $+                  WasmExpr $+                    ptr_instr+                      `WasmConcat` WasmLoad+                        ty+                        Nothing+                        Unsigned+                        o+                        NaturallyAligned++-- | Lower a 'CmmRegOff'.+lower_CmmRegOff :: CLabel -> CmmReg -> Int -> WasmCodeGenM w (SomeWasmExpr w)+lower_CmmRegOff lbl reg 0 = lower_CmmReg lbl reg+lower_CmmRegOff lbl reg o = do+  SomeWasmExpr ty (WasmExpr reg_instr) <- lower_CmmReg lbl reg+  pure $+    SomeWasmExpr ty $+      WasmExpr $+        reg_instr+          `WasmConcat` WasmConst+            ty+            (toInteger o)+          `WasmConcat` WasmAdd ty++-- | Lower a 'CmmLoad', passing in the expected wasm representation+-- type, and also the Cmm type (which contains width info needed for+-- memory narrowing).+--+-- The Cmm type system doesn't track signedness, so all 'CmmLoad's are+-- unsigned loads. However, as an optimization, we do emit signed+-- loads when a 'CmmLoad' result is immediately used as a 'MO_SS_Conv'+-- operand.+lower_CmmLoad_Typed ::+  CLabel ->+  CmmExpr ->+  WasmTypeTag t ->+  CmmType ->+  AlignmentSpec ->+  WasmCodeGenM w (WasmExpr w t)+lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align = do+  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr_expr+  pure $+    WasmExpr $+      ptr_instr+        `WasmConcat` WasmLoad+          ty+          (wasmMemoryNarrowing ty ty_cmm)+          Unsigned+          o+          align++-- | Lower a 'CmmLoad'.+lower_CmmLoad ::+  CLabel ->+  CmmExpr ->+  CmmType ->+  AlignmentSpec ->+  WasmCodeGenM+    w+    (SomeWasmExpr w)+lower_CmmLoad lbl ptr_expr ty_cmm align = case someWasmTypeFromCmmType ty_cmm of+  SomeWasmType ty ->+    SomeWasmExpr ty <$> lower_CmmLoad_Typed lbl ptr_expr ty ty_cmm align++-- | Lower a 'CmmExpr'.+lower_CmmExpr :: CLabel -> CmmExpr -> WasmCodeGenM w (SomeWasmExpr w)+lower_CmmExpr lbl expr = case expr of+  CmmLit lit -> lower_CmmLit lit+  CmmLoad ptr_expr ty_cmm align -> lower_CmmLoad lbl ptr_expr ty_cmm align+  CmmReg reg -> lower_CmmReg lbl reg+  CmmRegOff reg o -> lower_CmmRegOff lbl reg o+  CmmMachOp op xs -> lower_CmmMachOp lbl op xs+  _ -> panic "lower_CmmExpr: unreachable"++-- | Lower a 'CmmExpr', passing in the expected wasm representation+-- type.+lower_CmmExpr_Typed ::+  CLabel ->+  WasmTypeTag t ->+  CmmExpr ->+  WasmCodeGenM+    w+    (WasmExpr w t)+lower_CmmExpr_Typed lbl ty expr = do+  SomeWasmExpr ty' r <- lower_CmmExpr lbl expr+  if+      | Just Refl <- ty' `testEquality` ty -> pure r+      | otherwise -> panic "lower_CmmExpr_Typed: unreachable"++-- | Lower a 'CmmExpr' as a pointer, returning the pair of base+-- pointer and non-negative offset.+lower_CmmExpr_Ptr :: CLabel -> CmmExpr -> WasmCodeGenM w (WasmExpr w w, Int)+lower_CmmExpr_Ptr lbl ptr = do+  ty_word <- wasmWordTypeM+  case ptr of+    CmmLit (CmmLabelOff lbl o)+      | o >= 0 -> do+          instrs <-+            lower_CmmExpr_Typed+              lbl+              ty_word+              (CmmLit $ CmmLabel lbl)+          pure (instrs, o)+    CmmMachOp (MO_Add _) [base, CmmLit (CmmInt o _)]+      | o >= 0 -> do+          instrs <- lower_CmmExpr_Typed lbl ty_word base+          pure (instrs, fromInteger o)+    _ -> do+      instrs <- lower_CmmExpr_Typed lbl ty_word ptr+      pure (instrs, 0)++-- | Push a series of values onto the wasm value stack, returning the+-- result stack type.+type family+  WasmPushes (ts :: [WasmType]) (pre :: [WasmType]) ::+    [WasmType]+  where+  WasmPushes '[] pre = pre+  WasmPushes (t : ts) pre = WasmPushes ts (t : pre)++-- | Push the arguments onto the wasm value stack before a ccall.+data SomeWasmPreCCall w where+  SomeWasmPreCCall ::+    TypeList ts ->+    (forall pre. WasmInstr w pre (WasmPushes ts pre)) ->+    SomeWasmPreCCall w++-- | Pop the results into locals after a ccall.+data SomeWasmPostCCall w where+  SomeWasmPostCCall ::+    TypeList ts ->+    (forall post. WasmInstr w (WasmPushes ts post) post) ->+    SomeWasmPostCCall w++-- | Lower an unary homogeneous 'CallishMachOp' to a ccall.+lower_CMO_Un_Homo ::+  CLabel ->+  SymName ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CMO_Un_Homo lbl op [reg] [x] = do+  (ri, SomeWasmType ty) <- onCmmLocalReg reg+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+  let ty_cmm = localRegType reg+  onFuncSym op [ty_cmm] [ty_cmm]+  pure $+    WasmStatements $+      x_instr `WasmConcat` WasmCCall op `WasmConcat` WasmLocalSet ty ri+lower_CMO_Un_Homo _ _ _ _ = panic "lower_CMO_Un_Homo: unreachable"++-- | Lower an unary homogeneous 'CallishMachOp' to inline assembly.+lower_CMO_Un_Prim ::+  CLabel ->+  (forall pre t. WasmTypeTag t -> WasmInstr w (t : pre) (t : pre)) ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CMO_Un_Prim lbl op [reg] [x] = do+  (ri, SomeWasmType ty) <- onCmmLocalReg reg+  SomeWasmExpr ty_x (WasmExpr x_instr) <- lower_CmmExpr lbl x+  if+      | Just Refl <- ty `testEquality` ty_x ->+          pure $+            WasmStatements $+              x_instr `WasmConcat` op ty_x `WasmConcat` WasmLocalSet ty ri+      | TagI32 <- ty,+        TagI64 <-+          ty_x ->+          pure $+            WasmStatements $+              x_instr+                `WasmConcat` op ty_x+                `WasmConcat` WasmI32WrapI64+                `WasmConcat` WasmLocalSet ty ri+      | otherwise -> panic "lower_CMO_Un_Prim: unreachable"+lower_CMO_Un_Prim _ _ _ _ = panic "lower_CMO_Un_Prim: unreachable"++-- | Lower a binary homogeneous 'CallishMachOp' to a ccall.+lower_CMO_Bin_Homo ::+  CLabel ->+  SymName ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CMO_Bin_Homo lbl op [reg] [x, y] = do+  (ri, SomeWasmType ty) <- onCmmLocalReg reg+  WasmExpr x_instr <- lower_CmmExpr_Typed lbl ty x+  WasmExpr y_instr <- lower_CmmExpr_Typed lbl ty y+  let ty_cmm = localRegType reg+  onFuncSym op [ty_cmm, ty_cmm] [ty_cmm]+  pure $+    WasmStatements $+      x_instr+        `WasmConcat` y_instr+        `WasmConcat` WasmCCall op+        `WasmConcat` WasmLocalSet ty ri+lower_CMO_Bin_Homo _ _ _ _ = panic "lower_CMO_Bin_Homo: unreachable"++-- | Lower a 'MO_UF_Conv' operation.+lower_MO_UF_Conv ::+  CLabel ->+  Width ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_MO_UF_Conv lbl W32 [reg] [x] = do+  ri <- onCmmLocalReg_Typed TagF32 reg+  SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x+  pure $+    WasmStatements $+      x_instr+        `WasmConcat` WasmConvert Unsigned ty0 TagF32+        `WasmConcat` WasmLocalSet TagF32 ri+lower_MO_UF_Conv lbl W64 [reg] [x] = do+  ri <- onCmmLocalReg_Typed TagF64 reg+  SomeWasmExpr ty0 (WasmExpr x_instr) <- lower_CmmExpr lbl x+  pure $+    WasmStatements $+      x_instr+        `WasmConcat` WasmConvert Unsigned ty0 TagF64+        `WasmConcat` WasmLocalSet TagF64 ri+lower_MO_UF_Conv _ _ _ _ = panic "lower_MO_UF_Conv: unreachable"++-- | Lower a 'MO_Cmpxchg' operation to inline assembly. Currently we+-- target wasm without atomics and threads, so it's just lowered to+-- regular memory loads and stores.+lower_MO_Cmpxchg ::+  CLabel ->+  Width ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_MO_Cmpxchg lbl w0 [reg] [ptr, expected, new] =+  case someWasmTypeFromCmmType ty_cmm of+    SomeWasmType ty -> do+      reg_i <- onCmmLocalReg_Typed ty reg+      let narrowing = wasmMemoryNarrowing ty ty_cmm+      (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr+      WasmExpr expected_instr <- lower_CmmExpr_Typed lbl ty expected+      WasmExpr new_instr <- lower_CmmExpr_Typed lbl ty new+      pure $+        WasmStatements $+          ptr_instr+            `WasmConcat` WasmLoad ty narrowing Unsigned o NaturallyAligned+            `WasmConcat` WasmLocalTee ty reg_i+            `WasmConcat` expected_instr+            `WasmConcat` WasmEq ty+            `WasmConcat` WasmCond+              ( ptr_instr+                  `WasmConcat` new_instr+                  `WasmConcat` WasmStore ty narrowing o NaturallyAligned+              )+  where+    ty_cmm = cmmBits w0+lower_MO_Cmpxchg _ _ _ _ = panic "lower_MO_Cmpxchg: unreachable"++-- | Lower a 'CallishMachOp'.+lower_CallishMachOp ::+  CLabel ->+  CallishMachOp ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CallishMachOp lbl MO_F64_Pwr rs xs = lower_CMO_Bin_Homo lbl "pow" rs xs+lower_CallishMachOp lbl MO_F64_Sin rs xs = lower_CMO_Un_Homo lbl "sin" rs xs+lower_CallishMachOp lbl MO_F64_Cos rs xs = lower_CMO_Un_Homo lbl "cos" rs xs+lower_CallishMachOp lbl MO_F64_Tan rs xs = lower_CMO_Un_Homo lbl "tan" rs xs+lower_CallishMachOp lbl MO_F64_Sinh rs xs = lower_CMO_Un_Homo lbl "sinh" rs xs+lower_CallishMachOp lbl MO_F64_Cosh rs xs = lower_CMO_Un_Homo lbl "cosh" rs xs+lower_CallishMachOp lbl MO_F64_Tanh rs xs = lower_CMO_Un_Homo lbl "tanh" rs xs+lower_CallishMachOp lbl MO_F64_Asin rs xs = lower_CMO_Un_Homo lbl "asin" rs xs+lower_CallishMachOp lbl MO_F64_Acos rs xs = lower_CMO_Un_Homo lbl "acos" rs xs+lower_CallishMachOp lbl MO_F64_Atan rs xs = lower_CMO_Un_Homo lbl "atan" rs xs+lower_CallishMachOp lbl MO_F64_Asinh rs xs = lower_CMO_Un_Homo lbl "asinh" rs xs+lower_CallishMachOp lbl MO_F64_Acosh rs xs = lower_CMO_Un_Homo lbl "acosh" rs xs+lower_CallishMachOp lbl MO_F64_Atanh rs xs = lower_CMO_Un_Homo lbl "atanh" rs xs+lower_CallishMachOp lbl MO_F64_Log rs xs = lower_CMO_Un_Homo lbl "log" rs xs+lower_CallishMachOp lbl MO_F64_Log1P rs xs = lower_CMO_Un_Homo lbl "log1p" rs xs+lower_CallishMachOp lbl MO_F64_Exp rs xs = lower_CMO_Un_Homo lbl "exp" rs xs+lower_CallishMachOp lbl MO_F64_ExpM1 rs xs = lower_CMO_Un_Homo lbl "expm1" rs xs+lower_CallishMachOp lbl MO_F64_Fabs rs xs = lower_CMO_Un_Homo lbl "fabs" rs xs+lower_CallishMachOp lbl MO_F64_Sqrt rs xs = lower_CMO_Un_Homo lbl "sqrt" rs xs+lower_CallishMachOp lbl MO_F32_Pwr rs xs = lower_CMO_Bin_Homo lbl "powf" rs xs+lower_CallishMachOp lbl MO_F32_Sin rs xs = lower_CMO_Un_Homo lbl "sinf" rs xs+lower_CallishMachOp lbl MO_F32_Cos rs xs = lower_CMO_Un_Homo lbl "cosf" rs xs+lower_CallishMachOp lbl MO_F32_Tan rs xs = lower_CMO_Un_Homo lbl "tanf" rs xs+lower_CallishMachOp lbl MO_F32_Sinh rs xs = lower_CMO_Un_Homo lbl "sinhf" rs xs+lower_CallishMachOp lbl MO_F32_Cosh rs xs = lower_CMO_Un_Homo lbl "coshf" rs xs+lower_CallishMachOp lbl MO_F32_Tanh rs xs = lower_CMO_Un_Homo lbl "tanhf" rs xs+lower_CallishMachOp lbl MO_F32_Asin rs xs = lower_CMO_Un_Homo lbl "asinf" rs xs+lower_CallishMachOp lbl MO_F32_Acos rs xs = lower_CMO_Un_Homo lbl "acosf" rs xs+lower_CallishMachOp lbl MO_F32_Atan rs xs = lower_CMO_Un_Homo lbl "atanf" rs xs+lower_CallishMachOp lbl MO_F32_Asinh rs xs =+  lower_CMO_Un_Homo lbl "asinhf" rs xs+lower_CallishMachOp lbl MO_F32_Acosh rs xs =+  lower_CMO_Un_Homo lbl "acoshf" rs xs+lower_CallishMachOp lbl MO_F32_Atanh rs xs =+  lower_CMO_Un_Homo lbl "atanhf" rs xs+lower_CallishMachOp lbl MO_F32_Log rs xs = lower_CMO_Un_Homo lbl "logf" rs xs+lower_CallishMachOp lbl MO_F32_Log1P rs xs =+  lower_CMO_Un_Homo lbl "log1pf" rs xs+lower_CallishMachOp lbl MO_F32_Exp rs xs = lower_CMO_Un_Homo lbl "expf" rs xs+lower_CallishMachOp lbl MO_F32_ExpM1 rs xs =+  lower_CMO_Un_Homo lbl "expm1f" rs xs+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_Touch _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp _ (MO_Prefetch_Data {}) _ _ = pure $ WasmStatements WasmNop+lower_CallishMachOp lbl (MO_Memcpy {}) [] xs = do+  ty_word_cmm <- wasmWordCmmTypeM+  lower_CmmUnsafeForeignCall_Drop lbl "memcpy" ty_word_cmm xs+lower_CallishMachOp lbl (MO_Memset {}) [] xs = do+  ty_word_cmm <- wasmWordCmmTypeM+  lower_CmmUnsafeForeignCall_Drop lbl "memset" ty_word_cmm xs+lower_CallishMachOp lbl (MO_Memmove {}) [] xs = do+  ty_word_cmm <- wasmWordCmmTypeM+  lower_CmmUnsafeForeignCall_Drop lbl "memmove" ty_word_cmm xs+lower_CallishMachOp lbl (MO_Memcmp {}) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left "memcmp")+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_PopCnt w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_popcnt" <> show (widthInBits w0))+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Pdep w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_pdep" <> show (widthInBits w0))+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Pext w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_pext" <> show (widthInBits w0))+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Clz w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_clz" <> show (widthInBits w0))+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_Ctz w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_ctz" <> show (widthInBits w0))+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_BSwap w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_bswap" <> show (widthInBits w0))+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_BRev w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_bitrev" <> show (widthInBits w0))+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_AtomicRMW w0 op) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    ( Left $+        fromString $+          ( case op of+              AMO_Add -> "hs_atomic_add"+              AMO_Sub -> "hs_atomic_sub"+              AMO_And -> "hs_atomic_and"+              AMO_Nand -> "hs_atomic_nand"+              AMO_Or -> "hs_atomic_or"+              AMO_Xor -> "hs_atomic_xor"+          )+            <> show (widthInBits w0)+    )+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl (MO_AtomicRead w0) [reg] [ptr] = do+  SomeWasmExpr ty (WasmExpr ret_instr) <-+    lower_CmmLoad+      lbl+      ptr+      (cmmBits w0)+      NaturallyAligned+  ri <- onCmmLocalReg_Typed ty reg+  pure $ WasmStatements $ ret_instr `WasmConcat` WasmLocalSet ty ri+lower_CallishMachOp lbl (MO_AtomicWrite _) [] [ptr, val] =+  lower_CmmStore lbl ptr val NaturallyAligned+lower_CallishMachOp lbl (MO_Cmpxchg w0) rs xs = lower_MO_Cmpxchg lbl w0 rs xs+lower_CallishMachOp lbl (MO_Xchg w0) rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left $ fromString $ "hs_xchg" <> show (widthInBits w0))+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl MO_SuspendThread rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left "suspendThread")+    CmmMayReturn+    rs+    xs+lower_CallishMachOp lbl MO_ResumeThread rs xs =+  lower_CmmUnsafeForeignCall+    lbl+    (Left "resumeThread")+    CmmMayReturn+    rs+    xs+lower_CallishMachOp _ _ _ _ = panic "lower_CallishMachOp: unreachable"++-- | Lower a ccall, but drop the result by assigning it to an unused+-- local. This is only used for lowering 'MO_Memcpy' and such, where+-- the libc functions do have a return value, but the corresponding+-- 'CallishMachOp' does not expect one.+lower_CmmUnsafeForeignCall_Drop ::+  CLabel ->+  SymName ->+  CmmType ->+  [CmmActual] ->+  WasmCodeGenM w (WasmStatements w)+lower_CmmUnsafeForeignCall_Drop lbl sym_callee ret_cmm_ty arg_exprs = do+  ret_uniq <- wasmUniq+  let ret_local = LocalReg ret_uniq ret_cmm_ty+  lower_CmmUnsafeForeignCall+    lbl+    (Left sym_callee)+    CmmMayReturn+    [ret_local]+    arg_exprs++-- | Lower a 'CmmUnsafeForeignCall'. The target is 'Either' a symbol,+-- which translates to a direct @call@, or an expression, which+-- translates to a @call_indirect@. The callee function signature is+-- inferred from the passed in arguments here.+lower_CmmUnsafeForeignCall ::+  CLabel ->+  (Either SymName CmmExpr) ->+  CmmReturnInfo ->+  [CmmFormal] ->+  [CmmActual] ->+  WasmCodeGenM+    w+    (WasmStatements w)+lower_CmmUnsafeForeignCall lbl target ret_info ret_locals arg_exprs = do+  SomeWasmPreCCall arg_tys args_instr <-+    foldrM+      ( \arg_expr (SomeWasmPreCCall acc_tys acc_instr) -> do+          SomeWasmExpr arg_ty (WasmExpr arg_instr) <-+            lower_CmmExpr lbl arg_expr+          pure $+            SomeWasmPreCCall (arg_ty `TypeListCons` acc_tys) $+              arg_instr `WasmConcat` acc_instr+      )+      (SomeWasmPreCCall TypeListNil WasmNop)+      arg_exprs+  SomeWasmPostCCall ret_tys ret_instr <-+    foldrM+      ( \reg (SomeWasmPostCCall acc_tys acc_instr) -> do+          (reg_i, SomeWasmType reg_ty) <- onCmmLocalReg reg+          pure $+            SomeWasmPostCCall (reg_ty `TypeListCons` acc_tys) $+              acc_instr `WasmConcat` WasmLocalSet reg_ty reg_i+      )+      (SomeWasmPostCCall TypeListNil WasmNop)+      ret_locals+  case target of+    Left sym_callee -> do+      platform <- wasmPlatformM+      let arg_cmm_tys = map (cmmExprType platform) arg_exprs+          ret_cmm_tys = map localRegType ret_locals+      onFuncSym sym_callee arg_cmm_tys ret_cmm_tys+      pure $+        WasmStatements $+          args_instr+            `WasmConcat` WasmCCall sym_callee+            `WasmConcat` ( case ret_info of+                             CmmMayReturn -> ret_instr+                             CmmNeverReturns -> WasmUnreachable+                         )+    Right fptr_callee -> do+      (WasmExpr instr_callee, _) <- lower_CmmExpr_Ptr lbl fptr_callee+      pure $+        WasmStatements $+          args_instr+            `WasmConcat` instr_callee+            `WasmConcat` WasmCCallIndirect arg_tys ret_tys+            `WasmConcat` ( case ret_info of+                             CmmMayReturn -> ret_instr+                             CmmNeverReturns -> WasmUnreachable+                         )++-- | Lower a 'CmmStore'.+lower_CmmStore ::+  CLabel ->+  CmmExpr ->+  CmmExpr ->+  AlignmentSpec ->+  WasmCodeGenM+    w+    (WasmStatements w)+lower_CmmStore lbl ptr val align = do+  platform <- wasmPlatformM+  (WasmExpr ptr_instr, o) <- lower_CmmExpr_Ptr lbl ptr+  let ty_cmm = cmmExprType platform val+  SomeWasmExpr ty (WasmExpr val_instr) <- lower_CmmExpr lbl val+  pure $+    WasmStatements $+      ptr_instr+        `WasmConcat` val_instr+        `WasmConcat` WasmStore ty (wasmMemoryNarrowing ty ty_cmm) o align++-- | Lower a single Cmm action.+lower_CmmAction :: CLabel -> CmmNode O O -> WasmCodeGenM w (WasmStatements w)+lower_CmmAction lbl act = do+  ty_word <- wasmWordTypeM+  platform <- wasmPlatformM+  case act of+    CmmComment {} -> pure $ WasmStatements WasmNop+    CmmTick {} -> pure $ WasmStatements WasmNop+    CmmUnwind {} -> pure $ WasmStatements WasmNop+    CmmAssign (CmmLocal reg) e -> do+      (i, SomeWasmType ty_reg) <- onCmmLocalReg reg+      WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e+      pure $ WasmStatements $ instrs `WasmConcat` WasmLocalSet ty_reg i+    CmmAssign (CmmGlobal reg) e+      | BaseReg <- reg -> pure $ WasmStatements WasmNop+      | Just (sym_global, SomeWasmType ty_reg) <-+          globalInfoFromCmmGlobalReg ty_word reg -> do+          WasmExpr instrs <- lower_CmmExpr_Typed lbl ty_reg e+          pure $+            WasmStatements $+              instrs `WasmConcat` WasmGlobalSet ty_reg sym_global+      | otherwise -> do+          (WasmExpr ptr_instr, o) <-+            lower_CmmExpr_Ptr lbl $ get_GlobalReg_addr platform reg+          SomeWasmExpr ty_e (WasmExpr instrs) <- lower_CmmExpr lbl e+          pure $+            WasmStatements $+              ptr_instr+                `WasmConcat` instrs+                `WasmConcat` WasmStore ty_e Nothing o NaturallyAligned+    CmmStore ptr val align -> lower_CmmStore lbl ptr val align+    CmmUnsafeForeignCall+      ( ForeignTarget+          (CmmLit (CmmLabel lbl_callee))+          (ForeignConvention conv _ _ ret_info)+        )+      ret_locals+      arg_exprs+        | conv `elem` [CCallConv, CApiConv] ->+            lower_CmmUnsafeForeignCall+              lbl+              (Left $ symNameFromCLabel lbl_callee)+              ret_info+              ret_locals+              arg_exprs+    CmmUnsafeForeignCall+      (ForeignTarget target_expr (ForeignConvention conv _ _ ret_info))+      ret_locals+      arg_exprs+        | conv `elem` [CCallConv, CApiConv] ->+            lower_CmmUnsafeForeignCall+              lbl+              (Right target_expr)+              ret_info+              ret_locals+              arg_exprs+    CmmUnsafeForeignCall (PrimTarget op) ret_locals arg_exprs ->+      lower_CallishMachOp lbl op ret_locals arg_exprs+    _ -> panic "lower_CmmAction: unreachable"++-- | Lower a block of Cmm actions.+lower_CmmActions ::+  CLabel ->+  Label ->+  Block CmmNode O O ->+  WasmCodeGenM+    w+    (WasmStatements w)+lower_CmmActions lbl _ blk =+  foldlM+    ( \(WasmStatements acc) act ->+        (\(WasmStatements stmts) -> WasmStatements $ acc `WasmConcat` stmts)+          <$> lower_CmmAction lbl act+    )+    (WasmStatements WasmNop)+    acts+  where+    acts = blockToList blk++-- | Lower a 'CmmGraph'.+lower_CmmGraph :: CLabel -> CmmGraph -> WasmCodeGenM w (FuncBody w)+lower_CmmGraph lbl g = do+  ty_word <- wasmWordTypeM+  platform <- wasmPlatformM+  body <-+    structuredControl+      platform+      (\_ -> lower_CmmExpr_Typed lbl ty_word)+      (lower_CmmActions lbl)+      g+  locals <- wasmStateM $ \s ->+    (#+      map snd $ detEltsUFM $ localRegs s,+      s {localRegs = emptyUFM, localRegsCount = 0}+    #)+  pure FuncBody {funcLocals = locals, funcBody = wasmControlCast $ body}++-- | Invoked once for each 'CLabel' which indexes a 'CmmData' or+-- 'CmmProc'.+onTopSym :: CLabel -> WasmCodeGenM w ()+onTopSym lbl = case sym_vis of+  SymDefault -> wasmModifyM $ \s ->+    s+      { defaultSyms =+          IS.insert+            (getKey $ getUnique sym)+            $ defaultSyms s+      }+  _ -> pure ()+  where+    sym = symNameFromCLabel lbl++    sym_vis = symVisibilityFromCLabel lbl++-- | Invoked for each function 'CLabel' with known type (e.g. a+-- 'CmmProc', or callee of 'CmmUnsafeForeignCall').+onFuncSym :: SymName -> [CmmType] -> [CmmType] -> WasmCodeGenM w ()+onFuncSym sym arg_tys ret_tys = wasmModifyM $+  \s@WasmCodeGenState {..} ->+    s+      { funcTypes =+          addToUniqMap+            funcTypes+            sym+            ( map someWasmTypeFromCmmType arg_tys,+              map someWasmTypeFromCmmType ret_tys+            )+      }++-- | Invoked for all other 'CLabel's along the way, e.g. in+-- 'CmmStatic's or 'CmmExpr's.+onAnySym :: CLabel -> WasmCodeGenM w ()+onAnySym lbl = case sym_kind of+  SymFunc -> wasmModifyM $ \s@WasmCodeGenState {..} ->+    s {funcTypes = addToUniqMap_C const funcTypes sym ([], [])}+  _ -> pure ()+  where+    sym = symNameFromCLabel lbl++    sym_kind = symKindFromCLabel lbl++-- | Invoked for each 'LocalReg', returning its wasm local id and+-- representation type.+onCmmLocalReg :: LocalReg -> WasmCodeGenM w LocalInfo+onCmmLocalReg reg = wasmStateM $ \s@WasmCodeGenState {..} ->+  let reg_info =+        (localRegsCount, someWasmTypeFromCmmType $ localRegType reg)+   in case addToUFM_L (\_ i _ -> i) reg reg_info localRegs of+        (Just i, _) -> (# i, s #)+        (_, localRegs') ->+          (#+            reg_info,+            s+              { localRegs = localRegs',+                localRegsCount =+                  localRegsCount + 1+              }+          #)++-- | Invoked for each 'LocalReg' with expected representation type,+-- only returning its wasm local id.+onCmmLocalReg_Typed :: WasmTypeTag t -> LocalReg -> WasmCodeGenM w Int+onCmmLocalReg_Typed ty reg = do+  (i, SomeWasmType ty') <- onCmmLocalReg reg+  if+      | Just Refl <- ty' `testEquality` ty -> pure i+      | otherwise -> panic "onCmmLocalReg_Typed: unreachable"++-- | Invoked for dtors. We don't bother to implement dtors yet;+-- there's no native @.fini_array@ support for wasm, and the way+-- @clang@ handles dtors is generating a ctor that calls @atexit()@+-- for dtors. Which makes some sense, but we don't need to do the same+-- thing yet.+onFini :: [SymName] -> WasmCodeGenM w ()+onFini syms = do+  let n_finis = length syms+  when (n_finis /= 0) $ panic "dtors unsupported by wasm32 NCG"++-- | Invoked for ctors and dtors.+onCmmInitFini :: InitOrFini -> [CLabel] -> WasmCodeGenM w ()+onCmmInitFini iof lbls = do+  for_ lbls $ \lbl -> onFuncSym (symNameFromCLabel lbl) [] []+  case iof of+    IsInitArray -> wasmModifyM $ \s -> s {ctors = syms <> ctors s}+    IsFiniArray -> onFini syms+  where+    syms = map symNameFromCLabel lbls++-- | Invoked for each data section.+onCmmData :: CLabel -> Section -> [CmmStatic] -> WasmCodeGenM w ()+onCmmData lbl s statics = do+  ty_word <- wasmWordTypeM+  onTopSym lbl+  cs <- for statics lower_CmmStatic+  let sym = symNameFromCLabel lbl+      sec =+        DataSection+          { dataSectionKind =+              dataSectionKindFromCmmSection s,+            dataSectionAlignment =+              alignmentFromCmmSection ty_word lbl,+            dataSectionContents =+              case cs of+                [DataASCII buf] -> [DataASCII $ buf `BS.snoc` 0]+                [DataIncBin p l] -> [DataIncBin p l, DataI8 0]+                _ -> cs+          }+  wasmModifyM $ \s ->+    s+      { dataSections =+          addToUniqMap (dataSections s) sym sec+      }++-- | Invoked for each 'CmmProc'.+onCmmProc :: CLabel -> CmmGraph -> WasmCodeGenM w ()+onCmmProc lbl g = do+  ty_word <- wasmWordCmmTypeM+  onTopSym lbl+  onFuncSym sym [] [ty_word]+  body <- lower_CmmGraph lbl g+  wasmModifyM $ \s -> s {funcBodies = addToUniqMap (funcBodies s) sym body}+  where+    sym = symNameFromCLabel lbl++-- | Invoked for each 'RawCmmDecl'.+onCmmDecl :: RawCmmDecl -> WasmCodeGenM w ()+onCmmDecl decl+  | Just (iof, lbls) <- isInitOrFiniArray decl = onCmmInitFini iof lbls+onCmmDecl (CmmData s (CmmStaticsRaw lbl statics)) = onCmmData lbl s statics+onCmmDecl (CmmProc _ lbl _ g) = onCmmProc lbl g++-- | Invoked for each 'RawCmmGroup'.+onCmmGroup :: RawCmmGroup -> WasmCodeGenM w ()+onCmmGroup cmms = wasmStateM $ \s0 ->+  (# (), foldl' (\s cmm -> wasmExecM (onCmmDecl cmm) s) s0 cmms #)