compiler/GHC/Builtin/primops.txt.pp

@@ -74,7 +74,7 @@
 --   2. The dummy Prim.hs file, which is used for Haddock and
 --      contains descriptions taken from primops.txt.pp.
 --      All definitions are replaced by placeholders.
---      See Note [GHC.Prim Docs] in genprimopcode.
+--      See Note [GHC.Prim Docs] in GHC.Builtin.Utils.
 --
 --   3. The module PrimopWrappers.hs, which wraps every call for GHCi;
 --      see Note [Primop wrappers] in GHC.Builtin.Primops for details.
@@ -145,7 +145,6 @@ defaults
    cheap            = { primOpOkForSpeculation _thisOp }
    strictness       = { \ arity -> mkClosedDmdSig (replicate arity topDmd) topDiv }
    fixity           = Nothing
-   llvm_only        = False
    vector           = []
    deprecated_msg   = {}      -- A non-empty message indicates deprecation
 
@@ -1094,6 +1093,22 @@ primop   DoubleLtOp "<##"   Compare   Double# -> Double# -> Int#
 primop   DoubleLeOp "<=##"   Compare   Double# -> Double# -> Int#
    with fixity = infix 4
 
+primop   DoubleMinOp   "minDouble#"      GenPrimOp
+   Double# -> Double# -> Double#
+   {Return the minimum of the arguments.
+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)
+   or one of the arguments is not-a-number (NaN),
+   it is unspecified which one is returned.}
+   with commutable = True
+
+primop   DoubleMaxOp   "maxDouble#"      GenPrimOp
+   Double# -> Double# -> Double#
+   {Return the maximum of the arguments.
+   When the arguments are numerically equal (e.g. @0.0##@ and @-0.0##@)
+   or one of the arguments is not-a-number (NaN),
+   it is unspecified which one is returned.}
+   with commutable = True
+
 primop   DoubleAddOp   "+##"   GenPrimOp
    Double# -> Double# -> Double#
    with commutable = True
@@ -1231,6 +1246,14 @@ primop   DoubleDecode_Int64Op   "decodeDouble_Int64#" GenPrimOp
    {Decode 'Double#' into mantissa and base-2 exponent.}
    with out_of_line = True
 
+primop CastDoubleToWord64Op "castDoubleToWord64#" GenPrimOp
+   Double# -> Word64#
+   {Bitcast a 'Double#' into a 'Word64#'}
+
+primop CastWord64ToDoubleOp "castWord64ToDouble#" GenPrimOp
+   Word64# -> Double#
+   {Bitcast a 'Word64#' into a 'Double#'}
+
 ------------------------------------------------------------------------
 section "Float#"
         {Operations on single-precision (32-bit) floating-point numbers.}
@@ -1252,6 +1275,22 @@ primop   FloatNeOp  "neFloat#"   Compare
 primop   FloatLtOp  "ltFloat#"   Compare   Float# -> Float# -> Int#
 primop   FloatLeOp  "leFloat#"   Compare   Float# -> Float# -> Int#
 
+primop   FloatMinOp   "minFloat#"      GenPrimOp
+   Float# -> Float# -> Float#
+   {Return the minimum of the arguments.
+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)
+   or one of the arguments is not-a-number (NaN),
+   it is unspecified which one is returned.}
+   with commutable = True
+
+primop   FloatMaxOp   "maxFloat#"      GenPrimOp
+   Float# -> Float# -> Float#
+   {Return the maximum of the arguments.
+   When the arguments are numerically equal (e.g. @0.0#@ and @-0.0#@)
+   or one of the arguments is not-a-number (NaN),
+   it is unspecified which one is returned.}
+   with commutable = True
+
 primop   FloatAddOp   "plusFloat#"      GenPrimOp
    Float# -> Float# -> Float#
    with commutable = True
@@ -1377,6 +1416,14 @@ primop   FloatDecode_IntOp   "decodeFloat_Int#" GenPrimOp
     First 'Int#' in result is the mantissa; second is the exponent.}
    with out_of_line = True
 
+primop CastFloatToWord32Op "castFloatToWord32#" GenPrimOp
+   Float# -> Word32#
+   {Bitcast a 'Float#' into a 'Word32#'}
+
+primop CastWord32ToFloatOp "castWord32ToFloat#" GenPrimOp
+   Word32# -> Float#
+   {Bitcast a 'Word32#' into a 'Float#'}
+
 ------------------------------------------------------------------------
 section "Fused multiply-add operations"
   { #fma#
@@ -1909,7 +1956,25 @@ primop  MutableByteArrayIsPinnedOp "isMutableByteArrayPinned#" GenPrimOp
 
 primop  ByteArrayIsPinnedOp "isByteArrayPinned#" GenPrimOp
    ByteArray# -> Int#
-   {Determine whether a 'ByteArray#' is guaranteed not to move during GC.}
+   {Determine whether a 'ByteArray#' is guaranteed not to move.}
+   with out_of_line = True
+
+primop  ByteArrayIsWeaklyPinnedOp "isByteArrayWeaklyPinned#" GenPrimOp
+   ByteArray# -> Int#
+   {Similar to 'isByteArrayPinned#'. Weakly pinned byte arrays are allowed
+    to be copied into compact regions by the user, potentially invalidating
+    the results of earlier calls to 'byteArrayContents#'.
+
+    See the section `Pinned Byte Arrays` in the user guide for more information.
+
+    This function also returns true for regular pinned bytearrays.
+   }
+   with out_of_line = True
+
+primop  MutableByteArrayIsWeaklyPinnedOp "isMutableByteArrayWeaklyPinned#" GenPrimOp
+   MutableByteArray# s -> Int#
+   { 'isByteArrayWeaklyPinned#' but for mutable arrays.
+   }
    with out_of_line = True
 
 primop  ByteArrayContents_Char "byteArrayContents#" GenPrimOp
@@ -2296,13 +2361,13 @@ primop   AddrRemOp "remAddr#" GenPrimOp Addr# -> Int# -> Int#
          {Return the remainder when the 'Addr#' arg, treated like an 'Int#',
           is divided by the 'Int#' arg.}
 primop   AddrToIntOp  "addr2Int#"     GenPrimOp   Addr# -> Int#
-        {Coerce directly from address to int.}
+        {Coerce directly from address to int. Users are discouraged from using
+         this operation as it makes little sense on platforms with tagged pointers.}
    with code_size = 0
-        deprecated_msg = { This operation is strongly deprecated. }
 primop   IntToAddrOp   "int2Addr#"    GenPrimOp  Int# -> Addr#
-        {Coerce directly from int to address.}
+        {Coerce directly from int to address. Users are discouraged from using
+         this operation as it makes little sense on platforms with tagged pointers.}
    with code_size = 0
-        deprecated_msg = { This operation is strongly deprecated. }
 
 primop   AddrGtOp  "gtAddr#"   Compare   Addr# -> Addr# -> Int#
 primop   AddrGeOp  "geAddr#"   Compare   Addr# -> Addr# -> Int#
@@ -2614,18 +2679,45 @@ primop  CasMutVarOp "casMutVar#" GenPrimOp
 section "Exceptions"
 ------------------------------------------------------------------------
 
--- Note [Strictness for mask/unmask/catch]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- Note [Strict IO wrappers]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~
 -- Consider this example, which comes from GHC.IO.Handle.Internals:
---    wantReadableHandle3 f ma b st
+--    wantReadableHandle3 f mv b st
 --      = case ... of
---          DEFAULT -> case ma of MVar a -> ...
---          0#      -> maskAsyncExceptions# (\st -> case ma of MVar a -> ...)
+--          DEFAULT -> case mv of MVar a -> ...
+--          0#      -> maskAsyncExceptions# (\st -> case mv of MVar a -> ...)
 -- The outer case just decides whether to mask exceptions, but we don't want
--- thereby to hide the strictness in 'ma'!  Hence the use of strictOnceApply1Dmd
--- in mask and unmask. But catch really is lazy in its first argument, see
--- #11555. So for IO actions 'ma' we often use a wrapper around it that is
--- head-strict in 'ma': GHC.IO.catchException.
+-- thereby to hide the strictness in `mv`!  Hence the use of strictOnceApply1Dmd
+-- in mask#, unmask# and atomically# (where we use strictManyApply1Dmd to respect
+-- that it potentially calls its action multiple times).
+--
+-- Note [Strictness for catch-style primops]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+-- The catch#-style primops always call their action, just like outlined
+-- in Note [Strict IO wrappers].
+-- However, it is important that we give their first arg lazyApply1Dmd and not
+-- strictOnceApply1Dmd, like for mask#. Here is why. Consider a call
+--
+--   catch# act handler s
+--
+-- If `act = raiseIO# ...`, using strictOnceApply1Dmd for `act` would mean that
+-- the call forwards the dead-end flag from `act` (see Note [Dead ends] and
+-- Note [Precise exceptions and strictness analysis]).
+-- This would cause dead code elimination to discard the continuation of the
+-- catch# call, among other things. This first came up in #11555.
+--
+-- Hence catch# uses lazyApply1Dmd in order /not/ to forward the dead-end flag
+-- from `act`. (This is a bit brutal, but the language of strictness types is
+-- not expressive enough to give it a more precise semantics that is still
+-- sound.)
+-- For perf reasons we often (but not always) choose to use a wrapper around
+-- catch# that is head-strict in `act`: GHC.IO.catchException.
+--
+-- A similar caveat applies to prompt#, which can be seen as a
+-- generalisation of catch# as explained in GHC.Prim#continuations#.
+-- The reason is that even if `act` appears dead-ending (e.g., looping)
+-- `prompt# tag ma s` might return alright due to a (higher-order) use of
+-- `control0#` in `act`. This came up in #25439.
 
 primop  CatchOp "catch#" GenPrimOp
           (State# RealWorld -> (# State# RealWorld, a_reppoly #) )
@@ -2642,7 +2734,7 @@ primop  CatchOp "catch#" GenPrimOp
    strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
                                                  , lazyApply2Dmd
                                                  , topDmd] topDiv }
-                 -- See Note [Strictness for mask/unmask/catch]
+                 -- See Note [Strictness for catch-style primops]
    out_of_line = True
    effect = ReadWriteEffect
    -- Either inner computation might potentially raise an unchecked exception,
@@ -2708,7 +2800,7 @@ primop  MaskAsyncExceptionsOp "maskAsyncExceptions#" GenPrimOp
      in continuation-style primops\" for details. }
    with
    strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }
-                 -- See Note [Strictness for mask/unmask/catch]
+                 -- See Note [Strict IO wrappers]
    out_of_line = True
    effect = ReadWriteEffect
 
@@ -2723,6 +2815,7 @@ primop  MaskUninterruptibleOp "maskUninterruptible#" GenPrimOp
      in continuation-style primops\" for details. }
    with
    strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }
+                 -- See Note [Strict IO wrappers]
    out_of_line = True
    effect = ReadWriteEffect
 
@@ -2737,7 +2830,7 @@ primop  UnmaskAsyncExceptionsOp "unmaskAsyncExceptions#" GenPrimOp
      in continuation-style primops\" for details. }
    with
    strictness  = { \ _arity -> mkClosedDmdSig [strictOnceApply1Dmd,topDmd] topDiv }
-                 -- See Note [Strictness for mask/unmask/catch]
+                 -- See Note [Strict IO wrappers]
    out_of_line = True
    effect = ReadWriteEffect
 
@@ -2882,9 +2975,9 @@ section "Continuations"
     'control0#' will fail by raising an exception. However, such violations
     are only detected on a best-effort basis, as the bookkeeping necessary for
     detecting /all/ illegal uses of 'control0#' would have significant overhead.
-    Therefore, although the operations are “safe” from the runtime’s point of
+    Therefore, although the operations are "safe" from the runtime's point of
     view (e.g. they will not compromise memory safety or clobber internal runtime
-    state), it is still ultimately the programmer’s responsibility to ensure
+    state), it is still ultimately the programmer's responsibility to ensure
     these invariants hold to guarantee predictable program behavior.
 
     In a similar vein, since each captured continuation includes the full local
@@ -2896,13 +2989,13 @@ section "Continuations"
     finish reading it when it is resumed; further attempts to resume from the
     same place would then fail because the file handle was already closed.
 
-    In other words, although the RTS ensures that a computation’s control state
+    In other words, although the RTS ensures that a computation's control state
     and local variables are properly restored for each distinct resumption of
     a continuation, it makes no attempt to duplicate any local state the
     computation may have been using (and could not possibly do so in general).
     Furthermore, it provides no mechanism for an arbitrary computation to
     protect itself against unwanted reentrancy (i.e. there is no analogue to
-    Scheme’s @dynamic-wind@). For those reasons, manipulating the continuation
+    Scheme's @dynamic-wind@). For those reasons, manipulating the continuation
     is only safe if the caller can be certain that doing so will not violate any
     expectations or invariants of the enclosing computation. }
 ------------------------------------------------------------------------
@@ -2923,7 +3016,8 @@ primop  PromptOp "prompt#" GenPrimOp
      -> State# RealWorld -> (# State# RealWorld, a #)
    { See "GHC.Prim#continuations". }
    with
-   strictness = { \ _arity -> mkClosedDmdSig [topDmd, strictOnceApply1Dmd, topDmd] topDiv }
+   strictness = { \ _arity -> mkClosedDmdSig [topDmd, lazyApply1Dmd, topDmd] topDiv }
+                 -- See Note [Strictness for catch-style primops]
    out_of_line = True
    effect = ReadWriteEffect
 
@@ -2951,7 +3045,7 @@ primop  AtomicallyOp "atomically#" GenPrimOp
    -> State# RealWorld -> (# State# RealWorld, a_levpoly #)
    with
    strictness  = { \ _arity -> mkClosedDmdSig [strictManyApply1Dmd,topDmd] topDiv }
-                 -- See Note [Strictness for mask/unmask/catch]
+                 -- See Note [Strict IO wrappers]
    out_of_line = True
    effect = ReadWriteEffect
 
@@ -2980,7 +3074,7 @@ primop  CatchRetryOp "catchRetry#" GenPrimOp
    strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
                                                  , lazyApply1Dmd
                                                  , topDmd ] topDiv }
-                 -- See Note [Strictness for mask/unmask/catch]
+                 -- See Note [Strictness for catch-style primops]
    out_of_line = True
    effect = ReadWriteEffect
 
@@ -2992,7 +3086,7 @@ primop  CatchSTMOp "catchSTM#" GenPrimOp
    strictness  = { \ _arity -> mkClosedDmdSig [ lazyApply1Dmd
                                                  , lazyApply2Dmd
                                                  , topDmd ] topDiv }
-                 -- See Note [Strictness for mask/unmask/catch]
+                 -- See Note [Strictness for catch-style primops]
    out_of_line = True
    effect = ReadWriteEffect
 
@@ -3626,27 +3720,30 @@ primop  ReallyUnsafePtrEqualityOp "reallyUnsafePtrEquality#" GenPrimOp
 section "Parallelism"
 ------------------------------------------------------------------------
 
-primop  ParOp "par#" GenPrimOp
-   a -> Int#
+primop  ParOp "par#" GenPrimOp a -> Int#
+   {Create a new spark evaluating the given argument.
+    The return value should always be 1.
+    Users are encouraged to use spark# instead.}
    with
       -- Note that Par is lazy to avoid that the sparked thing
       -- gets evaluated strictly, which it should *not* be
    effect = ReadWriteEffect
    code_size = { primOpCodeSizeForeignCall }
-   deprecated_msg = { Use 'spark#' instead }
+   -- `par#` was suppose to be deprecated in favor of `spark#` [1], however it
+   -- wasn't clear how to replace it with `spark#` [2] and `par#` is still used
+   -- to implement `GHC.Internal.Conc.Sync.par`. So we undeprecated it until
+   -- everything is sorted out (see #24825).
+   --
+   -- [1] https://gitlab.haskell.org/ghc/ghc/-/issues/15227#note_154293
+   -- [2] https://gitlab.haskell.org/ghc/ghc/-/merge_requests/5548#note_347791
+   --
+   -- deprecated_msg = { Use 'spark#' instead }
 
 primop SparkOp "spark#" GenPrimOp
    a -> State# s -> (# State# s, a #)
    with effect = ReadWriteEffect
    code_size = { primOpCodeSizeForeignCall }
 
--- See Note [seq# magic] in GHC.Core.Opt.ConstantFold
-primop SeqOp "seq#" GenPrimOp
-   a -> State# s -> (# State# s, a #)
-   with
-   effect = ThrowsException
-   work_free = True -- seq# does work iff its lifted arg does work
-
 primop GetSparkOp "getSpark#" GenPrimOp
    State# s -> (# State# s, Int#, a #)
    with
@@ -3679,6 +3776,7 @@ primop KeepAliveOp "keepAlive#" GenPrimOp
    with
    out_of_line = True
    strictness = { \ _arity -> mkClosedDmdSig [topDmd, topDmd, strictOnceApply1Dmd] topDiv }
+                 -- See Note [Strict IO wrappers]
    effect = ReadWriteEffect
    -- The invoked computation may have side effects
 
@@ -3689,7 +3787,27 @@ section "Tag to enum stuff"
         and small integers.}
 ------------------------------------------------------------------------
 
-primop  DataToTagOp "dataToTagLarge#" GenPrimOp
+primop  DataToTagSmallOp "dataToTagSmall#" GenPrimOp
+   a_levpoly -> Int#
+   { Used internally to implement @dataToTag#@: Use that function instead!
+     This one normally offers /no advantage/ and comes with no stability
+     guarantees: it may change its type, its name, or its behavior
+     with /no warning/ between compiler releases.
+
+     It is expected that this function will be un-exposed in a future
+     release of ghc.
+
+     For more details, look at @Note [DataToTag overview]@
+     in GHC.Tc.Instance.Class in the source code for
+     /the specific compiler version you are using./
+   }
+   with
+   deprecated_msg = { Use dataToTag# from \"GHC.Magic\" instead. }
+   strictness = { \ _arity -> mkClosedDmdSig [evalDmd] topDiv }
+   effect = ThrowsException
+   cheap = True
+
+primop  DataToTagLargeOp "dataToTagLarge#" GenPrimOp
    a_levpoly -> Int#
    { Used internally to implement @dataToTag#@: Use that function instead!
      This one offers /no advantage/ and comes with no stability
@@ -3813,10 +3931,9 @@ primop  ClearCCSOp "clearCCS#" GenPrimOp
 section "Info Table Origin"
 ------------------------------------------------------------------------
 primop WhereFromOp "whereFrom#" GenPrimOp
-   a -> State# s -> (# State# s, Addr# #)
-   { Returns the @InfoProvEnt @ for the info table of the given object
-     (value is @NULL@ if the table does not exist or there is no information
-     about the closure).}
+   a -> Addr# -> State# s -> (# State# s, Int# #)
+   { Fills the given buffer with the @InfoProvEnt@ for the info table of the
+     given object. Returns @1#@ on success and @0#@ otherwise.}
    with
    out_of_line = True
 
@@ -3935,10 +4052,25 @@ pseudoop   "coerce"
      more complicated settings, e.g. converting a list of newtypes to a list of
      concrete types.
 
+     When used in conversions involving a newtype wrapper,
+     make sure the newtype constructor is in scope.
+
      This function is representation-polymorphic, but the
      'RuntimeRep' type argument is marked as 'Inferred', meaning
      that it is not available for visible type application. This means
      the typechecker will accept @'coerce' \@'Int' \@Age 42@.
+
+     === __Examples__
+
+     >>> newtype TTL = TTL Int deriving (Eq, Ord, Show)
+     >>> newtype Age = Age Int deriving (Eq, Ord, Show)
+     >>> coerce (Age 42) :: TTL
+     TTL 42
+     >>> coerce (+ (1 :: Int)) (Age 42) :: TTL
+     TTL 43
+     >>> coerce (map (+ (1 :: Int))) [Age 42, Age 24] :: [TTL]
+     [TTL 43,TTL 25]
+
    }
 
 ------------------------------------------------------------------------
@@ -3979,125 +4111,111 @@ section "SIMD Vectors"
   ,<Word8,Word8#,64>,<Word16,Word16#,32>,<Word32,Word32#,16>,<Word64,Word64#,8>]
 
 primtype VECTOR
-   with llvm_only = True
-        vector = ALL_VECTOR_TYPES
+   with vector = ALL_VECTOR_TYPES
 
 primop VecBroadcastOp "broadcast#" GenPrimOp
    SCALAR -> VECTOR
    { Broadcast a scalar to all elements of a vector. }
-   with llvm_only = True
-        vector = ALL_VECTOR_TYPES
+   with vector = ALL_VECTOR_TYPES
 
 primop VecPackOp "pack#" GenPrimOp
    VECTUPLE -> VECTOR
    { Pack the elements of an unboxed tuple into a vector. }
-   with llvm_only = True
-        vector = ALL_VECTOR_TYPES
+   with vector = ALL_VECTOR_TYPES
 
 primop VecUnpackOp "unpack#" GenPrimOp
    VECTOR -> VECTUPLE
-   { Unpack the elements of a vector into an unboxed tuple. #}
-   with llvm_only = True
-        vector = ALL_VECTOR_TYPES
+   { Unpack the elements of a vector into an unboxed tuple. }
+   with vector = ALL_VECTOR_TYPES
 
 primop VecInsertOp "insert#" GenPrimOp
    VECTOR -> SCALAR -> Int# -> VECTOR
-   { Insert a scalar at the given position in a vector. }
+   { Insert a scalar at the given position in a vector.
+     The position must be a compile-time constant. }
    with effect = CanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecAddOp "plus#" GenPrimOp
    VECTOR -> VECTOR -> VECTOR
    { Add two vectors element-wise. }
    with commutable = True
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecSubOp "minus#" GenPrimOp
    VECTOR -> VECTOR -> VECTOR
    { Subtract two vectors element-wise. }
-   with llvm_only = True
-        vector = ALL_VECTOR_TYPES
+   with vector = ALL_VECTOR_TYPES
 
 primop VecMulOp "times#" GenPrimOp
    VECTOR -> VECTOR -> VECTOR
    { Multiply two vectors element-wise. }
    with commutable = True
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecDivOp "divide#" GenPrimOp
    VECTOR -> VECTOR -> VECTOR
    { Divide two vectors element-wise. }
    with effect = CanFail
-        llvm_only = True
         vector = FLOAT_VECTOR_TYPES
 
 primop VecQuotOp "quot#" GenPrimOp
    VECTOR -> VECTOR -> VECTOR
    { Rounds towards zero element-wise. }
    with effect = CanFail
-        llvm_only = True
         vector = INT_VECTOR_TYPES
 
 primop VecRemOp "rem#" GenPrimOp
    VECTOR -> VECTOR -> VECTOR
    { Satisfies @('quot#' x y) 'times#' y 'plus#' ('rem#' x y) == x@. }
    with effect = CanFail
-        llvm_only = True
         vector = INT_VECTOR_TYPES
 
 primop VecNegOp "negate#" GenPrimOp
    VECTOR -> VECTOR
    { Negate element-wise. }
-   with llvm_only = True
-        vector = SIGNED_VECTOR_TYPES
+   with vector = SIGNED_VECTOR_TYPES
 
 primop VecIndexByteArrayOp "indexArray#" GenPrimOp
    ByteArray# -> Int# -> VECTOR
-   { Read a vector from specified index of immutable array. }
+   { Read a vector from the specified index of an immutable array.
+     The index is counted in units of SIMD vectors (not scalar elements). }
    with effect = CanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecReadByteArrayOp "readArray#" GenPrimOp
    MutableByteArray# s -> Int# -> State# s -> (# State# s, VECTOR #)
-   { Read a vector from specified index of mutable array. }
+   { Read a vector from the specified index of a mutable array.
+     The index is counted in units of SIMD vectors (not scalar elements). }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecWriteByteArrayOp "writeArray#" GenPrimOp
    MutableByteArray# s -> Int# -> VECTOR -> State# s -> State# s
-   { Write a vector to specified index of mutable array. }
+   { Write a vector to the specified index of a mutable array.
+     The index is counted in units of SIMD vectors (not scalar elements). }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecIndexOffAddrOp "indexOffAddr#" GenPrimOp
    Addr# -> Int# -> VECTOR
-   { Reads vector; offset in bytes. }
+   { Reads vector; offset in units of SIMD vectors (not scalar elements). }
    with effect = CanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecReadOffAddrOp "readOffAddr#" GenPrimOp
    Addr# -> Int# -> State# s -> (# State# s, VECTOR #)
-   { Reads vector; offset in bytes. }
+   { Reads vector; offset in units of SIMD vectors (not scalar elements). }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecWriteOffAddrOp "writeOffAddr#" GenPrimOp
    Addr# -> Int# -> VECTOR -> State# s -> State# s
-   { Write vector; offset in bytes. }
+   { Write vector; offset in units of SIMD vectors (not scalar elements). }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 
@@ -4105,7 +4223,6 @@ primop VecIndexScalarByteArrayOp "indexArrayAs#" GenPrimOp
    ByteArray# -> Int# -> VECTOR
    { Read a vector from specified index of immutable array of scalars; offset is in scalar elements. }
    with effect = CanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp
@@ -4113,7 +4230,6 @@ primop VecReadScalarByteArrayOp "readArrayAs#" GenPrimOp
    { Read a vector from specified index of mutable array of scalars; offset is in scalar elements. }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp
@@ -4121,14 +4237,12 @@ primop VecWriteScalarByteArrayOp "writeArrayAs#" GenPrimOp
    { Write a vector to specified index of mutable array of scalars; offset is in scalar elements. }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecIndexScalarOffAddrOp "indexOffAddrAs#" GenPrimOp
    Addr# -> Int# -> VECTOR
    { Reads vector; offset in scalar elements. }
    with effect = CanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp
@@ -4136,7 +4250,6 @@ primop VecReadScalarOffAddrOp "readOffAddrAs#" GenPrimOp
    { Reads vector; offset in scalar elements. }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
 primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp
@@ -4144,9 +4257,47 @@ primop VecWriteScalarOffAddrOp "writeOffAddrAs#" GenPrimOp
    { Write vector; offset in scalar elements. }
    with effect = ReadWriteEffect
         can_fail_warning = YesWarnCanFail
-        llvm_only = True
         vector = ALL_VECTOR_TYPES
 
+primop   VecFMAdd   "fmadd#" GenPrimOp
+   VECTOR -> VECTOR -> VECTOR -> VECTOR
+   {Fused multiply-add operation @x*y+z@. See "GHC.Prim#fma".}
+   with
+      vector = FLOAT_VECTOR_TYPES
+primop   VecFMSub   "fmsub#" GenPrimOp
+   VECTOR -> VECTOR -> VECTOR -> VECTOR
+   {Fused multiply-subtract operation @x*y-z@. See "GHC.Prim#fma".}
+   with
+      vector = FLOAT_VECTOR_TYPES
+primop   VecFNMAdd   "fnmadd#" GenPrimOp
+   VECTOR -> VECTOR -> VECTOR -> VECTOR
+   {Fused negate-multiply-add operation @-x*y+z@. See "GHC.Prim#fma".}
+   with
+      vector = FLOAT_VECTOR_TYPES
+primop   VecFNMSub   "fnmsub#" GenPrimOp
+   VECTOR -> VECTOR -> VECTOR -> VECTOR
+   {Fused negate-multiply-subtract operation @-x*y-z@. See "GHC.Prim#fma".}
+   with
+      vector = FLOAT_VECTOR_TYPES
+
+primop VecShuffleOp "shuffle#" GenPrimOp
+  VECTOR -> VECTOR -> INTVECTUPLE -> VECTOR
+  {Shuffle elements of the concatenation of the input two vectors
+  into the result vector. The indices must be compile-time constants.}
+   with vector = ALL_VECTOR_TYPES
+
+primop VecMinOp "min#" GenPrimOp
+   VECTOR -> VECTOR -> VECTOR
+   {Component-wise minimum of two vectors.}
+   with
+      vector = ALL_VECTOR_TYPES
+
+primop VecMaxOp "max#" GenPrimOp
+   VECTOR -> VECTOR -> VECTOR
+   {Component-wise maximum of two vectors.}
+   with
+      vector = ALL_VECTOR_TYPES
+
 ------------------------------------------------------------------------
 
 section "Prefetch"

compiler/GHC/ByteCode/Asm.hs

 {-# LANGUAGE CPP             #-}
 {-# LANGUAGE DeriveFunctor   #-}
 {-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE MagicHash       #-}
+{-# LANGUAGE UnboxedTuples   #-}
+{-# LANGUAGE PatternSynonyms   #-}
 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
 --
+--
 --  (c) The University of Glasgow 2002-2006
 --
 
 -- | Bytecode assembler and linker
 module GHC.ByteCode.Asm (
-        assembleBCOs, assembleOneBCO,
+        assembleBCOs,
         bcoFreeNames,
         SizedSeq, sizeSS, ssElts,
         iNTERP_STACK_CHECK_THRESH,
-        mkNativeCallInfoLit
+        mkNativeCallInfoLit,
+
+        -- * For testing
+        assembleBCO
   ) where
 
-import GHC.Prelude
+import GHC.Prelude hiding ( any )
+
 
 import GHC.ByteCode.Instr
 import GHC.ByteCode.InfoTable
@@ -28,35 +36,43 @@ import GHC.Types.Name
 import GHC.Types.Name.Set
 import GHC.Types.Literal
 import GHC.Types.Unique.DSet
+import GHC.Types.SptEntry
+import GHC.Types.Unique.FM
 
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
 import GHC.Core.TyCon
-import GHC.Data.FastString
 import GHC.Data.SizedSeq
+import GHC.Data.SmallArray
 
 import GHC.StgToCmm.Layout     ( ArgRep(..) )
 import GHC.Cmm.Expr
+import GHC.Cmm.Reg             ( GlobalArgRegs(..) )
 import GHC.Cmm.CallConv        ( allArgRegsCover )
 import GHC.Platform
 import GHC.Platform.Profile
 
 import Control.Monad
-import Control.Monad.Trans.Class
-import Control.Monad.Trans.State.Strict
+import qualified Control.Monad.Trans.State.Strict as MTL
 
 import qualified Data.Array.Unboxed as Array
-import Data.Array.Base  ( UArray(..) )
+import qualified Data.Array.IO as Array
+import Data.Array.Base  ( UArray(..), numElements, unsafeFreeze )
+
+#if ! defined(DEBUG)
+import Data.Array.Base  ( unsafeWrite )
+#endif
 
 import Foreign hiding (shiftL, shiftR)
-import Data.Char        ( ord )
-import Data.List        ( genericLength )
-import Data.Map.Strict (Map)
+import Data.Char  (ord)
 import Data.Maybe (fromMaybe)
-import qualified Data.Map.Strict as Map
 import GHC.Float (castFloatToWord32, castDoubleToWord64)
 
+import qualified Data.List as List ( any )
+import GHC.Exts
+
+
 -- -----------------------------------------------------------------------------
 -- Unlinked BCOs
 
@@ -71,9 +87,9 @@ bcoFreeNames bco
   where
     bco_refs (UnlinkedBCO _ _ _ _ nonptrs ptrs)
         = unionManyUniqDSets (
-             mkUniqDSet [ n | BCOPtrName n <- ssElts ptrs ] :
-             mkUniqDSet [ n | BCONPtrItbl n <- ssElts nonptrs ] :
-             map bco_refs [ bco | BCOPtrBCO bco <- ssElts ptrs ]
+             mkUniqDSet [ n | BCOPtrName n <- elemsFlatBag ptrs ] :
+             mkUniqDSet [ n | BCONPtrItbl n <- elemsFlatBag nonptrs ] :
+             map bco_refs [ bco | BCOPtrBCO bco <- elemsFlatBag ptrs ]
           )
 
 -- -----------------------------------------------------------------------------
@@ -90,12 +106,13 @@ bcoFreeNames bco
 assembleBCOs
   :: Interp
   -> Profile
-  -> [ProtoBCO Name]
+  -> FlatBag (ProtoBCO Name)
   -> [TyCon]
   -> AddrEnv
   -> Maybe ModBreaks
+  -> [SptEntry]
   -> IO CompiledByteCode
-assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
+assembleBCOs interp profile proto_bcos tycons top_strs modbreaks spt_entries = do
   -- TODO: the profile should be bundled with the interpreter: the rts ways are
   -- fixed for an interpreter
   itblenv <- mkITbls interp profile tycons
@@ -103,10 +120,11 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
   bcos'   <- mallocStrings interp bcos
   return CompiledByteCode
     { bc_bcos = bcos'
-    , bc_itbls =  itblenv
+    , bc_itbls = itblenv
     , bc_ffis = concatMap protoBCOFFIs proto_bcos
     , bc_strs = top_strs
     , bc_breaks = modbreaks
+    , bc_spt_entries = spt_entries
     }
 
 -- Note [Allocating string literals]
@@ -129,11 +147,11 @@ assembleBCOs interp profile proto_bcos tycons top_strs modbreaks = do
 -- top-level string literal bindings] in GHC.StgToByteCode for some discussion
 -- about why.
 --
-mallocStrings :: Interp -> [UnlinkedBCO] -> IO [UnlinkedBCO]
+mallocStrings ::  Interp -> FlatBag UnlinkedBCO -> IO (FlatBag UnlinkedBCO)
 mallocStrings interp ulbcos = do
-  let bytestrings = reverse (execState (mapM_ collect ulbcos) [])
+  let bytestrings = reverse (MTL.execState (mapM_ collect ulbcos) [])
   ptrs <- interpCmd interp (MallocStrings bytestrings)
-  return (evalState (mapM splice ulbcos) ptrs)
+  return (MTL.evalState (mapM splice ulbcos) ptrs)
  where
   splice bco@UnlinkedBCO{..} = do
     lits <- mapM spliceLit unlinkedBCOLits
@@ -141,10 +159,10 @@ mallocStrings interp ulbcos = do
     return bco { unlinkedBCOLits = lits, unlinkedBCOPtrs = ptrs }
 
   spliceLit (BCONPtrStr _) = do
-    rptrs <- get
+    rptrs <- MTL.get
     case rptrs of
       (RemotePtr p : rest) -> do
-        put rest
+        MTL.put rest
         return (BCONPtrWord (fromIntegral p))
       _ -> panic "mallocStrings:spliceLit"
   spliceLit other = return other
@@ -157,32 +175,70 @@ mallocStrings interp ulbcos = do
     mapM_ collectPtr unlinkedBCOPtrs
 
   collectLit (BCONPtrStr bs) = do
-    strs <- get
-    put (bs:strs)
+    strs <- MTL.get
+    MTL.put (bs:strs)
   collectLit _ = return ()
 
   collectPtr (BCOPtrBCO bco) = collect bco
   collectPtr _ = return ()
 
+data RunAsmReader = RunAsmReader { isn_array :: {-# UNPACK #-} !(Array.IOUArray Int Word16)
+                                  , ptr_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCOPtr)
+                                  , lit_array :: {-# UNPACK #-} !(SmallMutableArrayIO BCONPtr )
+                                  }
+
+data RunAsmResult = RunAsmResult { final_isn_array :: !(Array.UArray Int Word16)
+                                 , final_ptr_array :: !(SmallArray BCOPtr)
+                                 , final_lit_array :: !(SmallArray BCONPtr) }
+
+-- How many words we have written so far.
+data AsmState = AsmState { nisn :: !Int, nptr :: !Int, nlit :: !Int }
+
+
+{-# NOINLINE inspectInstrs #-}
+-- | Perform analysis of the bytecode to determine
+--  1. How many instructions we will produce
+--  2. If we are going to need long jumps.
+--  3. The offsets that labels refer to
+inspectInstrs :: Platform -> Bool -> Word -> [BCInstr] -> InspectState
+inspectInstrs platform long_jump e instrs =
+  inspectAsm long_jump e (mapM_ (assembleInspectAsm platform) instrs)
+
+{-# NOINLINE runInstrs #-}
+-- | Assemble the bytecode from the instructions.
+runInstrs ::  Platform -> Bool -> InspectState -> [BCInstr] -> IO RunAsmResult
+runInstrs platform long_jumps is_state instrs = do
+  -- Produce arrays of exactly the right size, corresponding to the result of inspectInstrs.
+  isn_array <- Array.newArray_ (0, (fromIntegral $ instrCount is_state) - 1)
+  ptr_array <- newSmallArrayIO (fromIntegral $ ptrCount is_state) undefined
+  lit_array <- newSmallArrayIO (fromIntegral $ litCount is_state) undefined
+  let env :: LocalLabel -> Word
+      env lbl = fromMaybe
+        (pprPanic "assembleBCO.findLabel" (ppr lbl))
+        (lookupUFM (lblEnv is_state) lbl)
+  let initial_state  = AsmState 0 0 0
+  let initial_reader = RunAsmReader{..}
+  runAsm long_jumps env initial_reader initial_state (mapM_ (\i -> assembleRunAsm platform i) instrs)
+  final_isn_array <- unsafeFreeze isn_array
+  final_ptr_array <- unsafeFreezeSmallArrayIO ptr_array
+  final_lit_array <- unsafeFreezeSmallArrayIO lit_array
+  return $ RunAsmResult {..}
+
+assembleRunAsm :: Platform -> BCInstr -> RunAsm ()
+assembleRunAsm p i = assembleI @RunAsm p i
 
-assembleOneBCO :: Interp -> Profile -> ProtoBCO Name -> IO UnlinkedBCO
-assembleOneBCO interp profile pbco = do
-  -- TODO: the profile should be bundled with the interpreter: the rts ways are
-  -- fixed for an interpreter
-  ubco <- assembleBCO (profilePlatform profile) pbco
-  [ubco'] <- mallocStrings interp [ubco]
-  return ubco'
+assembleInspectAsm :: Platform -> BCInstr -> InspectAsm ()
+assembleInspectAsm p i = assembleI @InspectAsm p i
 
 assembleBCO :: Platform -> ProtoBCO Name -> IO UnlinkedBCO
-assembleBCO platform (ProtoBCO { protoBCOName       = nm
-                             , protoBCOInstrs     = instrs
-                             , protoBCOBitmap     = bitmap
-                             , protoBCOBitmapSize = bsize
-                             , protoBCOArity      = arity }) = do
+assembleBCO platform
+            (ProtoBCO { protoBCOName       = nm
+                      , protoBCOInstrs     = instrs
+                      , protoBCOBitmap     = bitmap
+                      , protoBCOBitmapSize = bsize
+                      , protoBCOArity      = arity }) = do
   -- pass 1: collect up the offsets of the local labels.
-  let asm = mapM_ (assembleI platform) instrs
-
-      initial_offset = 0
+  let initial_offset = 0
 
       -- Jump instructions are variable-sized, there are long and short variants
       -- depending on the magnitude of the offset.  However, we can't tell what
@@ -192,30 +248,25 @@ assembleBCO platform (ProtoBCO { protoBCOName       = nm
       -- and if the final size is indeed small enough for short jumps, we are
       -- done.  Otherwise, we repeat the calculation, and we force all jumps in
       -- this BCO to be long.
-      (n_insns0, lbl_map0) = inspectAsm platform False initial_offset asm
-      ((n_insns, lbl_map), long_jumps)
-        | isLargeW (fromIntegral $ Map.size lbl_map0)
-          || isLargeW n_insns0
-                    = (inspectAsm platform True initial_offset asm, True)
-        | otherwise = ((n_insns0, lbl_map0), False)
-
-      env :: LocalLabel -> Word
-      env lbl = fromMaybe
-        (pprPanic "assembleBCO.findLabel" (ppr lbl))
-        (Map.lookup lbl lbl_map)
+      is0 = inspectInstrs platform False initial_offset instrs
+      (is1, long_jumps)
+        | isLargeInspectState is0
+                    = (inspectInstrs platform True initial_offset instrs, True)
+        | otherwise = (is0, False)
+
 
   -- pass 2: run assembler and generate instructions, literals and pointers
-  let initial_state = (emptySS, emptySS, emptySS)
-  (final_insns, final_lits, final_ptrs) <- flip execStateT initial_state $ runAsm platform long_jumps env asm
+  RunAsmResult{..} <- runInstrs platform long_jumps is1 instrs
 
   -- precomputed size should be equal to final size
-  massertPpr (n_insns == sizeSS final_insns)
+  massertPpr (fromIntegral (instrCount is1) == numElements final_isn_array
+              && fromIntegral (ptrCount is1) == sizeofSmallArray final_ptr_array
+              && fromIntegral (litCount is1) == sizeofSmallArray final_lit_array)
              (text "bytecode instruction count mismatch")
 
-  let asm_insns = ssElts final_insns
-      insns_arr = Array.listArray (0, fromIntegral n_insns - 1) asm_insns
-      bitmap_arr = mkBitmapArray bsize bitmap
-      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr final_lits final_ptrs
+  let !insns_arr =  mkBCOByteArray $ final_isn_array
+      !bitmap_arr = mkBCOByteArray $ mkBitmapArray bsize bitmap
+      ul_bco = UnlinkedBCO nm arity insns_arr bitmap_arr (fromSmallArray final_lit_array) (fromSmallArray final_ptr_array)
 
   -- 8 Aug 01: Finalisers aren't safe when attached to non-primitive
   -- objects, since they might get run too early.  Disable this until
@@ -224,7 +275,7 @@ assembleBCO platform (ProtoBCO { protoBCOName       = nm
 
   return ul_bco
 
-mkBitmapArray :: Word -> [StgWord] -> UArray Int Word64
+mkBitmapArray :: Word -> [StgWord] -> UArray Int Word
 -- Here the return type must be an array of Words, not StgWords,
 -- because the underlying ByteArray# will end up as a component
 -- of a BCO object.
@@ -232,10 +283,6 @@ mkBitmapArray bsize bitmap
   = Array.listArray (0, length bitmap) $
       fromIntegral bsize : map (fromInteger . fromStgWord) bitmap
 
--- instrs nonptrs ptrs
-type AsmState = (SizedSeq Word16,
-                 SizedSeq BCONPtr,
-                 SizedSeq BCOPtr)
 
 data Operand
   = Op Word
@@ -255,39 +302,9 @@ truncHalfWord platform w = case platformWordSize platform of
   PW8 | w <= 4294967295 -> Op (fromIntegral w)
   _ -> pprPanic "GHC.ByteCode.Asm.truncHalfWord" (ppr w)
 
-data Assembler a
-  = AllocPtr (IO BCOPtr) (Word -> Assembler a)
-  | AllocLit [BCONPtr] (Word -> Assembler a)
-  | AllocLabel LocalLabel (Assembler a)
-  | Emit Word16 [Operand] (Assembler a)
-  | NullAsm a
-  deriving (Functor)
-
-instance Applicative Assembler where
-    pure = NullAsm
-    (<*>) = ap
-
-instance Monad Assembler where
-  NullAsm x >>= f = f x
-  AllocPtr p k >>= f = AllocPtr p (k >=> f)
-  AllocLit l k >>= f = AllocLit l (k >=> f)
-  AllocLabel lbl k >>= f = AllocLabel lbl (k >>= f)
-  Emit w ops k >>= f = Emit w ops (k >>= f)
-
-ioptr :: IO BCOPtr -> Assembler Word
-ioptr p = AllocPtr p return
-
-ptr :: BCOPtr -> Assembler Word
-ptr = ioptr . return
-
-lit :: [BCONPtr] -> Assembler Word
-lit l = AllocLit l return
-
-label :: LocalLabel -> Assembler ()
-label w = AllocLabel w (return ())
 
-emit :: Word16 -> [Operand] -> Assembler ()
-emit w ops = Emit w ops (return ())
+ptr :: MonadAssembler m => BCOPtr -> m Word
+ptr = ioptr . return
 
 type LabelEnv = LocalLabel -> Word
 
@@ -298,38 +315,142 @@ largeOp long_jumps op = case op of
    IOp i     -> isLargeI i
    LabelOp _ -> long_jumps
 
-runAsm :: Platform -> Bool -> LabelEnv -> Assembler a -> StateT AsmState IO a
-runAsm platform long_jumps e = go
+newtype RunAsm a = RunAsm' { runRunAsm :: Bool
+                                       -> LabelEnv
+                                       -> RunAsmReader
+                                       -> AsmState
+                                       -> IO (AsmState, a) }
+
+pattern RunAsm :: (Bool -> LabelEnv -> RunAsmReader -> AsmState -> IO (AsmState, a))
+                  -> RunAsm a
+pattern RunAsm m <- RunAsm' m
   where
-    go (NullAsm x) = return x
-    go (AllocPtr p_io k) = do
-      p <- lift p_io
-      w <- state $ \(st_i0,st_l0,st_p0) ->
-        let st_p1 = addToSS st_p0 p
-        in (sizeSS st_p0, (st_i0,st_l0,st_p1))
-      go $ k w
-    go (AllocLit lits k) = do
-      w <- state $ \(st_i0,st_l0,st_p0) ->
-        let st_l1 = addListToSS st_l0 lits
-        in (sizeSS st_l0, (st_i0,st_l1,st_p0))
-      go $ k w
-    go (AllocLabel _ k) = go k
-    go (Emit w ops k) = do
-      let largeArgs = any (largeOp long_jumps) ops
-          opcode
-            | largeArgs = largeArgInstr w
-            | otherwise = w
-          words = concatMap expand ops
-          expand (SmallOp w) = [w]
-          expand (LabelOp w) = expand (Op (e w))
-          expand (Op w) = if largeArgs then largeArg platform (fromIntegral w) else [fromIntegral w]
-          expand (IOp i) = if largeArgs then largeArg platform (fromIntegral i) else [fromIntegral i]
-      state $ \(st_i0,st_l0,st_p0) ->
-        let st_i1 = addListToSS st_i0 (opcode : words)
-        in ((), (st_i1,st_l0,st_p0))
-      go k
-
-type LabelEnvMap = Map LocalLabel Word
+    RunAsm m = RunAsm' (oneShot $ \a -> oneShot $ \b -> oneShot $ \c -> oneShot $ \d -> m a b c d)
+{-# COMPLETE RunAsm #-}
+
+instance Functor RunAsm where
+  fmap f (RunAsm x) = RunAsm (\a b c !s -> fmap (fmap f) (x a b c s))
+
+instance Applicative RunAsm where
+  pure x = RunAsm $ \_ _ _ !s -> pure (s, x)
+  (RunAsm f) <*> (RunAsm x) = RunAsm $ \a b c !s -> do
+                                  (!s', f') <- f a b c s
+                                  (!s'', x') <- x a b c s'
+                                  return (s'', f' x')
+  {-# INLINE (<*>) #-}
+
+
+instance Monad RunAsm where
+  return  = pure
+  (RunAsm m) >>= f = RunAsm $ \a b c !s -> m a b c s >>= \(s', r) -> runRunAsm (f r) a b c s'
+  {-# INLINE (>>=) #-}
+
+runAsm :: Bool -> LabelEnv -> RunAsmReader -> AsmState -> RunAsm a -> IO a
+runAsm long_jumps e r s (RunAsm'{runRunAsm}) = fmap snd $ runRunAsm long_jumps e r s
+
+expand :: PlatformWordSize -> Bool -> Operand -> RunAsm ()
+expand word_size largeArgs o = do
+  e <- askEnv
+  case o of
+    (SmallOp w) -> writeIsn w
+    (LabelOp w) -> let !r = e w in handleLargeArg r
+    (Op w) -> handleLargeArg w
+    (IOp i) -> handleLargeArg i
+
+  where
+    handleLargeArg :: Integral a => a -> RunAsm ()
+    handleLargeArg w  =
+      if largeArgs
+        then largeArg word_size (fromIntegral w)
+        else writeIsn (fromIntegral w)
+
+lift :: IO a -> RunAsm a
+lift io = RunAsm $ \_ _ _ s -> io >>= \a -> pure (s, a)
+
+askLongJumps :: RunAsm Bool
+askLongJumps = RunAsm $ \a _ _ s -> pure (s, a)
+
+askEnv :: RunAsm LabelEnv
+askEnv = RunAsm $ \_ b _ s -> pure (s, b)
+
+writePtr :: BCOPtr -> RunAsm Word
+writePtr w
+            = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do
+              writeSmallArrayIO ptr_array (nptr asm) w
+              let !n' = nptr asm + 1
+              let !asm' = asm { nptr = n' }
+              return (asm', fromIntegral (nptr asm))
+
+writeLit :: BCONPtr -> RunAsm Word
+writeLit w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do
+              writeSmallArrayIO lit_array (nlit asm) w
+              let !n' = nlit asm + 1
+              let !asm' = asm { nlit = n' }
+              return (asm', fromIntegral (nlit asm))
+
+writeLits :: OneOrTwo BCONPtr -> RunAsm Word
+writeLits (OnlyOne l) = writeLit l
+writeLits (OnlyTwo l1 l2) = writeLit l1 <* writeLit l2
+
+writeIsn :: Word16 -> RunAsm ()
+writeIsn w = RunAsm $ \_ _ (RunAsmReader{..}) asm -> do
+#if defined(DEBUG)
+              Array.writeArray isn_array (nisn asm) w
+#else
+              unsafeWrite isn_array (nisn asm) w
+#endif
+              let !n' = nisn asm + 1
+              let !asm' = asm { nisn = n' }
+              return (asm', ())
+
+{-# INLINE any #-}
+-- Any is unrolled manually so that the call in `emit` can be eliminated without
+-- relying on SpecConstr (which does not work across modules).
+any :: (a -> Bool) -> [a] -> Bool
+any _ [] = False
+any f [x] = f x
+any f [x,y] = f x || f y
+any f [x,y,z] = f x || f y || f z
+any f [x1,x2,x3,x4] = f x1 || f x2 || f x3 || f x4
+any f [x1,x2,x3,x4, x5] = f x1 || f x2 || f x3 || f x4 || f x5
+any f [x1,x2,x3,x4,x5,x6] = f x1 || f x2 || f x3 || f x4 || f x5 || f x6
+any f xs = List.any f xs
+
+{-# INLINE mapM6_ #-}
+mapM6_ :: Monad m => (a -> m b) -> [a] -> m ()
+mapM6_ _ [] = return ()
+mapM6_ f [x] = () <$ f x
+mapM6_ f [x,y] = () <$ f x <* f y
+mapM6_ f [x,y,z] = () <$ f x <* f y <* f z
+mapM6_ f [a1,a2,a3,a4] = () <$ f a1 <* f a2 <* f a3 <* f a4
+mapM6_ f [a1,a2,a3,a4,a5] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5
+mapM6_ f [a1,a2,a3,a4,a5,a6] = () <$ f a1 <* f a2 <* f a3 <* f a4 <* f a5 <* f a6
+mapM6_ f xs = mapM_ f xs
+
+instance MonadAssembler RunAsm where
+  ioptr p_io = do
+    p <- lift p_io
+    writePtr p
+  lit lits = writeLits lits
+
+  label _ = return ()
+
+  emit pwordsize w ops = do
+    long_jumps <- askLongJumps
+    -- See the definition of `any` above
+    let largeArgs = any (largeOp long_jumps) ops
+    let opcode
+          | largeArgs = largeArgInstr w
+          | otherwise = w
+    writeIsn opcode
+    mapM6_ (expand pwordsize largeArgs) ops
+
+  {-# INLINE emit #-}
+  {-# INLINE label #-}
+  {-# INLINE lit #-}
+  {-# INLINE ioptr #-}
+
+type LabelEnvMap = UniqFM LocalLabel Word
 
 data InspectState = InspectState
   { instrCount :: !Word
@@ -338,26 +459,105 @@ data InspectState = InspectState
   , lblEnv :: LabelEnvMap
   }
 
-inspectAsm :: Platform -> Bool -> Word -> Assembler a -> (Word, LabelEnvMap)
-inspectAsm platform long_jumps initial_offset
-  = go (InspectState initial_offset 0 0 Map.empty)
+instance Outputable InspectState where
+  ppr (InspectState i p l m) = text "InspectState" <+> ppr [ppr i, ppr p, ppr l, ppr (sizeUFM m)]
+
+isLargeInspectState :: InspectState -> Bool
+isLargeInspectState InspectState{..} =
+  isLargeW (fromIntegral $ sizeUFM lblEnv)
+    || isLargeW instrCount
+
+newtype InspectEnv = InspectEnv { _inspectLongJumps :: Bool
+                                }
+
+newtype InspectAsm a = InspectAsm' { runInspectAsm :: InspectEnv -> InspectState -> (# InspectState,  a #) }
+
+pattern InspectAsm :: (InspectEnv -> InspectState -> (# InspectState, a #))
+                   -> InspectAsm a
+pattern InspectAsm m <- InspectAsm' m
   where
-    go s (NullAsm _) = (instrCount s, lblEnv s)
-    go s (AllocPtr _ k) = go (s { ptrCount = n + 1 }) (k n)
-      where n = ptrCount s
-    go s (AllocLit ls k) = go (s { litCount = n + genericLength ls }) (k n)
-      where n = litCount s
-    go s (AllocLabel lbl k) = go s' k
-      where s' = s { lblEnv = Map.insert lbl (instrCount s) (lblEnv s) }
-    go s (Emit _ ops k) = go s' k
-      where
-        s' = s { instrCount = instrCount s + size }
-        size = sum (map count ops) + 1
+    InspectAsm m = InspectAsm' (oneShot $ \a -> oneShot $ \b -> m a b)
+{-# COMPLETE InspectAsm #-}
+
+instance Functor InspectAsm where
+  fmap f (InspectAsm k) = InspectAsm $ \a b -> case k a b of
+                                                  (# b', c #) -> (# b', f c #)
+
+instance Applicative InspectAsm where
+  pure x = InspectAsm $ \_ s -> (# s, x #)
+  (InspectAsm f) <*> (InspectAsm x) = InspectAsm $ \a b -> case f a b of
+                                                              (# s', f' #) ->
+                                                                case x a s' of
+                                                                  (# s'', x' #) -> (# s'', f' x' #)
+
+instance Monad InspectAsm where
+  return = pure
+  (InspectAsm m) >>= f = InspectAsm $ \ a b -> case m a b of
+                                                (# s', a' #) -> runInspectAsm (f a') a s'
+
+get_ :: InspectAsm InspectState
+get_ = InspectAsm $ \_ b -> (# b, b #)
+
+put_ :: InspectState -> InspectAsm ()
+put_ !s = InspectAsm $ \_ _ -> (# s, () #)
+
+modify_ :: (InspectState -> InspectState) -> InspectAsm ()
+modify_ f = InspectAsm $ \_ s -> let !s' = f s in (# s', () #)
+
+ask_ :: InspectAsm InspectEnv
+ask_ = InspectAsm $ \a b -> (# b, a #)
+
+inspectAsm :: Bool -> Word -> InspectAsm () -> InspectState
+inspectAsm long_jumps initial_offset (InspectAsm s) =
+  case s (InspectEnv long_jumps) (InspectState initial_offset 0 0 emptyUFM) of
+    (# res, () #) -> res
+{-# INLINE inspectAsm #-}
+
+
+
+instance MonadAssembler InspectAsm where
+  ioptr _ = do
+    s <- get_
+    let n = ptrCount s
+    put_ (s { ptrCount = n + 1 })
+    return n
+
+  lit ls = do
+    s <- get_
+    let n = litCount s
+    put_ (s { litCount = n + oneTwoLength ls })
+    return n
+
+  label lbl = modify_ (\s -> let !count = instrCount s in let !env' = addToUFM (lblEnv s) lbl count in s { lblEnv = env' })
+
+  emit pwordsize _ ops = do
+    InspectEnv long_jumps <- ask_
+    -- Size is written in this way as `mapM6_` is also used by RunAsm, and guaranteed
+    -- to unroll for arguments up to size 6.
+    let size = (MTL.execState (mapM6_ (\x -> MTL.modify (count' x +)) ops) 0) + 1
         largeOps = any (largeOp long_jumps) ops
-        count (SmallOp _) = 1
-        count (LabelOp _) = count (Op 0)
-        count (Op _) = if largeOps then largeArg16s platform else 1
-        count (IOp _) = if largeOps then largeArg16s platform else 1
+        bigSize = largeArg16s pwordsize
+        count' = if largeOps then countLarge bigSize else countSmall bigSize
+
+    s <- get_
+    put_ (s { instrCount = instrCount s + size })
+
+  {-# INLINE emit #-}
+  {-# INLINE label #-}
+  {-# INLINE lit #-}
+  {-# INLINE ioptr #-}
+
+count :: Word -> Bool -> Operand -> Word
+count _ _ (SmallOp _)          = 1
+count big largeOps (LabelOp _) = if largeOps then big else 1
+count big largeOps (Op _)      = if largeOps then big else 1
+count big largeOps (IOp _)     = if largeOps then big else 1
+{-# INLINE count #-}
+
+countSmall, countLarge :: Word -> Operand -> Word
+countLarge big x = count big True x
+countSmall big x = count big False x
+
 
 -- Bring in all the bci_ bytecode constants.
 #include "Bytecodes.h"
@@ -365,47 +565,67 @@ inspectAsm platform long_jumps initial_offset
 largeArgInstr :: Word16 -> Word16
 largeArgInstr bci = bci_FLAG_LARGE_ARGS .|. bci
 
-largeArg :: Platform -> Word64 -> [Word16]
-largeArg platform w = case platformWordSize platform of
-   PW8 -> [fromIntegral (w `shiftR` 48),
-           fromIntegral (w `shiftR` 32),
-           fromIntegral (w `shiftR` 16),
-           fromIntegral w]
+{-# INLINE largeArg #-}
+largeArg :: PlatformWordSize -> Word64 -> RunAsm ()
+largeArg wsize w = case wsize of
+   PW8 ->  do writeIsn (fromIntegral (w `shiftR` 48))
+              writeIsn (fromIntegral (w `shiftR` 32))
+              writeIsn (fromIntegral (w `shiftR` 16))
+              writeIsn (fromIntegral w)
    PW4 -> assertPpr (w < fromIntegral (maxBound :: Word32))
-                    (text "largeArg too big:" <+> ppr w) $
-          [fromIntegral (w `shiftR` 16),
-           fromIntegral w]
+                    (text "largeArg too big:" <+> ppr w) $ do
+          writeIsn (fromIntegral (w `shiftR` 16))
+          writeIsn (fromIntegral w)
 
-largeArg16s :: Platform -> Word
-largeArg16s platform = case platformWordSize platform of
+largeArg16s :: PlatformWordSize -> Word
+largeArg16s pwordsize = case pwordsize of
    PW8 -> 4
    PW4 -> 2
 
-assembleI :: Platform
+data OneOrTwo a = OnlyOne a | OnlyTwo a a deriving (Functor)
+
+oneTwoLength :: OneOrTwo a -> Word
+oneTwoLength (OnlyOne {}) = 1
+oneTwoLength (OnlyTwo {}) = 2
+
+class Monad m => MonadAssembler m where
+  ioptr :: IO BCOPtr -> m Word
+  lit :: OneOrTwo BCONPtr -> m Word
+  label :: LocalLabel -> m ()
+  emit :: PlatformWordSize -> Word16 -> [Operand] -> m ()
+
+lit1 :: MonadAssembler m => BCONPtr -> m Word
+lit1 p = lit (OnlyOne p)
+
+{-# SPECIALISE assembleI :: Platform -> BCInstr -> InspectAsm () #-}
+{-# SPECIALISE assembleI :: Platform -> BCInstr -> RunAsm () #-}
+
+assembleI :: forall m . MonadAssembler m
+          => Platform
           -> BCInstr
-          -> Assembler ()
+          -> m ()
 assembleI platform i = case i of
-  STKCHECK n               -> emit bci_STKCHECK [Op n]
-  PUSH_L o1                -> emit bci_PUSH_L [wOp o1]
-  PUSH_LL o1 o2            -> emit bci_PUSH_LL [wOp o1, wOp o2]
-  PUSH_LLL o1 o2 o3        -> emit bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]
-  PUSH8 o1                 -> emit bci_PUSH8 [bOp o1]
-  PUSH16 o1                -> emit bci_PUSH16 [bOp o1]
-  PUSH32 o1                -> emit bci_PUSH32 [bOp o1]
-  PUSH8_W o1               -> emit bci_PUSH8_W [bOp o1]
-  PUSH16_W o1              -> emit bci_PUSH16_W [bOp o1]
-  PUSH32_W o1              -> emit bci_PUSH32_W [bOp o1]
+  STKCHECK n               -> emit_ bci_STKCHECK [Op n]
+  PUSH_L o1                -> emit_ bci_PUSH_L [wOp o1]
+  PUSH_LL o1 o2            -> emit_ bci_PUSH_LL [wOp o1, wOp o2]
+  PUSH_LLL o1 o2 o3        -> emit_ bci_PUSH_LLL [wOp o1, wOp o2, wOp o3]
+  PUSH8 o1                 -> emit_ bci_PUSH8 [bOp o1]
+  PUSH16 o1                -> emit_ bci_PUSH16 [bOp o1]
+  PUSH32 o1                -> emit_ bci_PUSH32 [bOp o1]
+  PUSH8_W o1               -> emit_ bci_PUSH8_W [bOp o1]
+  PUSH16_W o1              -> emit_ bci_PUSH16_W [bOp o1]
+  PUSH32_W o1              -> emit_ bci_PUSH32_W [bOp o1]
   PUSH_G nm                -> do p <- ptr (BCOPtrName nm)
-                                 emit bci_PUSH_G [Op p]
+                                 emit_ bci_PUSH_G [Op p]
   PUSH_PRIMOP op           -> do p <- ptr (BCOPtrPrimOp op)
-                                 emit bci_PUSH_G [Op p]
+                                 emit_ bci_PUSH_G [Op p]
   PUSH_BCO proto           -> do let ul_bco = assembleBCO platform proto
                                  p <- ioptr (liftM BCOPtrBCO ul_bco)
-                                 emit bci_PUSH_G [Op p]
+                                 emit_ bci_PUSH_G [Op p]
   PUSH_ALTS proto pk
                            -> do let ul_bco = assembleBCO platform proto
                                  p <- ioptr (liftM BCOPtrBCO ul_bco)
-                                 emit (push_alts pk) [Op p]
+                                 emit_ (push_alts pk) [Op p]
   PUSH_ALTS_TUPLE proto call_info tuple_proto
                            -> do let ul_bco = assembleBCO platform proto
                                      ul_tuple_bco = assembleBCO platform
@@ -414,123 +634,131 @@ assembleI platform i = case i of
                                  p_tup <- ioptr (liftM BCOPtrBCO ul_tuple_bco)
                                  info <- word (fromIntegral $
                                               mkNativeCallInfoSig platform call_info)
-                                 emit bci_PUSH_ALTS_T
+                                 emit_ bci_PUSH_ALTS_T
                                       [Op p, Op info, Op p_tup]
-  PUSH_PAD8                -> emit bci_PUSH_PAD8 []
-  PUSH_PAD16               -> emit bci_PUSH_PAD16 []
-  PUSH_PAD32               -> emit bci_PUSH_PAD32 []
+  PUSH_PAD8                -> emit_ bci_PUSH_PAD8 []
+  PUSH_PAD16               -> emit_ bci_PUSH_PAD16 []
+  PUSH_PAD32               -> emit_ bci_PUSH_PAD32 []
   PUSH_UBX8 lit            -> do np <- literal lit
-                                 emit bci_PUSH_UBX8 [Op np]
+                                 emit_ bci_PUSH_UBX8 [Op np]
   PUSH_UBX16 lit           -> do np <- literal lit
-                                 emit bci_PUSH_UBX16 [Op np]
+                                 emit_ bci_PUSH_UBX16 [Op np]
   PUSH_UBX32 lit           -> do np <- literal lit
-                                 emit bci_PUSH_UBX32 [Op np]
+                                 emit_ bci_PUSH_UBX32 [Op np]
   PUSH_UBX lit nws         -> do np <- literal lit
-                                 emit bci_PUSH_UBX [Op np, wOp nws]
-
+                                 emit_ bci_PUSH_UBX [Op np, wOp nws]
   -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
-  PUSH_ADDR nm             -> do np <- lit [BCONPtrAddr nm]
-                                 emit bci_PUSH_UBX [Op np, SmallOp 1]
-
-  PUSH_APPLY_N             -> emit bci_PUSH_APPLY_N []
-  PUSH_APPLY_V             -> emit bci_PUSH_APPLY_V []
-  PUSH_APPLY_F             -> emit bci_PUSH_APPLY_F []
-  PUSH_APPLY_D             -> emit bci_PUSH_APPLY_D []
-  PUSH_APPLY_L             -> emit bci_PUSH_APPLY_L []
-  PUSH_APPLY_P             -> emit bci_PUSH_APPLY_P []
-  PUSH_APPLY_PP            -> emit bci_PUSH_APPLY_PP []
-  PUSH_APPLY_PPP           -> emit bci_PUSH_APPLY_PPP []
-  PUSH_APPLY_PPPP          -> emit bci_PUSH_APPLY_PPPP []
-  PUSH_APPLY_PPPPP         -> emit bci_PUSH_APPLY_PPPPP []
-  PUSH_APPLY_PPPPPP        -> emit bci_PUSH_APPLY_PPPPPP []
-
-  SLIDE     n by           -> emit bci_SLIDE [wOp n, wOp by]
-  ALLOC_AP  n              -> emit bci_ALLOC_AP [truncHalfWord platform n]
-  ALLOC_AP_NOUPD n         -> emit bci_ALLOC_AP_NOUPD [truncHalfWord platform n]
-  ALLOC_PAP arity n        -> emit bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]
-  MKAP      off sz         -> emit bci_MKAP [wOp off, truncHalfWord platform sz]
-  MKPAP     off sz         -> emit bci_MKPAP [wOp off, truncHalfWord platform sz]
-  UNPACK    n              -> emit bci_UNPACK [wOp n]
-  PACK      dcon sz        -> do itbl_no <- lit [BCONPtrItbl (getName dcon)]
-                                 emit bci_PACK [Op itbl_no, wOp sz]
+  PUSH_ADDR nm             -> do np <- lit1 (BCONPtrAddr nm)
+                                 emit_ bci_PUSH_UBX [Op np, SmallOp 1]
+
+  PUSH_APPLY_N             -> emit_ bci_PUSH_APPLY_N []
+  PUSH_APPLY_V             -> emit_ bci_PUSH_APPLY_V []
+  PUSH_APPLY_F             -> emit_ bci_PUSH_APPLY_F []
+  PUSH_APPLY_D             -> emit_ bci_PUSH_APPLY_D []
+  PUSH_APPLY_L             -> emit_ bci_PUSH_APPLY_L []
+  PUSH_APPLY_P             -> emit_ bci_PUSH_APPLY_P []
+  PUSH_APPLY_PP            -> emit_ bci_PUSH_APPLY_PP []
+  PUSH_APPLY_PPP           -> emit_ bci_PUSH_APPLY_PPP []
+  PUSH_APPLY_PPPP          -> emit_ bci_PUSH_APPLY_PPPP []
+  PUSH_APPLY_PPPPP         -> emit_ bci_PUSH_APPLY_PPPPP []
+  PUSH_APPLY_PPPPPP        -> emit_ bci_PUSH_APPLY_PPPPPP []
+
+  SLIDE     n by           -> emit_ bci_SLIDE [wOp n, wOp by]
+  ALLOC_AP  n              -> emit_ bci_ALLOC_AP [truncHalfWord platform n]
+  ALLOC_AP_NOUPD n         -> emit_ bci_ALLOC_AP_NOUPD [truncHalfWord platform n]
+  ALLOC_PAP arity n        -> emit_ bci_ALLOC_PAP [truncHalfWord platform arity, truncHalfWord platform n]
+  MKAP      off sz         -> emit_ bci_MKAP [wOp off, truncHalfWord platform sz]
+  MKPAP     off sz         -> emit_ bci_MKPAP [wOp off, truncHalfWord platform sz]
+  UNPACK    n              -> emit_ bci_UNPACK [wOp n]
+  PACK      dcon sz        -> do itbl_no <- lit1 (BCONPtrItbl (getName dcon))
+                                 emit_ bci_PACK [Op itbl_no, wOp sz]
   LABEL     lbl            -> label lbl
   TESTLT_I  i l            -> do np <- int i
-                                 emit bci_TESTLT_I [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_I [Op np, LabelOp l]
   TESTEQ_I  i l            -> do np <- int i
-                                 emit bci_TESTEQ_I [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_I [Op np, LabelOp l]
   TESTLT_W  w l            -> do np <- word w
-                                 emit bci_TESTLT_W [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_W [Op np, LabelOp l]
   TESTEQ_W  w l            -> do np <- word w
-                                 emit bci_TESTEQ_W [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_W [Op np, LabelOp l]
   TESTLT_I64  i l          -> do np <- word64 (fromIntegral i)
-                                 emit bci_TESTLT_I64 [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_I64 [Op np, LabelOp l]
   TESTEQ_I64  i l          -> do np <- word64 (fromIntegral i)
-                                 emit bci_TESTEQ_I64 [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_I64 [Op np, LabelOp l]
   TESTLT_I32  i l          -> do np <- word (fromIntegral i)
-                                 emit bci_TESTLT_I32 [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_I32 [Op np, LabelOp l]
   TESTEQ_I32 i l           -> do np <- word (fromIntegral i)
-                                 emit bci_TESTEQ_I32 [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_I32 [Op np, LabelOp l]
   TESTLT_I16  i l          -> do np <- word (fromIntegral i)
-                                 emit bci_TESTLT_I16 [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_I16 [Op np, LabelOp l]
   TESTEQ_I16 i l           -> do np <- word (fromIntegral i)
-                                 emit bci_TESTEQ_I16 [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_I16 [Op np, LabelOp l]
   TESTLT_I8  i l           -> do np <- word (fromIntegral i)
-                                 emit bci_TESTLT_I8 [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_I8 [Op np, LabelOp l]
   TESTEQ_I8 i l            -> do np <- word (fromIntegral i)
-                                 emit bci_TESTEQ_I8 [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_I8 [Op np, LabelOp l]
   TESTLT_W64  w l          -> do np <- word64 w
-                                 emit bci_TESTLT_W64 [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_W64 [Op np, LabelOp l]
   TESTEQ_W64  w l          -> do np <- word64 w
-                                 emit bci_TESTEQ_W64 [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_W64 [Op np, LabelOp l]
   TESTLT_W32  w l          -> do np <- word (fromIntegral w)
-                                 emit bci_TESTLT_W32 [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_W32 [Op np, LabelOp l]
   TESTEQ_W32  w l          -> do np <- word (fromIntegral w)
-                                 emit bci_TESTEQ_W32 [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_W32 [Op np, LabelOp l]
   TESTLT_W16  w l          -> do np <- word (fromIntegral w)
-                                 emit bci_TESTLT_W16 [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_W16 [Op np, LabelOp l]
   TESTEQ_W16  w l          -> do np <- word (fromIntegral w)
-                                 emit bci_TESTEQ_W16 [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_W16 [Op np, LabelOp l]
   TESTLT_W8  w l           -> do np <- word (fromIntegral w)
-                                 emit bci_TESTLT_W8 [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_W8 [Op np, LabelOp l]
   TESTEQ_W8  w l           -> do np <- word (fromIntegral w)
-                                 emit bci_TESTEQ_W8 [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_W8 [Op np, LabelOp l]
   TESTLT_F  f l            -> do np <- float f
-                                 emit bci_TESTLT_F [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_F [Op np, LabelOp l]
   TESTEQ_F  f l            -> do np <- float f
-                                 emit bci_TESTEQ_F [Op np, LabelOp l]
+                                 emit_ bci_TESTEQ_F [Op np, LabelOp l]
   TESTLT_D  d l            -> do np <- double d
-                                 emit bci_TESTLT_D [Op np, LabelOp l]
+                                 emit_ bci_TESTLT_D [Op np, LabelOp l]
   TESTEQ_D  d l            -> do np <- double d
-                                 emit bci_TESTEQ_D [Op np, LabelOp l]
-  TESTLT_P  i l            -> emit bci_TESTLT_P [SmallOp i, LabelOp l]
-  TESTEQ_P  i l            -> emit bci_TESTEQ_P [SmallOp i, LabelOp l]
-  CASEFAIL                 -> emit bci_CASEFAIL []
-  SWIZZLE   stkoff n       -> emit bci_SWIZZLE [wOp stkoff, IOp n]
-  JMP       l              -> emit bci_JMP [LabelOp l]
-  ENTER                    -> emit bci_ENTER []
-  RETURN rep               -> emit (return_non_tuple rep) []
-  RETURN_TUPLE             -> emit bci_RETURN_T []
+                                 emit_ bci_TESTEQ_D [Op np, LabelOp l]
+  TESTLT_P  i l            -> emit_ bci_TESTLT_P [SmallOp i, LabelOp l]
+  TESTEQ_P  i l            -> emit_ bci_TESTEQ_P [SmallOp i, LabelOp l]
+  CASEFAIL                 -> emit_ bci_CASEFAIL []
+  SWIZZLE   stkoff n       -> emit_ bci_SWIZZLE [wOp stkoff, IOp n]
+  JMP       l              -> emit_ bci_JMP [LabelOp l]
+  ENTER                    -> emit_ bci_ENTER []
+  RETURN rep               -> emit_ (return_non_tuple rep) []
+  RETURN_TUPLE             -> emit_ bci_RETURN_T []
   CCALL off m_addr i       -> do np <- addr m_addr
-                                 emit bci_CCALL [wOp off, Op np, SmallOp i]
-  PRIMCALL                 -> emit bci_PRIMCALL []
-  BRK_FUN arr index mod cc -> do p1 <- ptr (BCOPtrBreakArray arr)
-                                 m <- addr mod
+                                 emit_ bci_CCALL [wOp off, Op np, SmallOp i]
+  PRIMCALL                 -> emit_ bci_PRIMCALL []
+  BRK_FUN arr tick_mod tickx info_mod infox cc ->
+                              do p1 <- ptr (BCOPtrBreakArray arr)
+                                 tick_addr <- addr tick_mod
+                                 info_addr <- addr info_mod
                                  np <- addr cc
-                                 emit bci_BRK_FUN [Op p1, SmallOp index,
-                                                   Op m, Op np]
+                                 emit_ bci_BRK_FUN [ Op p1
+                                                  , Op tick_addr, Op info_addr
+                                                  , SmallOp tickx, SmallOp infox
+                                                  , Op np
+                                                  ]
+#if MIN_VERSION_rts(1,0,3)
+  BCO_NAME name            -> do np <- lit1 (BCONPtrStr name)
+                                 emit_ bci_BCO_NAME [Op np]
+#endif
+
+
 
   where
-    literal (LitLabel fs (Just sz) _)
-     | platformOS platform == OSMinGW32
-         = litlabel (appendFS fs (mkFastString ('@':show sz)))
-     -- On Windows, stdcall labels have a suffix indicating the no. of
-     -- arg words, e.g. foo@8.  testcase: ffi012(ghci)
-    literal (LitLabel fs _ _) = litlabel fs
+    emit_ = emit word_size
+
+    literal :: Literal -> m Word
+    literal (LitLabel fs _)   = litlabel fs
     literal LitNullAddr       = word 0
     literal (LitFloat r)      = float (fromRational r)
     literal (LitDouble r)     = double (fromRational r)
     literal (LitChar c)       = int (ord c)
-    literal (LitString bs)    = lit [BCONPtrStr bs]
+    literal (LitString bs)    = lit1 (BCONPtrStr bs)
        -- LitString requires a zero-terminator when emitted
     literal (LitNumber nt i) = case nt of
       LitNumInt     -> word (fromIntegral i)
@@ -550,10 +778,11 @@ assembleI platform i = case i of
     -- analysis messed up.
     literal (LitRubbish {}) = word 0
 
-    litlabel fs = lit [BCONPtrLbl fs]
-    addr (RemotePtr a) = words [fromIntegral a]
-    words ws = lit (map BCONPtrWord ws)
-    word w = words [w]
+    litlabel fs = lit1 (BCONPtrLbl fs)
+    addr (RemotePtr a) = word (fromIntegral a)
+    words ws = lit (fmap BCONPtrWord ws)
+    word w = words (OnlyOne w)
+    word2 w1 w2 = words (OnlyTwo w1 w2)
     word_size  = platformWordSize platform
     word_size_bits = platformWordSizeInBits platform
 
@@ -564,36 +793,36 @@ assembleI platform i = case i of
     -- Note that we only support host endianness == target endianness for now,
     -- even with the external interpreter. This would need to be fixed to
     -- support host endianness /= target endianness
-    int :: Int -> Assembler Word
+    int :: Int -> m Word
     int  i = word (fromIntegral i)
 
-    float :: Float -> Assembler Word
+    float :: Float -> m Word
     float f = word32 (castFloatToWord32 f)
 
-    double :: Double -> Assembler Word
+    double :: Double -> m Word
     double d = word64 (castDoubleToWord64 d)
 
-    word64 :: Word64 -> Assembler Word
+    word64 :: Word64 -> m Word
     word64 ww = case word_size of
        PW4 ->
         let !wl = fromIntegral ww
             !wh = fromIntegral (ww `unsafeShiftR` 32)
         in case platformByteOrder platform of
-            LittleEndian -> words [wl,wh]
-            BigEndian    -> words [wh,wl]
+            LittleEndian -> word2 wl wh
+            BigEndian    -> word2 wh wl
        PW8 -> word (fromIntegral ww)
 
-    word8 :: Word8 -> Assembler Word
+    word8 :: Word8 -> m Word
     word8  x = case platformByteOrder platform of
       LittleEndian -> word (fromIntegral x)
       BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 8))
 
-    word16 :: Word16 -> Assembler Word
+    word16 :: Word16 -> m Word
     word16 x = case platformByteOrder platform of
       LittleEndian -> word (fromIntegral x)
       BigEndian    -> word (fromIntegral x `unsafeShiftL` (word_size_bits - 16))
 
-    word32 :: Word32 -> Assembler Word
+    word32 :: Word32 -> m Word
     word32 x = case platformByteOrder platform of
       LittleEndian -> word (fromIntegral x)
       BigEndian    -> case word_size of
@@ -635,7 +864,7 @@ return_non_tuple V64 = error "return_non_tuple: vector"
   Note [unboxed tuple bytecodes and tuple_BCO].
 
   If needed, you can support larger tuples by adding more in
-  StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and
+  Jumps.cmm, StgMiscClosures.cmm, Interpreter.c and MiscClosures.h and
   raising this limit.
 
   Note that the limit is the number of words passed on the stack.
@@ -662,10 +891,23 @@ mkNativeCallInfoSig platform NativeCallInfo{..}
               text "Use -fobject-code to get around this limit"
              )
   | otherwise
-  = assertPpr (length regs <= 24) (text "too many registers for bitmap:" <+> ppr (length regs)) {- 24 bits for register bitmap -}
-    assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset) {- 8 bits for continuation offset (only for NativeTupleReturn) -}
-    assertPpr (all (`elem` regs) (regSetToList nativeCallRegs)) (text "not all registers accounted for") {- all regs accounted for -}
-    foldl' reg_bit 0 (zip regs [0..]) .|. (cont_offset `shiftL` 24)
+  = -- 24 bits for register bitmap
+    assertPpr (length argRegs <= 24) (text "too many registers for bitmap:" <+> ppr (length argRegs))
+
+    -- 8 bits for continuation offset (only for NativeTupleReturn)
+    assertPpr (cont_offset < 255) (text "continuation offset too large:" <+> ppr cont_offset)
+
+    -- all regs accounted for
+    assertPpr (all (`elem` (map fst argRegs)) (regSetToList nativeCallRegs))
+      ( vcat
+        [ text "not all registers accounted for"
+        , text "argRegs:" <+> ppr argRegs
+        , text "nativeCallRegs:" <+> ppr nativeCallRegs
+        ] ) $
+      -- SIMD GHCi TODO: the above assertion doesn't account for register overlap;
+      -- it will need to be adjusted for SIMD vector support in the bytecode interpreter.
+
+    foldl' reg_bit 0 argRegs .|. (cont_offset `shiftL` 24)
   where
     cont_offset :: Word32
     cont_offset
@@ -676,7 +918,9 @@ mkNativeCallInfoSig platform NativeCallInfo{..}
     reg_bit x (r, n)
       | r `elemRegSet` nativeCallRegs = x .|. 1 `shiftL` n
       | otherwise                     = x
-    regs = allArgRegsCover platform
+    argRegs = zip (allArgRegsCover platform SCALAR_ARG_REGS) [0..]
+      -- The bytecode interpreter does not (currently) handle vector registers,
+      -- so we only use the scalar argument-passing registers here.
 
 mkNativeCallInfoLit :: Platform -> NativeCallInfo -> Literal
 mkNativeCallInfoLit platform call_info =

compiler/GHC/ByteCode/InfoTable.hs

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

compiler/GHC/ByteCode/Instr.hs

-
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE LambdaCase #-}
 {-# OPTIONS_GHC -funbox-strict-fields #-}
@@ -27,11 +27,16 @@ import GHC.Runtime.Heap.Layout ( StgWord )
 import Data.Int
 import Data.Word
 
+#if MIN_VERSION_rts(1,0,3)
+import Data.ByteString (ByteString)
+#endif
+
 import GHC.Stack.CCS (CostCentre)
 
 import GHC.Stg.Syntax
 import GHCi.BreakArray (BreakArray)
 import Language.Haskell.Syntax.Module.Name (ModuleName)
+import GHC.Types.Unique
 
 -- ----------------------------------------------------------------------------
 -- Bytecode instructions
@@ -54,6 +59,10 @@ data ProtoBCO a
 newtype LocalLabel = LocalLabel { getLocalLabel :: Word32 }
   deriving (Eq, Ord)
 
+-- Just so we can easily juse UniqFM.
+instance Uniquable LocalLabel where
+  getUnique (LocalLabel w) = mkUniqueGrimily $ fromIntegral w
+
 instance Outputable LocalLabel where
   ppr (LocalLabel lbl) = text "lbl:" <> ppr lbl
 
@@ -83,7 +92,7 @@ data BCInstr
    | PUSH16_W !ByteOff
    | PUSH32_W !ByteOff
 
-   -- Push a ptr  (these all map to PUSH_G really)
+   -- Push a (heap) ptr  (these all map to PUSH_G really)
    | PUSH_G       Name
    | PUSH_PRIMOP  PrimOp
    | PUSH_BCO     (ProtoBCO Name)
@@ -130,7 +139,18 @@ data BCInstr
    | PUSH_APPLY_PPPPP
    | PUSH_APPLY_PPPPPP
 
-   | SLIDE     !WordOff{-this many-} !WordOff{-down by this much-}
+   -- | Drop entries @(n, n+by]@ entries from the stack. Graphically:
+   -- @
+   -- a_1  ← top
+   -- ...
+   -- a_n
+   -- b_1              =>    a_1  ← top
+   -- ...                    ...
+   -- b_by                   a_n
+   -- k                      k
+   -- @
+   | SLIDE     !WordOff -- ^ n = this many
+               !WordOff -- ^ by = down by this much
 
    -- To do with the heap
    | ALLOC_AP  !HalfWord {- make an AP with this many payload words.
@@ -175,7 +195,12 @@ data BCInstr
    -- The Word16 value is a constructor number and therefore
    -- stored in the insn stream rather than as an offset into
    -- the literal pool.
+
+   -- | Test whether the tag of a closure pointer is less than the given value.
+   -- If not, jump to the given label.
    | TESTLT_P  !Word16 LocalLabel
+   -- | Test whether the tag of a closure pointer is equal to the given value.
+   -- If not, jump to the given label.
    | TESTEQ_P  !Word16 LocalLabel
 
    | CASEFAIL
@@ -206,9 +231,29 @@ data BCInstr
                    -- Note [unboxed tuple bytecodes and tuple_BCO] in GHC.StgToByteCode
 
    -- Breakpoints
-   | BRK_FUN          (ForeignRef BreakArray) !Word16 (RemotePtr ModuleName)
+   | BRK_FUN          (ForeignRef BreakArray)
+                      (RemotePtr ModuleName) -- breakpoint tick module
+                      !Word16                -- breakpoint tick index
+                      (RemotePtr ModuleName) -- breakpoint info module
+                      !Word16                -- breakpoint info index
                       (RemotePtr CostCentre)
 
+#if MIN_VERSION_rts(1,0,3)
+   -- | A "meta"-instruction for recording the name of a BCO for debugging purposes.
+   -- These are ignored by the interpreter but helpfully printed by the disassmbler.
+   | BCO_NAME         !ByteString
+#endif
+
+
+{- Note [BCO_NAME]
+   ~~~~~~~~~~~~~~~
+   The BCO_NAME instruction is a debugging-aid enabled with the -fadd-bco-name flag.
+   When enabled the bytecode assembler will prepend a BCO_NAME instruction to every
+   generated bytecode object capturing the STG name of the binding the BCO implements.
+   This is then printed by the bytecode disassembler, allowing bytecode objects to be
+   readily correlated with their STG and Core source.
+ -}
+
 -- -----------------------------------------------------------------------------
 -- Printing bytecode instructions
 
@@ -358,8 +403,14 @@ instance Outputable BCInstr where
    ppr ENTER                 = text "ENTER"
    ppr (RETURN pk)           = text "RETURN  " <+> ppr pk
    ppr (RETURN_TUPLE)        = text "RETURN_TUPLE"
-   ppr (BRK_FUN _ index _ _) = text "BRK_FUN" <+> text "<breakarray>"
-                               <+> ppr index <+> text "<module>" <+> text "<cc>"
+   ppr (BRK_FUN _ _tick_mod tickx _info_mod infox _)
+                             = text "BRK_FUN" <+> text "<breakarray>"
+                               <+> text "<tick_module>" <+> ppr tickx
+                               <+> text "<info_module>" <+> ppr infox
+                               <+> text "<cc>"
+#if MIN_VERSION_rts(1,0,3)
+   ppr (BCO_NAME nm)         = text "BCO_NAME" <+> text (show nm)
+#endif
 
 
 
@@ -464,3 +515,6 @@ bciStackUse SLIDE{}               = 0
 bciStackUse MKAP{}                = 0
 bciStackUse MKPAP{}               = 0
 bciStackUse PACK{}                = 1 -- worst case is PACK 0 words
+#if MIN_VERSION_rts(1,0,3)
+bciStackUse BCO_NAME{}            = 0
+#endif

compiler/GHC/ByteCode/Linker.hs

 {-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MagicHash             #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE DataKinds             #-}
 {-# OPTIONS_GHC -optc-DNON_POSIX_SOURCE #-}
 --
 --  (c) The University of Glasgow 2002-2006
@@ -11,7 +13,6 @@ module GHC.ByteCode.Linker
   ( linkBCO
   , lookupStaticPtr
   , lookupIE
-  , nameToCLabel
   , linkFail
   )
 where
@@ -24,7 +25,7 @@ import GHCi.RemoteTypes
 import GHCi.ResolvedBCO
 
 import GHC.Builtin.PrimOps
-import GHC.Builtin.Names
+import GHC.Builtin.PrimOps.Ids
 
 import GHC.Unit.Types
 
@@ -38,8 +39,8 @@ import GHC.Utils.Outputable
 
 import GHC.Types.Name
 import GHC.Types.Name.Env
-
-import Language.Haskell.Syntax.Module.Name
+import qualified GHC.Types.Id as Id
+import GHC.Types.Unique.DFM
 
 -- Standard libraries
 import Data.Array.Unboxed
@@ -52,31 +53,35 @@ import GHC.Exts
 
 linkBCO
   :: Interp
+  -> PkgsLoaded
   -> LinkerEnv
   -> NameEnv Int
   -> UnlinkedBCO
   -> IO ResolvedBCO
-linkBCO interp le bco_ix
+linkBCO interp pkgs_loaded le bco_ix
            (UnlinkedBCO _ arity insns bitmap lits0 ptrs0) = do
   -- fromIntegral Word -> Word64 should be a no op if Word is Word64
   -- otherwise it will result in a cast to longlong on 32bit systems.
-  lits <- mapM (fmap fromIntegral . lookupLiteral interp le) (ssElts lits0)
-  ptrs <- mapM (resolvePtr interp le bco_ix) (ssElts ptrs0)
-  return (ResolvedBCO isLittleEndian arity insns bitmap
-              (listArray (0, fromIntegral (sizeSS lits0)-1) lits)
+  (lits :: [Word]) <- mapM (fmap fromIntegral . lookupLiteral interp pkgs_loaded le) (elemsFlatBag lits0)
+  ptrs <- mapM (resolvePtr interp pkgs_loaded le bco_ix) (elemsFlatBag ptrs0)
+  let lits' = listArray (0 :: Int, fromIntegral (sizeFlatBag lits0)-1) lits
+  return (ResolvedBCO isLittleEndian arity
+              insns
+              bitmap
+              (mkBCOByteArray lits')
               (addListToSS emptySS ptrs))
 
-lookupLiteral :: Interp -> LinkerEnv -> BCONPtr -> IO Word
-lookupLiteral interp le ptr = case ptr of
+lookupLiteral :: Interp -> PkgsLoaded -> LinkerEnv -> BCONPtr -> IO Word
+lookupLiteral interp pkgs_loaded le ptr = case ptr of
   BCONPtrWord lit -> return lit
   BCONPtrLbl  sym -> do
     Ptr a# <- lookupStaticPtr interp sym
     return (W# (int2Word# (addr2Int# a#)))
   BCONPtrItbl nm -> do
-    Ptr a# <- lookupIE interp (itbl_env le) nm
+    Ptr a# <- lookupIE interp pkgs_loaded (itbl_env le) nm
     return (W# (int2Word# (addr2Int# a#)))
   BCONPtrAddr nm -> do
-    Ptr a# <- lookupAddr interp (addr_env le) nm
+    Ptr a# <- lookupAddr interp pkgs_loaded (addr_env le) nm
     return (W# (int2Word# (addr2Int# a#)))
   BCONPtrStr _ ->
     -- should be eliminated during assembleBCOs
@@ -84,60 +89,61 @@ lookupLiteral interp le ptr = case ptr of
 
 lookupStaticPtr :: Interp -> FastString -> IO (Ptr ())
 lookupStaticPtr interp addr_of_label_string = do
-  m <- lookupSymbol interp addr_of_label_string
+  m <- lookupSymbol interp (IFaststringSymbol addr_of_label_string)
   case m of
     Just ptr -> return ptr
     Nothing  -> linkFail "GHC.ByteCode.Linker: can't find label"
-                  (unpackFS addr_of_label_string)
+                  (ppr addr_of_label_string)
 
-lookupIE :: Interp -> ItblEnv -> Name -> IO (Ptr ())
-lookupIE interp ie con_nm =
+lookupIE :: Interp -> PkgsLoaded -> ItblEnv -> Name -> IO (Ptr ())
+lookupIE interp pkgs_loaded ie con_nm =
   case lookupNameEnv ie con_nm of
     Just (_, ItblPtr a) -> return (fromRemotePtr (castRemotePtr a))
     Nothing -> do -- try looking up in the object files.
-       let sym_to_find1 = nameToCLabel con_nm "con_info"
-       m <- lookupSymbol interp sym_to_find1
+       let sym_to_find1 = IConInfoSymbol con_nm
+       m <- lookupHsSymbol interp pkgs_loaded sym_to_find1
        case m of
           Just addr -> return addr
           Nothing
              -> do -- perhaps a nullary constructor?
-                   let sym_to_find2 = nameToCLabel con_nm "static_info"
-                   n <- lookupSymbol interp sym_to_find2
+                   let sym_to_find2 = IStaticInfoSymbol con_nm
+                   n <- lookupHsSymbol interp pkgs_loaded sym_to_find2
                    case n of
                       Just addr -> return addr
                       Nothing   -> linkFail "GHC.ByteCode.Linker.lookupIE"
-                                      (unpackFS sym_to_find1 ++ " or " ++
-                                       unpackFS sym_to_find2)
+                                      (ppr sym_to_find1 <> " or " <>
+                                       ppr sym_to_find2)
 
 -- see Note [Generating code for top-level string literal bindings] in GHC.StgToByteCode
-lookupAddr :: Interp -> AddrEnv -> Name -> IO (Ptr ())
-lookupAddr interp ae addr_nm = do
+lookupAddr :: Interp -> PkgsLoaded -> AddrEnv -> Name -> IO (Ptr ())
+lookupAddr interp pkgs_loaded ae addr_nm = do
   case lookupNameEnv ae addr_nm of
     Just (_, AddrPtr ptr) -> return (fromRemotePtr ptr)
     Nothing -> do -- try looking up in the object files.
-      let sym_to_find = nameToCLabel addr_nm "bytes"
+      let sym_to_find = IBytesSymbol addr_nm
                           -- see Note [Bytes label] in GHC.Cmm.CLabel
-      m <- lookupSymbol interp sym_to_find
+      m <- lookupHsSymbol interp pkgs_loaded sym_to_find
       case m of
         Just ptr -> return ptr
         Nothing -> linkFail "GHC.ByteCode.Linker.lookupAddr"
-                     (unpackFS sym_to_find)
+                     (ppr sym_to_find)
 
-lookupPrimOp :: Interp -> PrimOp -> IO (RemotePtr ())
-lookupPrimOp interp primop = do
+lookupPrimOp :: Interp -> PkgsLoaded -> PrimOp -> IO (RemotePtr ())
+lookupPrimOp interp pkgs_loaded primop = do
   let sym_to_find = primopToCLabel primop "closure"
-  m <- lookupSymbol interp (mkFastString sym_to_find)
+  m <- lookupHsSymbol interp pkgs_loaded (IClosureSymbol (Id.idName $ primOpId primop))
   case m of
     Just p -> return (toRemotePtr p)
-    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" sym_to_find
+    Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE(primop)" (text sym_to_find)
 
 resolvePtr
   :: Interp
+  -> PkgsLoaded
   -> LinkerEnv
   -> NameEnv Int
   -> BCOPtr
   -> IO ResolvedBCOPtr
-resolvePtr interp le bco_ix ptr = case ptr of
+resolvePtr interp pkgs_loaded le bco_ix ptr = case ptr of
   BCOPtrName nm
     | Just ix <- lookupNameEnv bco_ix nm
     -> return (ResolvedBCORef ix) -- ref to another BCO in this group
@@ -148,27 +154,48 @@ resolvePtr interp le bco_ix ptr = case ptr of
     | otherwise
     -> assertPpr (isExternalName nm) (ppr nm) $
        do
-          let sym_to_find = nameToCLabel nm "closure"
-          m <- lookupSymbol interp sym_to_find
+          let sym_to_find = IClosureSymbol nm
+          m <- lookupHsSymbol interp pkgs_loaded sym_to_find
           case m of
             Just p -> return (ResolvedBCOStaticPtr (toRemotePtr p))
-            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (unpackFS sym_to_find)
+            Nothing -> linkFail "GHC.ByteCode.Linker.lookupCE" (ppr sym_to_find)
 
   BCOPtrPrimOp op
-    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp op
+    -> ResolvedBCOStaticPtr <$> lookupPrimOp interp pkgs_loaded op
 
   BCOPtrBCO bco
-    -> ResolvedBCOPtrBCO <$> linkBCO interp le bco_ix bco
+    -> ResolvedBCOPtrBCO <$> linkBCO interp pkgs_loaded le bco_ix bco
 
   BCOPtrBreakArray breakarray
     -> withForeignRef breakarray $ \ba -> return (ResolvedBCOPtrBreakArray ba)
 
-linkFail :: String -> String -> IO a
+-- | Look up the address of a Haskell symbol in the currently
+-- loaded units.
+--
+-- See Note [Looking up symbols in the relevant objects].
+lookupHsSymbol :: Interp -> PkgsLoaded -> InterpSymbol (Suffix s) -> IO (Maybe (Ptr ()))
+lookupHsSymbol interp pkgs_loaded sym_to_find = do
+  massertPpr (isExternalName (interpSymbolName sym_to_find)) (ppr sym_to_find)
+  let pkg_id = moduleUnitId $ nameModule (interpSymbolName sym_to_find)
+      loaded_dlls = maybe [] loaded_pkg_hs_dlls $ lookupUDFM pkgs_loaded pkg_id
+
+      go (dll:dlls) = do
+        mb_ptr <- lookupSymbolInDLL interp dll sym_to_find
+        case mb_ptr of
+          Just ptr -> pure (Just ptr)
+          Nothing -> go dlls
+      go [] =
+        -- See Note [Symbols may not be found in pkgs_loaded] in GHC.Linker.Types
+        lookupSymbol interp sym_to_find
+
+  go loaded_dlls
+
+linkFail :: String -> SDoc -> IO a
 linkFail who what
    = throwGhcExceptionIO (ProgramError $
         unlines [ "",who
                 , "During interactive linking, GHCi couldn't find the following symbol:"
-                , ' ' : ' ' : what
+                , ' ' : ' ' : showSDocUnsafe what
                 , "This may be due to you not asking GHCi to load extra object files,"
                 , "archives or DLLs needed by your current session.  Restart GHCi, specifying"
                 , "the missing library using the -L/path/to/object/dir and -lmissinglibname"
@@ -179,31 +206,14 @@ linkFail who what
                 ])
 
 
-nameToCLabel :: Name -> String -> FastString
-nameToCLabel n suffix = mkFastString label
-  where
-    encodeZ = zString . zEncodeFS
-    (Module pkgKey modName) = assert (isExternalName n) $ case nameModule n of
-        -- Primops are exported from GHC.Prim, their HValues live in GHC.PrimopWrappers
-        -- See Note [Primop wrappers] in GHC.Builtin.PrimOps.
-        mod | mod == gHC_PRIM -> gHC_PRIMOPWRAPPERS
-        mod -> mod
-    packagePart = encodeZ (unitFS pkgKey)
-    modulePart  = encodeZ (moduleNameFS modName)
-    occPart     = encodeZ $ occNameMangledFS (nameOccName n)
 
-    label = concat
-        [ if pkgKey == mainUnit then "" else packagePart ++ "_"
-        , modulePart
-        , '_':occPart
-        , '_':suffix
-        ]
+
 
 
 -- See Note [Primop wrappers] in GHC.Builtin.PrimOps
 primopToCLabel :: PrimOp -> String -> String
 primopToCLabel primop suffix = concat
-    [ "ghczmprim_GHCziPrimopWrappers_"
+    [ "ghczminternal_GHCziInternalziPrimopWrappers_"
     , zString (zEncodeFS (occNameFS (primOpOcc primop)))
     , '_':suffix
     ]

compiler/GHC/ByteCode/Types.hs

 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE MagicHash                  #-}
+{-# LANGUAGE UnliftedNewtypes           #-}
 --
 --  (c) The University of Glasgow 2002-2006
 --
@@ -8,6 +10,7 @@
 -- | Bytecode assembler types
 module GHC.ByteCode.Types
   ( CompiledByteCode(..), seqCompiledByteCode
+  , BCOByteArray(..), mkBCOByteArray
   , FFIInfo(..)
   , RegBitmap(..)
   , NativeCallType(..), NativeCallInfo(..), voidTupleReturnInfo, voidPrimCallInfo
@@ -18,25 +21,27 @@ module GHC.ByteCode.Types
   , CgBreakInfo(..)
   , ModBreaks (..), BreakIndex, emptyModBreaks
   , CCostCentre
+  , FlatBag, sizeFlatBag, fromSmallArray, elemsFlatBag
   ) where
 
 import GHC.Prelude
 
 import GHC.Data.FastString
-import GHC.Data.SizedSeq
+import GHC.Data.FlatBag
 import GHC.Types.Name
 import GHC.Types.Name.Env
 import GHC.Utils.Outputable
 import GHC.Builtin.PrimOps
+import GHC.Types.SptEntry
 import GHC.Types.SrcLoc
 import GHCi.BreakArray
 import GHCi.RemoteTypes
 import GHCi.FFI
 import Control.DeepSeq
+import GHCi.ResolvedBCO ( BCOByteArray(..), mkBCOByteArray )
 
 import Foreign
 import Data.Array
-import Data.Array.Base  ( UArray(..) )
 import Data.ByteString (ByteString)
 import Data.IntMap (IntMap)
 import qualified Data.IntMap as IntMap
@@ -50,19 +55,32 @@ import Language.Haskell.Syntax.Module.Name (ModuleName)
 -- Compiled Byte Code
 
 data CompiledByteCode = CompiledByteCode
-  { bc_bcos   :: [UnlinkedBCO]  -- Bunch of interpretable bindings
-  , bc_itbls  :: ItblEnv        -- A mapping from DataCons to their itbls
-  , bc_ffis   :: [FFIInfo]      -- ffi blocks we allocated
-  , bc_strs   :: AddrEnv        -- malloc'd top-level strings
-  , bc_breaks :: Maybe ModBreaks -- breakpoint info (Nothing if we're not
-                                 -- creating breakpoints, for some reason)
+  { bc_bcos   :: FlatBag UnlinkedBCO
+    -- ^ Bunch of interpretable bindings
+
+  , bc_itbls  :: ItblEnv
+    -- ^ Mapping from DataCons to their info tables
+
+  , bc_ffis   :: [FFIInfo]
+    -- ^ ffi blocks we allocated
+
+  , bc_strs   :: AddrEnv
+    -- ^ top-level strings (heap allocated)
+
+  , bc_breaks :: Maybe ModBreaks
+    -- ^ breakpoint info (Nothing if breakpoints are disabled)
+
+  , bc_spt_entries :: ![SptEntry]
+    -- ^ Static pointer table entries which should be loaded along with the
+    -- BCOs. See Note [Grand plan for static forms] in
+    -- "GHC.Iface.Tidy.StaticPtrTable".
   }
                 -- ToDo: we're not tracking strings that we malloc'd
 newtype FFIInfo = FFIInfo (RemotePtr C_ffi_cif)
   deriving (Show, NFData)
 
 instance Outputable CompiledByteCode where
-  ppr CompiledByteCode{..} = ppr bc_bcos
+  ppr CompiledByteCode{..} = ppr $ elemsFlatBag bc_bcos
 
 -- Not a real NFData instance, because ModBreaks contains some things
 -- we can't rnf
@@ -152,10 +170,10 @@ data UnlinkedBCO
    = UnlinkedBCO {
         unlinkedBCOName   :: !Name,
         unlinkedBCOArity  :: {-# UNPACK #-} !Int,
-        unlinkedBCOInstrs :: !(UArray Int Word16),      -- insns
-        unlinkedBCOBitmap :: !(UArray Int Word64),      -- bitmap
-        unlinkedBCOLits   :: !(SizedSeq BCONPtr),       -- non-ptrs
-        unlinkedBCOPtrs   :: !(SizedSeq BCOPtr)         -- ptrs
+        unlinkedBCOInstrs :: !(BCOByteArray Word16),      -- insns
+        unlinkedBCOBitmap :: !(BCOByteArray Word),      -- bitmap
+        unlinkedBCOLits   :: !(FlatBag BCONPtr),       -- non-ptrs
+        unlinkedBCOPtrs   :: !(FlatBag BCOPtr)         -- ptrs
    }
 
 instance NFData UnlinkedBCO where
@@ -210,8 +228,8 @@ seqCgBreakInfo CgBreakInfo{..} =
 instance Outputable UnlinkedBCO where
    ppr (UnlinkedBCO nm _arity _insns _bitmap lits ptrs)
       = sep [text "BCO", ppr nm, text "with",
-             ppr (sizeSS lits), text "lits",
-             ppr (sizeSS ptrs), text "ptrs" ]
+             ppr (sizeFlatBag lits), text "lits",
+             ppr (sizeFlatBag ptrs), text "ptrs" ]
 
 instance Outputable CgBreakInfo where
    ppr info = text "CgBreakInfo" <+>

compiler/GHC/Cmm.hs

@@ -12,22 +12,28 @@
 
 module GHC.Cmm (
      -- * Cmm top-level datatypes
+     DCmmGroup,
      CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
-     CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
-     CmmDataDecl, cmmDataDeclCmmDecl,
-     CmmGraph, GenCmmGraph(..),
+     CmmDecl, DCmmDecl, CmmDeclSRTs, GenCmmDecl(..),
+     CmmDataDecl, cmmDataDeclCmmDecl, DCmmGraph,
+     CmmGraph, GenCmmGraph, GenGenCmmGraph(..),
      toBlockMap, revPostorder, toBlockList,
      CmmBlock, RawCmmDecl,
      Section(..), SectionType(..),
      GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),
      SectionProtection(..), sectionProtection,
 
+     DWrap(..), unDeterm, removeDeterm, removeDetermDecl, removeDetermGraph,
+
      -- ** Blocks containing lists
      GenBasicBlock(..), blockId,
      ListGraph(..), pprBBlock,
 
      -- * Info Tables
-     CmmTopInfo(..), CmmStackInfo(..), CmmInfoTable(..), topInfoTable,
+     GenCmmTopInfo(..)
+     , DCmmTopInfo
+     , CmmTopInfo
+     , CmmStackInfo(..), CmmInfoTable(..), topInfoTable, topInfoTableD,
      ClosureTypeInfo(..),
      ProfilingInfo(..), ConstrDescription,
 
@@ -50,7 +56,6 @@ import GHC.Cmm.Node
 import GHC.Runtime.Heap.Layout
 import GHC.Cmm.Expr
 import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Label
 import GHC.Utils.Outputable
@@ -75,6 +80,8 @@ import qualified Data.ByteString as BS
 type CmmProgram = [CmmGroup]
 
 type GenCmmGroup d h g = [GenCmmDecl d h g]
+-- | Cmm group after STG generation
+type DCmmGroup    = GenCmmGroup CmmStatics    DCmmTopInfo              DCmmGraph
 -- | Cmm group before SRT generation
 type CmmGroup     = GenCmmGroup CmmStatics    CmmTopInfo               CmmGraph
 -- | Cmm group with SRTs
@@ -101,7 +108,7 @@ data GenCmmDecl d h g
   = CmmProc     -- A procedure
      h                 -- Extra header such as the info table
      CLabel            -- Entry label
-     [GlobalReg]       -- Registers live on entry. Note that the set of live
+     [GlobalRegUse]    -- Registers live on entry. Note that the set of live
                        -- registers will be correct in generated C-- code, but
                        -- not in hand-written C-- code. However,
                        -- splitAtProcPoints calculates correct liveness
@@ -118,6 +125,7 @@ instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platfor
       => OutputableP Platform (GenCmmDecl d info i) where
     pdoc = pprTop
 
+type DCmmDecl    = GenCmmDecl CmmStatics DCmmTopInfo DCmmGraph
 type CmmDecl     = GenCmmDecl CmmStatics    CmmTopInfo CmmGraph
 type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
 type CmmDataDecl = GenCmmDataDecl CmmStatics
@@ -140,7 +148,11 @@ type RawCmmDecl
 -----------------------------------------------------------------------------
 
 type CmmGraph = GenCmmGraph CmmNode
-data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
+type DCmmGraph = GenGenCmmGraph DWrap CmmNode
+
+type GenCmmGraph n = GenGenCmmGraph LabelMap n
+
+data GenGenCmmGraph s n = CmmGraph { g_entry :: BlockId, g_graph :: Graph' s Block n C C }
 type CmmBlock = Block CmmNode C C
 
 instance OutputableP Platform CmmGraph where
@@ -172,8 +184,16 @@ toBlockList g = mapElems $ toBlockMap g
 
 -- | CmmTopInfo is attached to each CmmDecl (see defn of CmmGroup), and contains
 -- the extra info (beyond the executable code) that belongs to that CmmDecl.
-data CmmTopInfo   = TopInfo { info_tbls  :: LabelMap CmmInfoTable
-                            , stack_info :: CmmStackInfo }
+data GenCmmTopInfo f = TopInfo { info_tbls  :: f CmmInfoTable
+                               , stack_info :: CmmStackInfo }
+
+newtype DWrap a = DWrap [(BlockId, a)]
+
+unDeterm :: DWrap a -> [(BlockId, a)]
+unDeterm (DWrap f) = f
+
+type DCmmTopInfo = GenCmmTopInfo DWrap
+type CmmTopInfo  = GenCmmTopInfo LabelMap
 
 instance OutputableP Platform CmmTopInfo where
     pdoc = pprTopInfo
@@ -183,7 +203,12 @@ pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
   vcat [text "info_tbls: " <> pdoc platform info_tbl,
         text "stack_info: " <> ppr stack_info]
 
-topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
+topInfoTableD :: GenCmmDecl a DCmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable
+topInfoTableD (CmmProc infos _ _ g) = case (info_tbls infos) of
+                                          DWrap xs -> lookup (g_entry g) xs
+topInfoTableD _                     = Nothing
+
+topInfoTable :: GenCmmDecl a CmmTopInfo (GenGenCmmGraph s n) -> Maybe CmmInfoTable
 topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
 topInfoTable _                     = Nothing
 
@@ -238,6 +263,7 @@ data ProfilingInfo
   = NoProfilingInfo
   | ProfilingInfo ByteString ByteString -- closure_type, closure_desc
   deriving (Eq, Ord)
+
 -----------------------------------------------------------------------------
 --              Static Data
 -----------------------------------------------------------------------------
@@ -305,7 +331,7 @@ instance Outputable CmmStatic where
   ppr (CmmString _) = text "CmmString"
   ppr (CmmFileEmbed fp _) = text "CmmFileEmbed" <+> text fp
 
--- Static data before SRT generation
+-- | Static data before or after SRT generation
 data GenCmmStatics (rawOnly :: Bool) where
     CmmStatics
       :: CLabel       -- Label of statics
@@ -329,6 +355,61 @@ instance OutputableP Platform (GenCmmStatics a) where
 type CmmStatics    = GenCmmStatics 'False
 type RawCmmStatics = GenCmmStatics 'True
 
+{-
+-----------------------------------------------------------------------------
+--              Deterministic Cmm / Info Tables
+-----------------------------------------------------------------------------
+
+Note [DCmmGroup vs CmmGroup or: Deterministic Info Tables]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+
+Consulting Note [Object determinism] one will learn that in order to produce
+deterministic objects just after cmm is produced we perform a renaming pass which
+provides fresh uniques for all unique-able things in the input Cmm.
+
+After this point, we use a deterministic unique supply (an incrementing counter)
+so any resulting labels which make their way into object code have a deterministic name.
+
+A key assumption to this process is that the input is deterministic modulo the uniques
+and the order that bindings appear in the definitions is the same.
+
+CmmGroup uses LabelMap in two places:
+
+* In CmmProc for info tables
+* In CmmGraph for the blocks of the graph
+
+LabelMap is not a deterministic structure, so traversing a LabelMap can process
+elements in different order (depending on the given uniques).
+
+Therefore before we do the renaming we need to use a deterministic structure, one
+which we can traverse in a guaranteed order. A list does the job perfectly.
+
+Once the renaming happens it is converted back into a LabelMap, which is now deterministic
+due to the uniques being generated and assigned in a deterministic manner.
+
+We prefer using the renamed LabelMap rather than the list in the rest of the
+code generation because it is much more efficient than lists for the needs of
+the code generator.
+-}
+
+-- Converting out of deterministic Cmm
+
+removeDeterm :: DCmmGroup -> CmmGroup
+removeDeterm = map removeDetermDecl
+
+removeDetermDecl :: DCmmDecl -> CmmDecl
+removeDetermDecl (CmmProc h e r g) = CmmProc (removeDetermTop h) e r (removeDetermGraph g)
+removeDetermDecl (CmmData a b) = CmmData a b
+
+removeDetermTop :: DCmmTopInfo -> CmmTopInfo
+removeDetermTop (TopInfo a b) = TopInfo (mapFromList $ unDeterm a) b
+
+removeDetermGraph :: DCmmGraph -> CmmGraph
+removeDetermGraph (CmmGraph x y) =
+  let y' = case y of
+            GMany a (DWrap b) c -> GMany a (mapFromList b) c
+  in CmmGraph x y'
+
 -- -----------------------------------------------------------------------------
 -- Basic blocks consisting of lists
 

compiler/GHC/Cmm/BlockId.hs

@@ -15,7 +15,7 @@ import GHC.Data.FastString
 import GHC.Types.Id.Info
 import GHC.Types.Name
 import GHC.Types.Unique
-import GHC.Types.Unique.Supply
+import qualified GHC.Types.Unique.DSM as DSM
 
 import GHC.Cmm.Dataflow.Label (Label, mkHooplLabel)
 
@@ -36,8 +36,12 @@ type BlockId = Label
 mkBlockId :: Unique -> BlockId
 mkBlockId unique = mkHooplLabel $ getKey unique
 
-newBlockId :: MonadUnique m => m BlockId
-newBlockId = mkBlockId <$> getUniqueM
+-- If the monad unique instance uses a deterministic unique supply, this will
+-- give you a deterministic unique. Otherwise, it will not. Note that from Cmm
+-- onwards (after deterministic renaming in 'codeGen'), there should only exist
+-- deterministic block labels.
+newBlockId :: DSM.MonadGetUnique m => m BlockId
+newBlockId = mkBlockId <$> DSM.getUniqueM
 
 blockLbl :: BlockId -> CLabel
 blockLbl label = mkLocalBlockLabel (getUnique label)

compiler/GHC/Cmm/CLabel.hs

+{-# LANGUAGE LambdaCase #-}
+
 -----------------------------------------------------------------------------
 --
 -- Object-file symbols (called CLabel for historical reasons).
@@ -6,11 +8,6 @@
 --
 -----------------------------------------------------------------------------
 
-{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-
 module GHC.Cmm.CLabel (
         CLabel, -- abstract type
         NeedExternDecl (..),
@@ -128,6 +125,7 @@ module GHC.Cmm.CLabel (
         toSlowEntryLbl,
         toEntryLbl,
         toInfoLbl,
+        toProcDelimiterLbl,
 
         -- * Pretty-printing
         LabelStyle (..),
@@ -138,8 +136,10 @@ module GHC.Cmm.CLabel (
 
         -- * Others
         dynamicLinkerLabelInfo,
-        addLabelSize,
-        foreignLabelStdcallInfo
+        CStubLabel (..),
+        cStubLabel,
+        fromCStubLabel,
+        mapInternalNonDetUniques
     ) where
 
 import GHC.Prelude
@@ -240,10 +240,6 @@ data CLabel
   | ForeignLabel
         FastString              -- ^ name of the imported label.
 
-        (Maybe Int)             -- ^ possible '@n' suffix for stdcall functions
-                                -- When generating C, the '@n' suffix is omitted, but when
-                                -- generating assembler we must add it to the label.
-
         ForeignLabelSource      -- ^ what package the foreign label is in.
 
         FunctionOrData
@@ -346,29 +342,40 @@ newtype NeedExternDecl
    deriving (Ord,Eq)
 
 -- This is laborious, but necessary. We can't derive Ord because
--- Unique doesn't have an Ord instance. Note nonDetCmpUnique in the
--- implementation. See Note [No Ord for Unique]
--- This is non-deterministic but we do not currently support deterministic
--- code-generation. See Note [Unique Determinism and code generation]
+-- Unique has a special Ord instance that cares for object determinism.
+-- Note nonDetCmpUnique and stableNameCmp in the implementation:
+--  * If -fobject-determinism, the internal uniques will be renamed, thus the
+--  comparison will actually be deterministic
+--  * Stable name compare guarantees deterministic ordering of Names despite
+--  the non-deterministic uniques underlying external names (which aren't
+--  renamed on -fobject-determinism).
+-- See Note [Unique Determinism and code generation] and Note [Object determinism]
 instance Ord CLabel where
+  compare (IdLabel a1 b1 c1)
+          (IdLabel a2 b2 c2)
+          | isExternalName a1, isExternalName a2 = stableNameCmp a1 a2 S.<> compare b1 b2 S.<> compare c1 c2
+          | isExternalName a1 = GT
+          | isExternalName a2 = LT
+
   compare (IdLabel a1 b1 c1) (IdLabel a2 b2 c2) =
+    -- Comparing names here should deterministic because all unique should have
+    -- been renamed deterministically, and external names compared above.
     compare a1 a2 S.<>
     compare b1 b2 S.<>
     compare c1 c2
   compare (CmmLabel a1 b1 c1 d1) (CmmLabel a2 b2 c2 d2) =
     compare a1 a2 S.<>
     compare b1 b2 S.<>
-    -- This non-determinism is "safe" in the sense that it only affects object code,
-    -- which is currently not covered by GHC's determinism guarantees. See #12935.
+    -- This is not non-deterministic because the uniques have been deterministically renamed.
+    -- See Note [Object determinism]
     uniqCompareFS c1 c2 S.<>
     compare d1 d2
   compare (RtsLabel a1) (RtsLabel a2) = compare a1 a2
   compare (LocalBlockLabel u1) (LocalBlockLabel u2) = nonDetCmpUnique u1 u2
-  compare (ForeignLabel a1 b1 c1 d1) (ForeignLabel a2 b2 c2 d2) =
+  compare (ForeignLabel a1 b1 c1) (ForeignLabel a2 b2 c2) =
     uniqCompareFS a1 a2 S.<>
     compare b1 b2 S.<>
-    compare c1 c2 S.<>
-    compare d1 d2
+    compare c1 c2
   compare (AsmTempLabel u1) (AsmTempLabel u2) = nonDetCmpUnique u1 u2
   compare (AsmTempDerivedLabel a1 b1) (AsmTempDerivedLabel a2 b2) =
     compare a1 a2 S.<>
@@ -470,8 +477,8 @@ pprDebugCLabel platform lbl = pprAsmLabel platform lbl <> parens extra
          RtsLabel{}
             -> text "RtsLabel"
 
-         ForeignLabel _name mSuffix src funOrData
-             -> text "ForeignLabel" <+> ppr mSuffix <+> ppr src <+> ppr funOrData
+         ForeignLabel _name src funOrData
+             -> text "ForeignLabel" <+> ppr src <+> ppr funOrData
 
          _  -> text "other CLabel"
 
@@ -652,7 +659,7 @@ mkDirty_MUT_VAR_Label,
     mkSMAP_DIRTY_infoLabel, mkBadAlignmentLabel,
     mkOutOfBoundsAccessLabel, mkMemcpyRangeOverlapLabel,
     mkMUT_VAR_CLEAN_infoLabel :: CLabel
-mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") Nothing ForeignLabelInExternalPackage IsFunction
+mkDirty_MUT_VAR_Label           = mkForeignLabel (fsLit "dirty_MUT_VAR") ForeignLabelInExternalPackage IsFunction
 mkNonmovingWriteBarrierEnabledLabel
                                 = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "nonmoving_write_barrier_enabled") CmmData
 mkOrigThunkInfoLabel            = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_orig_thunk_info_frame") CmmInfo
@@ -670,8 +677,8 @@ mkSMAP_FROZEN_CLEAN_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsL
 mkSMAP_FROZEN_DIRTY_infoLabel   = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_FROZEN_DIRTY") CmmInfo
 mkSMAP_DIRTY_infoLabel          = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_SMALL_MUT_ARR_PTRS_DIRTY") CmmInfo
 mkBadAlignmentLabel             = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_badAlignment")      CmmEntry
-mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess")  Nothing ForeignLabelInExternalPackage IsFunction
-mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") Nothing ForeignLabelInExternalPackage IsFunction
+mkOutOfBoundsAccessLabel        = mkForeignLabel (fsLit "rtsOutOfBoundsAccess") ForeignLabelInExternalPackage IsFunction
+mkMemcpyRangeOverlapLabel       = mkForeignLabel (fsLit "rtsMemcpyRangeOverlap") ForeignLabelInExternalPackage IsFunction
 mkMUT_VAR_CLEAN_infoLabel       = CmmLabel rtsUnitId (NeedExternDecl False) (fsLit "stg_MUT_VAR_CLEAN")     CmmInfo
 
 mkSRTInfoLabel :: Int -> CLabel
@@ -755,21 +762,12 @@ mkPrimCallLabel (PrimCall str pkg)
 -- | Make a foreign label
 mkForeignLabel
         :: FastString           -- name
-        -> Maybe Int            -- size prefix
         -> ForeignLabelSource   -- what package it's in
         -> FunctionOrData
         -> CLabel
 
 mkForeignLabel = ForeignLabel
 
-
--- | Update the label size field in a ForeignLabel
-addLabelSize :: CLabel -> Int -> CLabel
-addLabelSize (ForeignLabel str _ src  fod) sz
-    = ForeignLabel str (Just sz) src fod
-addLabelSize label _
-    = label
-
 -- | Whether label is a top-level string literal
 isBytesLabel :: CLabel -> Bool
 isBytesLabel (IdLabel _ _ Bytes) = True
@@ -777,7 +775,7 @@ isBytesLabel _lbl = False
 
 -- | Whether label is a non-haskell label (defined in C code)
 isForeignLabel :: CLabel -> Bool
-isForeignLabel (ForeignLabel _ _ _ _) = True
+isForeignLabel (ForeignLabel _ _ _) = True
 isForeignLabel _lbl = False
 
 -- | Whether label is a static closure label (can come from haskell or cmm)
@@ -820,12 +818,6 @@ isConInfoTableLabel :: CLabel -> Bool
 isConInfoTableLabel (IdLabel _ _ ConInfoTable {})   = True
 isConInfoTableLabel _                            = False
 
--- | Get the label size field from a ForeignLabel
-foreignLabelStdcallInfo :: CLabel -> Maybe Int
-foreignLabelStdcallInfo (ForeignLabel _ info _ _) = info
-foreignLabelStdcallInfo _lbl = Nothing
-
-
 -- Constructing Large*Labels
 mkBitmapLabel   :: Unique -> CLabel
 mkBitmapLabel   uniq            = LargeBitmapLabel uniq
@@ -950,6 +942,16 @@ toEntryLbl platform lbl = case lbl of
    CmmLabel m ext str CmmRetInfo -> CmmLabel m ext str CmmRet
    _                             -> pprPanic "toEntryLbl" (pprDebugCLabel platform lbl)
 
+-- | Generate a CmmProc delimiter label from the actual entry label.
+--
+-- This delimiter label might be the entry label itself, except when the entry
+-- label is a LocalBlockLabel. If we reused the entry label to delimit the proc,
+-- we would generate redundant labels (see #22792)
+toProcDelimiterLbl :: CLabel -> CLabel
+toProcDelimiterLbl lbl = case lbl of
+  LocalBlockLabel {} -> mkAsmTempDerivedLabel lbl (fsLit "_entry")
+  _                  -> lbl
+
 toInfoLbl :: Platform -> CLabel -> CLabel
 toInfoLbl platform lbl = case lbl of
    IdLabel n c LocalEntry      -> IdLabel n c LocalInfoTable
@@ -1057,7 +1059,7 @@ maybeLocalBlockLabel _                     = Nothing
 --      to the C compiler. For these labels we avoid generating our
 --      own C prototypes.
 isMathFun :: CLabel -> Bool
-isMathFun (ForeignLabel fs _ _ _)       = fs `elementOfUniqSet` math_funs
+isMathFun (ForeignLabel fs _ _)       = fs `elementOfUniqSet` math_funs
 isMathFun _ = False
 
 math_funs :: UniqSet FastString
@@ -1222,8 +1224,8 @@ labelType (RtsLabel (RtsPrimOp _))              = CodeLabel
 labelType (RtsLabel (RtsSlowFastTickyCtr _))    = DataLabel
 labelType (LocalBlockLabel _)                   = CodeLabel
 labelType (SRTLabel _)                          = DataLabel
-labelType (ForeignLabel _ _ _ IsFunction)       = CodeLabel
-labelType (ForeignLabel _ _ _ IsData)           = DataLabel
+labelType (ForeignLabel _ _ IsFunction)         = CodeLabel
+labelType (ForeignLabel _ _ IsData)             = DataLabel
 labelType (AsmTempLabel _)                      = panic "labelType(AsmTempLabel)"
 labelType (AsmTempDerivedLabel _ _)             = panic "labelType(AsmTempDerivedLabel)"
 labelType (StringLitLabel _)                    = DataLabel
@@ -1302,7 +1304,7 @@ labelDynamic this_mod platform external_dynamic_refs lbl =
 
    LocalBlockLabel _    -> False
 
-   ForeignLabel _ _ source _  ->
+   ForeignLabel _ source _  ->
        if os == OSMinGW32
        then case source of
             -- Foreign label is in some un-named foreign package (or DLL).
@@ -1429,11 +1431,11 @@ allocation.  Take care if you want to remove them!
 
 -- | Style of label pretty-printing.
 --
--- When we produce C sources or headers, we have to take into account that C
--- compilers transform C labels when they convert them into symbols. For
--- example, they can add prefixes (e.g., "_" on Darwin) or suffixes (size for
--- stdcalls on Windows). So we provide two ways to pretty-print CLabels: C style
--- or Asm style.
+-- When we produce C sources or headers, we have to take into account
+-- that C compilers transform C labels when they convert them into
+-- symbols. For example, they can add prefixes (e.g., "_" on Darwin).
+-- So we provide two ways to pretty-print CLabels: C style or Asm
+-- style.
 --
 data LabelStyle
    = CStyle   -- ^ C label style (used by C and LLVM backends)
@@ -1484,10 +1486,17 @@ pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel]
       -> tempLabelPrefixOrUnderscore <> pprUniqueAlways u
 
    AsmTempDerivedLabel l suf
-      -> asmTempLabelPrefix platform
-         <> case l of AsmTempLabel u    -> pprUniqueAlways u
-                      LocalBlockLabel u -> pprUniqueAlways u
-                      _other            -> pprCLabelStyle platform sty l
+         -- we print a derived label, so we just print the parent label
+         -- recursively. However we don't want to print the temp prefix (e.g.
+         -- ".L") twice, so we must explicitely handle these cases.
+      -> let skipTempPrefix = \case
+                AsmTempLabel u            -> pprUniqueAlways u
+                AsmTempDerivedLabel l suf -> skipTempPrefix l <> ftext suf
+                LocalBlockLabel u         -> pprUniqueAlways u
+                lbl                       -> pprAsmLabel platform lbl
+         in
+         asmTempLabelPrefix platform
+         <> skipTempPrefix l
          <> ftext suf
 
    DynamicLinkerLabel info lbl
@@ -1509,17 +1518,9 @@ pprCLabelStyle !platform !sty lbl = -- see Note [Bangs in CLabel]
    StringLitLabel u
       -> maybe_underscore $ pprUniqueAlways u <> text "_str"
 
-   ForeignLabel fs (Just sz) _ _
-      | AsmStyle <- sty
-      , OSMinGW32 <- platformOS platform
-      -> -- In asm mode, we need to put the suffix on a stdcall ForeignLabel.
-         -- (The C compiler does this itself).
-         maybe_underscore $ ftext fs <> char '@' <> int sz
-
-   ForeignLabel fs _ _ _
+   ForeignLabel fs _ _
       -> maybe_underscore $ ftext fs
 
-
    IdLabel name _cafs flavor -> case sty of
       AsmStyle -> maybe_underscore $ internalNamePrefix <> pprName name <> ppIdFlavor flavor
                    where
@@ -1694,11 +1695,7 @@ pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
             GotSymbolPtr    -> ppLbl <> text "@GOTPCREL"
             GotSymbolOffset -> ppLbl
         | platformArch platform == ArchAArch64 -> ppLbl
-        | otherwise ->
-          case dllInfo of
-            CodeStub  -> char 'L' <> ppLbl <> text "$stub"
-            SymbolPtr -> char 'L' <> ppLbl <> text "$non_lazy_ptr"
-            _         -> panic "pprDynamicLinkerAsmLabel"
+        | otherwise -> panic "pprDynamicLinkerAsmLabel"
 
       OSAIX ->
           case dllInfo of
@@ -1725,6 +1722,8 @@ pprDynamicLinkerAsmLabel !platform dllInfo ppLbl =
       | platformArch platform == ArchAArch64
       = ppLbl
 
+      | platformArch platform == ArchRISCV64
+      = ppLbl
 
       | platformArch platform == ArchX86_64
       = case dllInfo of
@@ -1883,3 +1882,74 @@ The transformation is performed because
      T15155.a_closure `mayRedirectTo` a1_rXq_closure+1
 returns True.
 -}
+
+-- | This type encodes the subset of 'CLabel' that occurs in C stubs of foreign
+-- declarations for the purpose of serializing to interface files.
+--
+-- See Note [Foreign stubs and TH bytecode linking]
+data CStubLabel =
+  CStubLabel {
+    csl_is_initializer :: Bool,
+    csl_module :: Module,
+    csl_name :: FastString
+  }
+
+instance Outputable CStubLabel where
+  ppr CStubLabel {csl_is_initializer, csl_module, csl_name} =
+    text ini <+> ppr csl_module <> colon <> text (unpackFS csl_name)
+    where
+      ini = if csl_is_initializer then "initializer" else "finalizer"
+
+-- | Project the constructor 'ModuleLabel' out of 'CLabel' if it is an
+-- initializer or finalizer.
+cStubLabel :: CLabel -> Maybe CStubLabel
+cStubLabel = \case
+  ModuleLabel csl_module label_kind -> do
+    (csl_is_initializer, csl_name) <- case label_kind of
+      MLK_Initializer (LexicalFastString s) -> Just (True, s)
+      MLK_Finalizer (LexicalFastString s) -> Just (False, s)
+      _ -> Nothing
+    Just (CStubLabel {csl_is_initializer, csl_module, csl_name})
+  _ -> Nothing
+
+-- | Inject a 'CStubLabel' into a 'CLabel' as a 'ModuleLabel'.
+fromCStubLabel :: CStubLabel -> CLabel
+fromCStubLabel (CStubLabel {csl_is_initializer, csl_module, csl_name}) =
+  ModuleLabel csl_module (label_kind (LexicalFastString csl_name))
+  where
+    label_kind =
+      if csl_is_initializer
+      then MLK_Initializer
+      else MLK_Finalizer
+
+-- | A utility for renaming uniques in CLabels to produce deterministic object.
+-- Note that not all Uniques are mapped over. Only those that can be safely alpha
+-- renamed, e.g. uniques of local symbols, but not of external ones.
+-- See Note [Renaming uniques deterministically].
+mapInternalNonDetUniques :: Applicative m => (Unique -> m Unique) -> CLabel -> m CLabel
+-- todo: Can we do less work here, e.g., do we really need to rename AsmTempLabel, LocalBlockLabel?
+mapInternalNonDetUniques f x = case x of
+  IdLabel name cafInfo idLabelInfo
+    | not (isExternalName name) -> IdLabel . setNameUnique name <$> f (nameUnique name) <*> pure cafInfo <*> pure idLabelInfo
+    | otherwise -> pure x
+  cl@CmmLabel{} -> pure cl
+  RtsLabel rtsLblInfo -> pure $ RtsLabel rtsLblInfo
+  LocalBlockLabel unique -> LocalBlockLabel <$> f unique
+  fl@ForeignLabel{} -> pure fl
+  AsmTempLabel unique -> AsmTempLabel <$> f unique
+  AsmTempDerivedLabel clbl fs -> AsmTempDerivedLabel <$> mapInternalNonDetUniques f clbl <*> pure fs
+  StringLitLabel unique -> StringLitLabel <$> f unique
+  CC_Label  cc -> pure $ CC_Label cc
+  CCS_Label ccs -> pure $ CCS_Label ccs
+  IPE_Label ipe@InfoProvEnt{infoTablePtr} ->
+    (\cl' -> IPE_Label ipe{infoTablePtr = cl'}) <$> mapInternalNonDetUniques f infoTablePtr
+  ml@ModuleLabel{} -> pure ml
+  DynamicLinkerLabel dlli clbl -> DynamicLinkerLabel dlli <$> mapInternalNonDetUniques f clbl
+  PicBaseLabel -> pure PicBaseLabel
+  DeadStripPreventer clbl -> DeadStripPreventer <$> mapInternalNonDetUniques f clbl
+  HpcTicksLabel mod -> pure $ HpcTicksLabel mod
+  SRTLabel unique -> SRTLabel <$> f unique
+  LargeBitmapLabel unique -> LargeBitmapLabel <$> f unique
+-- This is called *a lot* if renaming Cmm uniques, and won't specialise without this pragma:
+{-# INLINABLE mapInternalNonDetUniques #-}
+

compiler/GHC/Cmm/CallConv.hs

@@ -7,17 +7,21 @@ module GHC.Cmm.CallConv (
 ) where
 
 import GHC.Prelude
-import Data.List (nub)
 
 import GHC.Cmm.Expr
+import GHC.Cmm.Reg (GlobalArgRegs(..))
 import GHC.Runtime.Heap.Layout
 import GHC.Cmm (Convention(..))
 
 import GHC.Platform
+import GHC.Platform.Reg.Class
 import GHC.Platform.Profile
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 
+import Data.Maybe ( maybeToList )
+import Data.List (nub)
+
 -- Calculate the 'GlobalReg' or stack locations for function call
 -- parameters as used by the Cmm calling convention.
 
@@ -67,14 +71,16 @@ assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments)
       assign_regs assts (r:rs) regs | isVecType ty   = vec
                                     | isFloatType ty = float
                                     | otherwise      = int
-        where vec = case (w, regs) of
-                      (W128, AvailRegs vs fs ds ls (s:ss))
-                          | passVectorInReg W128 profile -> k (RegisterParam (XmmReg s), AvailRegs vs fs ds ls ss)
-                      (W256, AvailRegs vs fs ds ls (s:ss))
-                          | passVectorInReg W256 profile -> k (RegisterParam (YmmReg s), AvailRegs vs fs ds ls ss)
-                      (W512, AvailRegs vs fs ds ls (s:ss))
-                          | passVectorInReg W512 profile -> k (RegisterParam (ZmmReg s), AvailRegs vs fs ds ls ss)
-                      _ -> (assts, (r:rs))
+        where vec = case regs of
+                      AvailRegs vs fs ds ls (s:ss)
+                        | passVectorInReg w profile
+                          -> let reg_class = case w of
+                                    W128 -> XmmReg
+                                    W256 -> YmmReg
+                                    W512 -> ZmmReg
+                                    _    -> panic "CmmCallConv.assignArgumentsPos: Invalid vector width"
+                              in k (RegisterParam (reg_class s), AvailRegs vs fs ds ls ss)
+                      _ -> (assts, r:rs)
               float = case (w, regs) of
                         (W32, AvailRegs vs fs ds ls (s:ss))
                             | passFloatInXmm          -> k (RegisterParam (FloatReg s), AvailRegs vs fs ds ls ss)
@@ -98,10 +104,15 @@ assignArgumentsPos profile off conv arg_ty reps = (stk_off, assignments)
               passFloatInXmm = passFloatArgsInXmm platform
 
 passFloatArgsInXmm :: Platform -> Bool
-passFloatArgsInXmm platform = case platformArch platform of
-                              ArchX86_64 -> True
-                              ArchX86    -> False
-                              _          -> False
+passFloatArgsInXmm platform =
+  -- TODO: replace the following logic by casing on @registerArch (platformArch platform)@.
+  --
+  -- This will mean we start saying "True" for AArch64, which the rest of the AArch64
+  -- compilation pipeline will need to be able to handle (e.g. the AArch64 NCG).
+  case platformArch platform of
+    ArchX86_64 -> True
+    ArchX86    -> False
+    _          -> False
 
 -- We used to spill vector registers to the stack since the LLVM backend didn't
 -- support vector registers in its calling convention. However, this has now
@@ -213,131 +224,101 @@ allRegs platform =
 nodeOnly :: AvailRegs
 nodeOnly = noAvailRegs { availVanillaRegs = [VanillaReg 1] }
 
--- This returns the set of global registers that *cover* the machine registers
--- used for argument passing. On platforms where registers can overlap---right
--- now just x86-64, where Float and Double registers overlap---passing this set
--- of registers is guaranteed to preserve the contents of all live registers. We
--- only use this functionality in hand-written C-- code in the RTS.
-realArgRegsCover :: Platform -> [GlobalReg]
-realArgRegsCover platform
-    | passFloatArgsInXmm platform
-    = realVanillaRegs    platform ++
-      realLongRegs       platform ++
-      realDoubleRegs     platform
-        -- we only need to save the low Double part of XMM registers.
-        -- Moreover, the NCG can't load/store full XMM
-        -- registers for now...
-
-    | otherwise
-    = realVanillaRegs platform ++
-      realFloatRegs   platform ++
-      realDoubleRegs  platform ++
-      realLongRegs    platform
-        -- we don't save XMM registers if they are not used for parameter passing
-
-
-{-
-
-  Note [GHCi and native call registers]
-  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-  The GHCi bytecode interpreter does not have access to the STG registers
-  that the native calling convention uses for passing arguments. It uses
-  helper stack frames to move values between the stack and registers.
-
-  If only a single register needs to be moved, GHCi uses a specific stack
-  frame. For example stg_ctoi_R1p saves a heap pointer value from STG register
-  R1 and stg_ctoi_D1 saves a double precision floating point value from D1.
-  In the other direction, helpers stg_ret_p and stg_ret_d move a value from
-  the stack to the R1 and D1 registers, respectively.
-
-  When GHCi needs to move more than one register it cannot use a specific
-  helper frame. It would simply be impossible to create a helper for all
-  possible combinations of register values. Instead, there are generic helper
-  stack frames that use a call_info word that describes the active registers
-  and the number of stack words used by the arguments of a call.
-
-  These helper stack frames are currently:
-
-      - stg_ret_t:    return a tuple to the continuation at the top of
-                          the stack
-      - stg_ctoi_t:   convert a tuple return value to be used in
-                          bytecode
-      - stg_primcall: call a function
-
-
-  The call_info word contains a bitmap of the active registers
-  for the call and and a stack offset. The layout is as follows:
-
-      - bit 0-23:  Bitmap of active registers for the call, the
-                   order corresponds to the list returned by
-                   allArgRegsCover. For example if bit 0 (the least
-                   significant bit) is set, the first register in the
-                   allArgRegsCover list is active. Bit 1 for the
-                   second register in the list and so on.
-
-      - bit 24-31: Unsigned byte indicating the stack offset
-                   of the continuation in words. For tuple returns
-                   this is the number of words returned on the
-                   stack. For primcalls this field is unused, since
-                   we don't jump to a continuation.
-
-    The upper 32 bits on 64 bit platforms are currently unused.
-
-    If a register is smaller than a word on the stack (for example a
-    single precision float on a 64 bit system), then the stack slot
-    is padded to a whole word.
-
-    Example:
-
-        If a tuple is returned in three registers and an additional two
-        words on the stack, then three bits in the register bitmap
-        (bits 0-23) would be set. And bit 24-31 would be
-        00000010 (two in binary).
-
-        The values on the stack before a call to POP_ARG_REGS would
-        be as follows:
-
-            ...
-            continuation
-            stack_arg_1
-            stack_arg_2
-            register_arg_3
-            register_arg_2
-            register_arg_1 <- Sp
-
-        A call to POP_ARG_REGS(call_info) would move register_arg_1
-        to the register corresponding to the lowest set bit in the
-        call_info word. register_arg_2 would be moved to the register
-        corresponding to the second lowest set bit, and so on.
-
-        After POP_ARG_REGS(call_info), the stack pointer Sp points
-        to the topmost stack argument, so the stack looks as follows:
-
-            ...
-            continuation
-            stack_arg_1
-            stack_arg_2 <- Sp
-
-        At this point all the arguments are in place and we are ready
-        to jump to the continuation, the location (offset from Sp) of
-        which is found by inspecting the value of bits 24-31. In this
-        case the offset is two words.
-
-    On x86_64, the double precision (Dn) and single precision
-    floating (Fn) point registers overlap, e.g. D1 uses the same
-    physical register as F1. On this platform, the list returned
-    by allArgRegsCover contains only entries for the double
-    precision registers. If an argument is passed in register
-    Fn, the bit corresponding to Dn should be set.
-
-  Note: if anything changes in how registers for native calls overlap,
-           make sure to also update GHC.StgToByteCode.layoutNativeCall
- -}
-
--- Like realArgRegsCover but always includes the node. This covers all real
--- and virtual registers actually used for passing arguments.
-
-allArgRegsCover :: Platform -> [GlobalReg]
-allArgRegsCover platform =
-  nub (VanillaReg 1 : realArgRegsCover platform)
+-- | A set of global registers that cover the machine registers used
+-- for argument passing.
+--
+-- See Note [realArgRegsCover].
+realArgRegsCover :: Platform
+                 -> GlobalArgRegs
+                    -- ^ which kinds of registers do we want to cover?
+                 -> [GlobalReg]
+realArgRegsCover platform argRegs
+  =  realVanillaRegs platform
+  ++ realLongRegs    platform
+  ++ concat
+      (  [ realFloatRegs platform  | wantFP, not (passFloatArgsInXmm platform) ]
+           -- TODO: the line above is legacy logic, but removing it breaks
+           -- the bytecode interpreter on AArch64. Probably easy to fix.
+           -- AK: I believe this might be because we map REG_F1..4 and REG_D1..4 to different
+           -- machine registers on AArch64.
+      ++ [ realDoubleRegs platform | wantFP ]
+      )
+  ++ [ mkVecReg i | mkVecReg <- maybeToList mbMkVecReg
+                  , i <- realXmmRegNos platform ]
+
+  where
+    wantFP = case registerArch (platformArch platform) of
+      Unified   -> argRegs == SCALAR_ARG_REGS
+      Separate  -> argRegs >= SCALAR_ARG_REGS
+      NoVectors -> argRegs >= SCALAR_ARG_REGS
+    mbMkVecReg = case registerArch (platformArch platform) of
+      Unified   -> mb_xyzmm
+      Separate  -> mb_xyzmm
+      NoVectors -> Nothing
+    mb_xyzmm = case argRegs of
+      V16_ARG_REGS -> Just XmmReg
+      V32_ARG_REGS -> Just YmmReg
+      V64_ARG_REGS -> Just ZmmReg
+      _ -> Nothing
+
+-- | Like "realArgRegsCover", but always includes the node.
+--
+-- See Note [realArgRegsCover].
+allArgRegsCover :: Platform
+                -> GlobalArgRegs
+                    -- ^ which kinds of registers do we want to cover?
+                -> [GlobalReg]
+allArgRegsCover platform argRegs =
+  nub (node : realArgRegsCover platform argRegs)
+  where
+    node = VanillaReg 1
+
+{- Note [realArgRegsCover]
+~~~~~~~~~~~~~~~~~~~~~~~~~~
+In low-level Cmm, jumps must be annotated with a set of live registers,
+allowing precise control of global STG register contents across function calls.
+However, in some places (in particular in the RTS), the registers we want to
+preserve depend on the *caller*. For example, if we intercept a function call
+via a stack underflow frame, we want to preserve exactly those registers
+containing function arguments.
+Since we can't know exactly how many arguments the caller passed, we settle on
+simply preserving all global regs which might be used for argument passing.
+To do this, we specify a collection of registers that *covers* all the registers
+we want to preserve; this is done by "realArgRegsCover".
+
+The situation is made somewhat tricky by the need to handle vector registers.
+For example, on X86_64, the F, D, XMM, YMM, ZMM overlap in the following way
+          ┌─┬─┬───┬───────┬───────────────┐
+          │F┆D┆XMM┆  YMM  ┆     ZMM       │
+          └─┴─┴───┴───────┴───────────────┘
+where each register extends all the way to the left.
+
+Based on this register architecture, on X86_64 we might want to annotate a jump
+in which we (might) want to preserve the contents of all argument-passing
+registers with [R1, ..., R6, ZMM1, ..., ZMM6]. This, however, is not possible
+in general, because preserving e.g. a ZMM register across a C call requires the
+availability of the AVX-512F instruction set. If we did this, the RTS would
+crash at runtime with an "invalid instruction" error on X86_64 machines which
+do not support AVX-512F.
+
+Instead, we parametrise "realArgRegsCover" on the 'GlobalArgRegs' datatype, which
+specifies which registers it is sufficient to preserve. For example, it might
+suffice to only preserve general-purpose registers, or to only preserve up to
+XMM (not YMM or ZMM).
+
+Then, to handle certain functions in the RTS such as "stack_underflow_frame", we
+proceed by defining 4 variants, stack_underflow_frame_{d,v16,v32,v64}, which
+respectively annotate the jump at the end of the function with SCALAR_ARG_REGS,
+V16_ARG_REGS, V32_ARG_REGS and V64_ARG_REGS. Compiling these variants, in effect,
+amounts to compiling "stack_underflow_frame" four times, once for each level of
+vector support. Then, in the RTS, we dispatch at runtime based on the support
+for vectors provided by the architecture on the current machine (see e.g.
+'threadStackOverflow' and its 'switch (vectorSupportGlobalVar)'.)
+
+Note that, like in Note [AutoApply.cmm for vectors], it is **critical** that we
+compile e.g. stack_underflow_frame_v64 with -mavx512f. If we don't, the LLVM
+backend is liable to compile code using e.g. the ZMM1 STG register to uses of
+X86 machine registers xmm1, xmm2, xmm3, xmm4, instead of just zmm1. This would
+mean that LLVM produces ABI-incompatible code that would result in segfaults in
+the RTS.
+-}

compiler/GHC/Cmm/CommonBlockElim.hs

-{-# LANGUAGE GADTs, BangPatterns, ScopedTypeVariables #-}
+{-# LANGUAGE GADTs #-}
 
 module GHC.Cmm.CommonBlockElim
   ( elimCommonBlocks
@@ -17,7 +17,6 @@ import GHC.Cmm.ContFlowOpt
 import GHC.Cmm.Dataflow.Block
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Label
-import GHC.Cmm.Dataflow.Collections
 import Data.Functor.Classes (liftEq)
 import Data.Maybe (mapMaybe)
 import qualified Data.List as List

compiler/GHC/Cmm/ContFlowOpt.hs

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

compiler/GHC/Cmm/Dataflow.hs

-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses  #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 
 --
@@ -14,7 +10,7 @@
 --
 -- This module is a specialised and optimised version of
 -- Compiler.Hoopl.Dataflow in the hoopl package.  In particular it is
--- specialised to the UniqSM monad.
+-- specialised to the UniqDSM monad.
 --
 
 module GHC.Cmm.Dataflow
@@ -37,7 +33,7 @@ where
 import GHC.Prelude
 
 import GHC.Cmm
-import GHC.Types.Unique.Supply
+import GHC.Types.Unique.DSM
 
 import Data.Array
 import Data.Maybe
@@ -47,7 +43,6 @@ import Data.Kind (Type)
 
 import GHC.Cmm.Dataflow.Block
 import GHC.Cmm.Dataflow.Graph
-import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Label
 
 type family   Fact (x :: Extensibility) f :: Type
@@ -90,14 +85,14 @@ type TransferFun' (n :: Extensibility -> Extensibility -> Type) f =
 -- | Function for rewriting and analysis combined. To be used with
 -- @rewriteCmm@.
 --
--- Currently set to work with @UniqSM@ monad, but we could probably abstract
+-- Currently set to work with @UniqDSM@ monad, but we could probably abstract
 -- that away (if we do that, we might want to specialize the fixpoint algorithms
 -- to the particular monads through SPECIALIZE).
-type RewriteFun f = CmmBlock -> FactBase f -> UniqSM (CmmBlock, FactBase f)
+type RewriteFun f = CmmBlock -> FactBase f -> UniqDSM (CmmBlock, FactBase f)
 
 -- | `RewriteFun` abstracted over `n` (the node type)
 type RewriteFun' (n :: Extensibility -> Extensibility -> Type) f =
-    Block n C C -> FactBase f -> UniqSM (Block n C C, FactBase f)
+    Block n C C -> FactBase f -> UniqDSM (Block n C C, FactBase f)
 
 analyzeCmmBwd, analyzeCmmFwd
     :: (NonLocal node)
@@ -172,7 +167,7 @@ rewriteCmmBwd
     -> RewriteFun' node f
     -> GenCmmGraph node
     -> FactBase f
-    -> UniqSM (GenCmmGraph node, FactBase f)
+    -> UniqDSM (GenCmmGraph node, FactBase f)
 rewriteCmmBwd = rewriteCmm Bwd
 
 rewriteCmm
@@ -182,7 +177,7 @@ rewriteCmm
     -> RewriteFun' node f
     -> GenCmmGraph node
     -> FactBase f
-    -> UniqSM (GenCmmGraph node, FactBase f)
+    -> UniqDSM (GenCmmGraph node, FactBase f)
 rewriteCmm dir lattice rwFun cmmGraph initFact = {-# SCC rewriteCmm #-} do
     let entry = g_entry cmmGraph
         hooplGraph = g_graph cmmGraph
@@ -202,7 +197,7 @@ fixpointRewrite
     -> Label
     -> LabelMap (Block node C C)
     -> FactBase f
-    -> UniqSM (LabelMap (Block node C C), FactBase f)
+    -> UniqDSM (LabelMap (Block node C C), FactBase f)
 fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
   where
     -- Sorting the blocks helps to minimize the number of times we need to
@@ -221,7 +216,7 @@ fixpointRewrite dir lattice do_block entry blockmap = loop start blockmap
         :: IntHeap                    -- Worklist, i.e., blocks to process
         -> LabelMap (Block node C C)  -- Rewritten blocks.
         -> FactBase f                 -- Current facts.
-        -> UniqSM (LabelMap (Block node C C), FactBase f)
+        -> UniqDSM (LabelMap (Block node C C), FactBase f)
     loop todo !blocks1 !fbase1
       | Just (index, todo1) <- IntSet.minView todo = do
         -- Note that we use the *original* block here. This is important.
@@ -427,10 +422,10 @@ foldNodesBwdOO funOO = go
 -- Strict in both accumulated parts.
 foldRewriteNodesBwdOO
     :: forall f node.
-       (node O O -> f -> UniqSM (Block node O O, f))
+       (node O O -> f -> UniqDSM (Block node O O, f))
     -> Block node O O
     -> f
-    -> UniqSM (Block node O O, f)
+    -> UniqDSM (Block node O O, f)
 foldRewriteNodesBwdOO rewriteOO initBlock initFacts = go initBlock initFacts
   where
     go (BCons node1 block1) !fact1 = (rewriteOO node1 `comp` go block1) fact1

compiler/GHC/Cmm/Dataflow/Collections.hs

-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module GHC.Cmm.Dataflow.Collections
-    ( IsSet(..)
-    , setInsertList, setDeleteList, setUnions
-    , IsMap(..)
-    , mapInsertList, mapDeleteList, mapUnions
-    , UniqueMap, UniqueSet
-    ) where
-
-import GHC.Prelude
-
-import qualified GHC.Data.Word64Map.Strict as M
-import qualified GHC.Data.Word64Set as S
-
-import Data.List (foldl1')
-import Data.Word (Word64)
-
-class IsSet set where
-  type ElemOf set
-
-  setNull :: set -> Bool
-  setSize :: set -> Int
-  setMember :: ElemOf set -> set -> Bool
-
-  setEmpty :: set
-  setSingleton :: ElemOf set -> set
-  setInsert :: ElemOf set -> set -> set
-  setDelete :: ElemOf set -> set -> set
-
-  setUnion :: set -> set -> set
-  setDifference :: set -> set -> set
-  setIntersection :: set -> set -> set
-  setIsSubsetOf :: set -> set -> Bool
-  setFilter :: (ElemOf set -> Bool) -> set -> set
-
-  setFoldl :: (b -> ElemOf set -> b) -> b -> set -> b
-  setFoldr :: (ElemOf set -> b -> b) -> b -> set -> b
-
-  setElems :: set -> [ElemOf set]
-  setFromList :: [ElemOf set] -> set
-
--- Helper functions for IsSet class
-setInsertList :: IsSet set => [ElemOf set] -> set -> set
-setInsertList keys set = foldl' (flip setInsert) set keys
-
-setDeleteList :: IsSet set => [ElemOf set] -> set -> set
-setDeleteList keys set = foldl' (flip setDelete) set keys
-
-setUnions :: IsSet set => [set] -> set
-setUnions [] = setEmpty
-setUnions sets = foldl1' setUnion sets
-
-
-class IsMap map where
-  type KeyOf map
-
-  mapNull :: map a -> Bool
-  mapSize :: map a -> Int
-  mapMember :: KeyOf map -> map a -> Bool
-  mapLookup :: KeyOf map -> map a -> Maybe a
-  mapFindWithDefault :: a -> KeyOf map -> map a -> a
-
-  mapEmpty :: map a
-  mapSingleton :: KeyOf map -> a -> map a
-  mapInsert :: KeyOf map -> a -> map a -> map a
-  mapInsertWith :: (a -> a -> a) -> KeyOf map -> a -> map a -> map a
-  mapDelete :: KeyOf map -> map a -> map a
-  mapAlter :: (Maybe a -> Maybe a) -> KeyOf map -> map a -> map a
-  mapAdjust :: (a -> a) -> KeyOf map -> map a -> map a
-
-  mapUnion :: map a -> map a -> map a
-  mapUnionWithKey :: (KeyOf map -> a -> a -> a) -> map a -> map a -> map a
-  mapDifference :: map a -> map a -> map a
-  mapIntersection :: map a -> map a -> map a
-  mapIsSubmapOf :: Eq a => map a -> map a -> Bool
-
-  mapMap :: (a -> b) -> map a -> map b
-  mapMapWithKey :: (KeyOf map -> a -> b) -> map a -> map b
-  mapFoldl :: (b -> a -> b) -> b -> map a -> b
-  mapFoldr :: (a -> b -> b) -> b -> map a -> b
-  mapFoldlWithKey :: (b -> KeyOf map -> a -> b) -> b -> map a -> b
-  mapFoldMapWithKey :: Monoid m => (KeyOf map -> a -> m) -> map a -> m
-  mapFilter :: (a -> Bool) -> map a -> map a
-  mapFilterWithKey :: (KeyOf map -> a -> Bool) -> map a -> map a
-
-
-  mapElems :: map a -> [a]
-  mapKeys :: map a -> [KeyOf map]
-  mapToList :: map a -> [(KeyOf map, a)]
-  mapFromList :: [(KeyOf map, a)] -> map a
-  mapFromListWith :: (a -> a -> a) -> [(KeyOf map,a)] -> map a
-
--- Helper functions for IsMap class
-mapInsertList :: IsMap map => [(KeyOf map, a)] -> map a -> map a
-mapInsertList assocs map = foldl' (flip (uncurry mapInsert)) map assocs
-
-mapDeleteList :: IsMap map => [KeyOf map] -> map a -> map a
-mapDeleteList keys map = foldl' (flip mapDelete) map keys
-
-mapUnions :: IsMap map => [map a] -> map a
-mapUnions [] = mapEmpty
-mapUnions maps = foldl1' mapUnion maps
-
------------------------------------------------------------------------------
--- Basic instances
------------------------------------------------------------------------------
-
-newtype UniqueSet = US S.Word64Set deriving (Eq, Ord, Show, Semigroup, Monoid)
-
-instance IsSet UniqueSet where
-  type ElemOf UniqueSet = Word64
-
-  setNull (US s) = S.null s
-  setSize (US s) = S.size s
-  setMember k (US s) = S.member k s
-
-  setEmpty = US S.empty
-  setSingleton k = US (S.singleton k)
-  setInsert k (US s) = US (S.insert k s)
-  setDelete k (US s) = US (S.delete k s)
-
-  setUnion (US x) (US y) = US (S.union x y)
-  setDifference (US x) (US y) = US (S.difference x y)
-  setIntersection (US x) (US y) = US (S.intersection x y)
-  setIsSubsetOf (US x) (US y) = S.isSubsetOf x y
-  setFilter f (US s) = US (S.filter f s)
-
-  setFoldl k z (US s) = S.foldl' k z s
-  setFoldr k z (US s) = S.foldr k z s
-
-  setElems (US s) = S.elems s
-  setFromList ks = US (S.fromList ks)
-
-newtype UniqueMap v = UM (M.Word64Map v)
-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
-
-instance IsMap UniqueMap where
-  type KeyOf UniqueMap = Word64
-
-  mapNull (UM m) = M.null m
-  mapSize (UM m) = M.size m
-  mapMember k (UM m) = M.member k m
-  mapLookup k (UM m) = M.lookup k m
-  mapFindWithDefault def k (UM m) = M.findWithDefault def k m
-
-  mapEmpty = UM M.empty
-  mapSingleton k v = UM (M.singleton k v)
-  mapInsert k v (UM m) = UM (M.insert k v m)
-  mapInsertWith f k v (UM m) = UM (M.insertWith f k v m)
-  mapDelete k (UM m) = UM (M.delete k m)
-  mapAlter f k (UM m) = UM (M.alter f k m)
-  mapAdjust f k (UM m) = UM (M.adjust f k m)
-
-  mapUnion (UM x) (UM y) = UM (M.union x y)
-  mapUnionWithKey f (UM x) (UM y) = UM (M.unionWithKey f x y)
-  mapDifference (UM x) (UM y) = UM (M.difference x y)
-  mapIntersection (UM x) (UM y) = UM (M.intersection x y)
-  mapIsSubmapOf (UM x) (UM y) = M.isSubmapOf x y
-
-  mapMap f (UM m) = UM (M.map f m)
-  mapMapWithKey f (UM m) = UM (M.mapWithKey f m)
-  mapFoldl k z (UM m) = M.foldl' k z m
-  mapFoldr k z (UM m) = M.foldr k z m
-  mapFoldlWithKey k z (UM m) = M.foldlWithKey' k z m
-  mapFoldMapWithKey f (UM m) = M.foldMapWithKey f m
-  {-# INLINEABLE mapFilter #-}
-  mapFilter f (UM m) = UM (M.filter f m)
-  {-# INLINEABLE mapFilterWithKey #-}
-  mapFilterWithKey f (UM m) = UM (M.filterWithKey f m)
-
-  mapElems (UM m) = M.elems m
-  mapKeys (UM m) = M.keys m
-  {-# INLINEABLE mapToList #-}
-  mapToList (UM m) = M.toList m
-  mapFromList assocs = UM (M.fromList assocs)
-  mapFromListWith f assocs = UM (M.fromListWith f assocs)

compiler/GHC/Cmm/Dataflow/Graph.hs

-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE DataKinds #-}
-{-# LANGUAGE FlexibleInstances #-}
 {-# LANGUAGE GADTs #-}
-{-# LANGUAGE RankNTypes #-}
-{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies #-}
 module GHC.Cmm.Dataflow.Graph
     ( Body
@@ -26,15 +22,14 @@ import GHC.Utils.Misc
 
 import GHC.Cmm.Dataflow.Label
 import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
 
 import Data.Kind
 
 -- | A (possibly empty) collection of closed/closed blocks
-type Body n = LabelMap (Block n C C)
+type Body s n = Body' s Block n
 
 -- | @Body@ abstracted over @block@
-type Body' block (n :: Extensibility -> Extensibility -> Type) = LabelMap (block n C C)
+type Body' s block (n :: Extensibility -> Extensibility -> Type) = s (block n C C)
 
 -------------------------------
 -- | Gives access to the anchor points for
@@ -51,13 +46,13 @@ instance NonLocal n => NonLocal (Block n) where
   successors (BlockCC _ _ n) = successors n
 
 
-emptyBody :: Body' block n
+emptyBody :: Body' LabelMap block n
 emptyBody = mapEmpty
 
-bodyList :: Body' block n -> [(Label,block n C C)]
+bodyList :: Body' LabelMap block n -> [(Label,block n C C)]
 bodyList body = mapToList body
 
-bodyToBlockList :: Body n -> [Block n C C]
+bodyToBlockList :: Body LabelMap n -> [Block n C C]
 bodyToBlockList body = mapElems body
 
 addBlock
@@ -77,18 +72,18 @@ addBlock block body = mapAlter add lbl body
 -- O/C, C/O, C/C).  A graph open at the entry has a single,
 -- distinguished, anonymous entry point; if a graph is closed at the
 -- entry, its entry point(s) are supplied by a context.
-type Graph = Graph' Block
+type Graph = Graph' LabelMap Block
 
 -- | @Graph'@ is abstracted over the block type, so that we can build
 -- graphs of annotated blocks for example (Compiler.Hoopl.Dataflow
 -- needs this).
-data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where
-  GNil  :: Graph' block n O O
-  GUnit :: block n O O -> Graph' block n O O
+data Graph' s block (n :: Extensibility -> Extensibility -> Type) e x where
+  GNil  :: Graph' s block n O O
+  GUnit :: block n O O -> Graph' s block n O O
   GMany :: MaybeO e (block n O C)
-        -> Body' block n
+        -> Body' s block n
         -> MaybeO x (block n C O)
-        -> Graph' block n e x
+        -> Graph' s block n e x
 
 
 -- -----------------------------------------------------------------------------
@@ -96,31 +91,32 @@ data Graph' block (n :: Extensibility -> Extensibility -> Type) e x where
 
 -- | Maps over all nodes in a graph.
 mapGraph :: (forall e x. n e x -> n' e x) -> Graph n e x -> Graph n' e x
-mapGraph f = mapGraphBlocks (mapBlock f)
+mapGraph f = mapGraphBlocks mapMap (mapBlock f)
 
 -- | Function 'mapGraphBlocks' enables a change of representation of blocks,
 -- nodes, or both.  It lifts a polymorphic block transform into a polymorphic
 -- graph transform.  When the block representation stabilizes, a similar
 -- function should be provided for blocks.
-mapGraphBlocks :: forall block n block' n' e x .
-                  (forall e x . block n e x -> block' n' e x)
-               -> (Graph' block n e x -> Graph' block' n' e x)
+mapGraphBlocks :: forall s block n block' n' e x .
+                  (forall a b . (a -> b) -> s a -> s b)
+               -> (forall e x . block n e x -> block' n' e x)
+               -> (Graph' s block n e x -> Graph' s block' n' e x)
 
-mapGraphBlocks f = map
-  where map :: Graph' block n e x -> Graph' block' n' e x
+mapGraphBlocks f g = map
+  where map :: Graph' s block n e x -> Graph' s block' n' e x
         map GNil = GNil
-        map (GUnit b) = GUnit (f b)
-        map (GMany e b x) = GMany (fmap f e) (mapMap f b) (fmap f x)
+        map (GUnit b) = GUnit (g b)
+        map (GMany e b x) = GMany (fmap g e) (f g b) (fmap g x)
 
 -- -----------------------------------------------------------------------------
 -- Extracting Labels from graphs
 
-labelsDefined :: forall block n e x . NonLocal (block n) => Graph' block n e x
+labelsDefined :: forall block n e x . NonLocal (block n) => Graph' LabelMap block n e x
               -> LabelSet
 labelsDefined GNil      = setEmpty
 labelsDefined (GUnit{}) = setEmpty
 labelsDefined (GMany _ body x) = mapFoldlWithKey addEntry (exitLabel x) body
-  where addEntry :: forall a. LabelSet -> ElemOf LabelSet -> a -> LabelSet
+  where addEntry :: forall a. LabelSet -> Label -> a -> LabelSet
         addEntry labels label _ = setInsert label labels
         exitLabel :: MaybeO x (block n C O) -> LabelSet
         exitLabel NothingO  = setEmpty

compiler/GHC/Cmm/Dataflow/Label.hs

-{-# LANGUAGE DeriveTraversable #-}
-{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DeriveTraversable  #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE FlexibleInstances  #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
+{-# OPTIONS_GHC -Wno-unused-top-binds #-}
 
 module GHC.Cmm.Dataflow.Label
     ( Label
@@ -11,17 +13,76 @@ module GHC.Cmm.Dataflow.Label
     , FactBase
     , lookupFact
     , mkHooplLabel
+    -- * Set
+    , setEmpty
+    , setNull
+    , setSize
+    , setMember
+    , setSingleton
+    , setInsert
+    , setDelete
+    , setUnion
+    , setUnions
+    , setDifference
+    , setIntersection
+    , setIsSubsetOf
+    , setFilter
+    , setFoldl
+    , setFoldr
+    , setFromList
+    , setElems
+    -- * Map
+    , mapNull
+    , mapSize
+    , mapMember
+    , mapLookup
+    , mapFindWithDefault
+    , mapEmpty
+    , mapSingleton
+    , mapInsert
+    , mapInsertWith
+    , mapDelete
+    , mapAlter
+    , mapAdjust
+    , mapUnion
+    , mapUnions
+    , mapUnionWithKey
+    , mapDifference
+    , mapIntersection
+    , mapIsSubmapOf
+    , mapMap
+    , mapMapWithKey
+    , mapFoldl
+    , mapFoldr
+    , mapFoldlWithKey
+    , mapFoldMapWithKey
+    , mapFilter
+    , mapFilterWithKey
+    , mapElems
+    , mapKeys
+    , mapToList
+    , mapFromList
+    , mapFromListWith
+    , mapMapMaybe
     ) where
 
 import GHC.Prelude
 
+import GHC.Utils.Misc
 import GHC.Utils.Outputable
 
--- TODO: This should really just use GHC's Unique and Uniq{Set,FM}
-import GHC.Cmm.Dataflow.Collections
-
 import GHC.Types.Unique (Uniquable(..), mkUniqueGrimily)
+
+-- The code generator will eventually be using all the labels stored in a
+-- LabelSet and LabelMap. For these reasons we use the strict variants of these
+-- data structures. We inline selectively to enable the RULES in Word64Map/Set
+-- to fire.
+import GHC.Data.Word64Set (Word64Set)
+import qualified GHC.Data.Word64Set as S
+import GHC.Data.Word64Map.Strict (Word64Map)
+import qualified GHC.Data.Word64Map.Strict as M
 import GHC.Data.TrieMap
+
 import Data.Word (Word64)
 
 
@@ -30,7 +91,7 @@ import Data.Word (Word64)
 -----------------------------------------------------------------------------
 
 newtype Label = Label { lblToUnique :: Word64 }
-  deriving (Eq, Ord)
+  deriving newtype (Eq, Ord)
 
 mkHooplLabel :: Word64 -> Label
 mkHooplLabel = Label
@@ -50,78 +111,178 @@ instance OutputableP env Label where
 -----------------------------------------------------------------------------
 -- LabelSet
 
-newtype LabelSet = LS UniqueSet deriving (Eq, Ord, Show, Monoid, Semigroup)
+newtype LabelSet = LS Word64Set
+  deriving newtype (Eq, Ord, Show, Monoid, Semigroup)
+
+setNull :: LabelSet -> Bool
+setNull (LS s) = S.null s
+
+setSize :: LabelSet -> Int
+setSize (LS s) = S.size s
+
+setMember :: Label -> LabelSet -> Bool
+setMember (Label k) (LS s) = S.member k s
+
+setEmpty :: LabelSet
+setEmpty = LS S.empty
+
+setSingleton :: Label -> LabelSet
+setSingleton (Label k) = LS (S.singleton k)
+
+setInsert :: Label -> LabelSet -> LabelSet
+setInsert (Label k) (LS s) = LS (S.insert k s)
+
+setDelete :: Label -> LabelSet -> LabelSet
+setDelete (Label k) (LS s) = LS (S.delete k s)
+
+setUnion :: LabelSet -> LabelSet -> LabelSet
+setUnion (LS x) (LS y) = LS (S.union x y)
+
+{-# INLINE setUnions #-}
+setUnions :: [LabelSet] -> LabelSet
+setUnions = foldl1WithDefault' setEmpty setUnion
 
-instance IsSet LabelSet where
-  type ElemOf LabelSet = Label
+setDifference :: LabelSet -> LabelSet -> LabelSet
+setDifference (LS x) (LS y) = LS (S.difference x y)
 
-  setNull (LS s) = setNull s
-  setSize (LS s) = setSize s
-  setMember (Label k) (LS s) = setMember k s
+setIntersection :: LabelSet -> LabelSet -> LabelSet
+setIntersection (LS x) (LS y) = LS (S.intersection x y)
 
-  setEmpty = LS setEmpty
-  setSingleton (Label k) = LS (setSingleton k)
-  setInsert (Label k) (LS s) = LS (setInsert k s)
-  setDelete (Label k) (LS s) = LS (setDelete k s)
+setIsSubsetOf :: LabelSet -> LabelSet -> Bool
+setIsSubsetOf (LS x) (LS y) = S.isSubsetOf x y
 
-  setUnion (LS x) (LS y) = LS (setUnion x y)
-  setDifference (LS x) (LS y) = LS (setDifference x y)
-  setIntersection (LS x) (LS y) = LS (setIntersection x y)
-  setIsSubsetOf (LS x) (LS y) = setIsSubsetOf x y
-  setFilter f (LS s) = LS (setFilter (f . mkHooplLabel) s)
-  setFoldl k z (LS s) = setFoldl (\a v -> k a (mkHooplLabel v)) z s
-  setFoldr k z (LS s) = setFoldr (\v a -> k (mkHooplLabel v) a) z s
+setFilter :: (Label -> Bool) -> LabelSet -> LabelSet
+setFilter f (LS s) = LS (S.filter (f . mkHooplLabel) s)
 
-  setElems (LS s) = map mkHooplLabel (setElems s)
-  setFromList ks = LS (setFromList (map lblToUnique ks))
+{-# INLINE setFoldl #-}
+setFoldl :: (t -> Label -> t) -> t -> LabelSet -> t
+setFoldl k z (LS s) = S.foldl (\a v -> k a (mkHooplLabel v)) z s
+
+{-# INLINE setFoldr #-}
+setFoldr :: (Label -> t -> t) -> t -> LabelSet -> t
+setFoldr k z (LS s) = S.foldr (\v a -> k (mkHooplLabel v) a) z s
+
+{-# INLINE setElems #-}
+setElems :: LabelSet -> [Label]
+setElems (LS s) = map mkHooplLabel (S.elems s)
+
+{-# INLINE setFromList #-}
+setFromList :: [Label] -> LabelSet
+setFromList ks  = LS (S.fromList (map lblToUnique ks))
 
 -----------------------------------------------------------------------------
 -- LabelMap
 
-newtype LabelMap v = LM (UniqueMap v)
-  deriving (Eq, Ord, Show, Functor, Foldable, Traversable)
-
-instance IsMap LabelMap where
-  type KeyOf LabelMap = Label
-
-  mapNull (LM m) = mapNull m
-  mapSize (LM m) = mapSize m
-  mapMember (Label k) (LM m) = mapMember k m
-  mapLookup (Label k) (LM m) = mapLookup k m
-  mapFindWithDefault def (Label k) (LM m) = mapFindWithDefault def k m
-
-  mapEmpty = LM mapEmpty
-  mapSingleton (Label k) v = LM (mapSingleton k v)
-  mapInsert (Label k) v (LM m) = LM (mapInsert k v m)
-  mapInsertWith f (Label k) v (LM m) = LM (mapInsertWith f k v m)
-  mapDelete (Label k) (LM m) = LM (mapDelete k m)
-  mapAlter f (Label k) (LM m) = LM (mapAlter f k m)
-  mapAdjust f (Label k) (LM m) = LM (mapAdjust f k m)
-
-  mapUnion (LM x) (LM y) = LM (mapUnion x y)
-  mapUnionWithKey f (LM x) (LM y) = LM (mapUnionWithKey (f . mkHooplLabel) x y)
-  mapDifference (LM x) (LM y) = LM (mapDifference x y)
-  mapIntersection (LM x) (LM y) = LM (mapIntersection x y)
-  mapIsSubmapOf (LM x) (LM y) = mapIsSubmapOf x y
-
-  mapMap f (LM m) = LM (mapMap f m)
-  mapMapWithKey f (LM m) = LM (mapMapWithKey (f . mkHooplLabel) m)
-  mapFoldl k z (LM m) = mapFoldl k z m
-  mapFoldr k z (LM m) = mapFoldr k z m
-  mapFoldlWithKey k z (LM m) =
-      mapFoldlWithKey (\a v -> k a (mkHooplLabel v)) z m
-  mapFoldMapWithKey f (LM m) = mapFoldMapWithKey (\k v -> f (mkHooplLabel k) v) m
-  {-# INLINEABLE mapFilter #-}
-  mapFilter f (LM m) = LM (mapFilter f m)
-  {-# INLINEABLE mapFilterWithKey #-}
-  mapFilterWithKey f (LM m) = LM (mapFilterWithKey (f . mkHooplLabel) m)
-
-  mapElems (LM m) = mapElems m
-  mapKeys (LM m) = map mkHooplLabel (mapKeys m)
-  {-# INLINEABLE mapToList #-}
-  mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- mapToList m]
-  mapFromList assocs = LM (mapFromList [(lblToUnique k, v) | (k, v) <- assocs])
-  mapFromListWith f assocs = LM (mapFromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
+newtype LabelMap v = LM (Word64Map v)
+  deriving newtype (Eq, Ord, Show, Functor, Foldable)
+  deriving stock   Traversable
+
+mapNull :: LabelMap a -> Bool
+mapNull (LM m) = M.null m
+
+{-# INLINE mapSize #-}
+mapSize :: LabelMap a -> Int
+mapSize (LM m) = M.size m
+
+mapMember :: Label -> LabelMap a -> Bool
+mapMember (Label k) (LM m) = M.member k m
+
+mapLookup :: Label -> LabelMap a -> Maybe a
+mapLookup (Label k) (LM m) = M.lookup k m
+
+mapFindWithDefault :: a -> Label -> LabelMap a -> a
+mapFindWithDefault def (Label k) (LM m) = M.findWithDefault def k m
+
+mapEmpty :: LabelMap v
+mapEmpty = LM M.empty
+
+mapSingleton :: Label -> v -> LabelMap v
+mapSingleton (Label k) v = LM (M.singleton k v)
+
+mapInsert :: Label -> v -> LabelMap v -> LabelMap v
+mapInsert (Label k) v (LM m) = LM (M.insert k v m)
+
+mapInsertWith :: (v -> v -> v) -> Label -> v -> LabelMap v -> LabelMap v
+mapInsertWith f (Label k) v (LM m) = LM (M.insertWith f k v m)
+
+mapDelete :: Label -> LabelMap v -> LabelMap v
+mapDelete (Label k) (LM m) = LM (M.delete k m)
+
+mapAlter :: (Maybe v -> Maybe v) -> Label -> LabelMap v -> LabelMap v
+mapAlter f (Label k) (LM m) = LM (M.alter f k m)
+
+mapAdjust :: (v -> v) -> Label -> LabelMap v -> LabelMap v
+mapAdjust f (Label k) (LM m) = LM (M.adjust f k m)
+
+mapUnion :: LabelMap v -> LabelMap v -> LabelMap v
+mapUnion (LM x) (LM y) = LM (M.union x y)
+
+{-# INLINE mapUnions #-}
+mapUnions :: [LabelMap a] -> LabelMap a
+mapUnions = foldl1WithDefault' mapEmpty mapUnion
+
+mapUnionWithKey :: (Label -> v -> v -> v) -> LabelMap v -> LabelMap v -> LabelMap v
+mapUnionWithKey f (LM x) (LM y) = LM (M.unionWithKey (f . mkHooplLabel) x y)
+
+mapDifference :: LabelMap v -> LabelMap b -> LabelMap v
+mapDifference (LM x) (LM y) = LM (M.difference x y)
+
+mapIntersection :: LabelMap v -> LabelMap b -> LabelMap v
+mapIntersection (LM x) (LM y) = LM (M.intersection x y)
+
+mapIsSubmapOf :: Eq a => LabelMap a -> LabelMap a -> Bool
+mapIsSubmapOf (LM x) (LM y) = M.isSubmapOf x y
+
+mapMap :: (a -> v) -> LabelMap a -> LabelMap v
+mapMap f (LM m) = LM (M.map f m)
+
+mapMapWithKey :: (Label -> a -> v) -> LabelMap a -> LabelMap v
+mapMapWithKey f (LM m) = LM (M.mapWithKey (f . mkHooplLabel) m)
+
+{-# INLINE mapFoldl #-}
+mapFoldl :: (a -> b -> a) -> a -> LabelMap b -> a
+mapFoldl k z (LM m) = M.foldl k z m
+
+{-# INLINE mapFoldr #-}
+mapFoldr :: (a -> b -> b) -> b -> LabelMap a -> b
+mapFoldr k z (LM m) = M.foldr k z m
+
+{-# INLINE mapFoldlWithKey #-}
+mapFoldlWithKey :: (t -> Label -> b -> t) -> t -> LabelMap b -> t
+mapFoldlWithKey k z (LM m) = M.foldlWithKey (\a v -> k a (mkHooplLabel v)) z m
+
+mapFoldMapWithKey :: Monoid m => (Label -> t -> m) -> LabelMap t -> m
+mapFoldMapWithKey f (LM m) = M.foldMapWithKey (\k v -> f (mkHooplLabel k) v) m
+
+{-# INLINEABLE mapFilter #-}
+mapFilter :: (v -> Bool) -> LabelMap v -> LabelMap v
+mapFilter f (LM m) = LM (M.filter f m)
+
+{-# INLINEABLE mapFilterWithKey #-}
+mapFilterWithKey :: (Label -> v -> Bool) -> LabelMap v -> LabelMap v
+mapFilterWithKey f (LM m)  = LM (M.filterWithKey (f . mkHooplLabel) m)
+
+{-# INLINE mapElems #-}
+mapElems :: LabelMap a -> [a]
+mapElems (LM m) = M.elems m
+
+{-# INLINE mapKeys #-}
+mapKeys :: LabelMap a -> [Label]
+mapKeys (LM m) = map (mkHooplLabel . fst) (M.toList m)
+
+{-# INLINE mapToList #-}
+mapToList :: LabelMap b -> [(Label, b)]
+mapToList (LM m) = [(mkHooplLabel k, v) | (k, v) <- M.toList m]
+
+{-# INLINE mapFromList #-}
+mapFromList :: [(Label, v)] -> LabelMap v
+mapFromList assocs = LM (M.fromList [(lblToUnique k, v) | (k, v) <- assocs])
+
+mapFromListWith :: (v -> v -> v) -> [(Label, v)] -> LabelMap v
+mapFromListWith f assocs = LM (M.fromListWith f [(lblToUnique k, v) | (k, v) <- assocs])
+
+mapMapMaybe :: (a -> Maybe b) -> LabelMap a -> LabelMap b
+mapMapMaybe f (LM m) = LM (M.mapMaybe f m)
 
 -----------------------------------------------------------------------------
 -- Instances
@@ -137,11 +298,12 @@ instance OutputableP env a => OutputableP env (LabelMap a) where
 
 instance TrieMap LabelMap where
   type Key LabelMap = Label
-  emptyTM = mapEmpty
-  lookupTM k m = mapLookup k m
+  emptyTM       = mapEmpty
+  lookupTM k m  = mapLookup k m
   alterTM k f m = mapAlter f k m
-  foldTM k m z = mapFoldr k z m
-  filterTM f m = mapFilter f m
+  foldTM k m z  = mapFoldr k z m
+  filterTM f    = mapFilter f
+  mapMaybeTM f  = mapMapMaybe f
 
 -----------------------------------------------------------------------------
 -- FactBase

compiler/GHC/Cmm/DebugBlock.hs

@@ -6,9 +6,7 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE LambdaCase #-}
-
-
-{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE EmptyCase #-}
 
 -----------------------------------------------------------------------------
 --
@@ -41,23 +39,27 @@ import GHC.Cmm.CLabel
 import GHC.Cmm
 import GHC.Cmm.Reg ( pprGlobalReg, pprGlobalRegUse )
 import GHC.Cmm.Utils
-import GHC.Data.FastString ( nilFS, mkFastString )
+import GHC.Data.FastString ( LexicalFastString, nilFS, mkFastString )
 import GHC.Unit.Module
 import GHC.Utils.Outputable
 import GHC.Utils.Panic
 import GHC.Types.SrcLoc
 import GHC.Types.Tickish
-import GHC.Utils.Misc      ( partitionWith, seqList )
+import GHC.Utils.Misc      ( seqList )
 
 import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Label
 
 import Data.Maybe
-import Data.List     ( minimumBy, nubBy )
+import Data.List     ( nubBy )
+import Data.List.NonEmpty ( NonEmpty (..), nonEmpty )
+import qualified Data.List.NonEmpty as NE
 import Data.Ord      ( comparing )
 import qualified Data.Map as Map
+import Data.Foldable ( toList )
+import Data.Either ( partitionEithers )
+import Data.Void
 
 -- | Debug information about a block of code. Ticks scope over nested
 -- blocks.
@@ -95,23 +97,32 @@ instance OutputableP Platform DebugBlock where
 
 -- | Intermediate data structure holding debug-relevant context information
 -- about a block.
-type BlockContext = (CmmBlock, RawCmmDecl)
+type BlockContext = (CmmBlock, RawCmmDeclNoStatics)
+
+-- Same as `RawCmmDecl`, but statically (in GHC) excludes the possibility of statics (in the CMM
+-- code). (The first argument is `Void` rather than `RawCmmStatics`.
+type RawCmmDeclNoStatics
+   = GenCmmDecl
+        Void
+        (LabelMap RawCmmStatics)
+        CmmGraph
 
 -- | Extract debug data from a group of procedures. We will prefer
 -- source notes that come from the given module (presumably the module
 -- that we are currently compiling).
-cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
+cmmDebugGen :: ModLocation -> [RawCmmDecl] -> [DebugBlock]
 cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
   where
-      blockCtxs :: Map.Map CmmTickScope [BlockContext]
+      blockCtxs :: Map.Map CmmTickScope (NonEmpty BlockContext)
       blockCtxs = blockContexts decls
 
       -- Analyse tick scope structure: Each one is either a top-level
       -- tick scope, or the child of another.
       (topScopes, childScopes)
-        = partitionWith (\a -> findP a a) $ Map.keys blockCtxs
+        = partitionEithers $ map (\(k, a) -> findP (k, a) k) $ Map.toList blockCtxs
+
       findP tsc GlobalScope = Left tsc -- top scope
-      findP tsc scp | scp' `Map.member` blockCtxs = Right (scp', tsc)
+      findP tsc scp | Just x <- Map.lookup scp' blockCtxs = Right (scp', tsc, x)
                     | otherwise                   = findP tsc scp'
         where -- Note that we only following the left parent of
               -- combined scopes. This loses us ticks, which we will
@@ -119,7 +130,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
               scp' | SubScope _ scp' <- scp      = scp'
                    | CombinedScope scp' _ <- scp = scp'
 
-      scopeMap = foldl' (\acc (key, scope) -> insertMulti key scope acc) Map.empty childScopes
+      scopeMap = foldl' (\ acc (k, (k', a'), _) -> insertMulti k (k', a') acc) Map.empty childScopes
 
       -- This allows us to recover ticks that we lost by flattening
       -- the graph. Basically, if the parent is A but the child is
@@ -138,7 +149,7 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
                    | SubScope _ s' <- s       = ticks ++ go s'
                    | CombinedScope s1 s2 <- s = ticks ++ go s1 ++ go s2
                    | otherwise                = panic "ticksToCopy impossible"
-                where ticks = bCtxsTicks $ fromMaybe [] $ Map.lookup s blockCtxs
+                where ticks = bCtxsTicks $ maybe [] toList $ Map.lookup s blockCtxs
       ticksToCopy _ = []
       bCtxsTicks = concatMap (blockTicks . fst)
 
@@ -148,41 +159,37 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
       -- (if we generated one, we probably want debug information to
       -- refer to it).
       bestSrcTick = minimumBy (comparing rangeRating)
-      rangeRating (SourceNote span _)
+      rangeRating (span, _)
         | srcSpanFile span == thisFile = 1
         | otherwise                    = 2 :: Int
-      rangeRating note                 = pprPanic "rangeRating" (ppr note)
       thisFile = maybe nilFS mkFastString $ ml_hs_file modLoc
 
       -- Returns block tree for this scope as well as all nested
       -- scopes. Note that if there are multiple blocks in the (exact)
       -- same scope we elect one as the "branch" node and add the rest
       -- as children.
-      blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock
-      blocksForScope cstick scope = mkBlock True (head bctxs)
-        where bctxs = fromJust $ Map.lookup scope blockCtxs
-              nested = fromMaybe [] $ Map.lookup scope scopeMap
-              childs = map (mkBlock False) (tail bctxs) ++
+      blocksForScope :: Maybe (RealSrcSpan, LexicalFastString) -> (CmmTickScope, NonEmpty BlockContext) -> DebugBlock
+      blocksForScope cstick (scope, bctx:|bctxs) = mkBlock True bctx
+        where nested = fromMaybe [] $ Map.lookup scope scopeMap
+              childs = map (mkBlock False) bctxs ++
                        map (blocksForScope stick) nested
 
               mkBlock :: Bool -> BlockContext -> DebugBlock
               mkBlock top (block, prc)
                 = DebugBlock { dblProcedure    = g_entry graph
                              , dblLabel        = label
-                             , dblCLabel       = case info of
-                                 Just (CmmStaticsRaw infoLbl _) -> infoLbl
-                                 Nothing
-                                   | g_entry graph == label -> entryLbl
-                                   | otherwise              -> blockLbl label
+                             , dblCLabel       = blockLbl label
                              , dblHasInfoTbl   = isJust info
                              , dblParent       = Nothing
                              , dblTicks        = ticks
                              , dblPosition     = Nothing -- see cmmDebugLink
-                             , dblSourceTick   = stick
+                             , dblSourceTick   = uncurry SourceNote <$> stick
                              , dblBlocks       = blocks
                              , dblUnwind       = []
                              }
-                where (CmmProc infos entryLbl _ graph) = prc
+                where (infos, graph) = case prc of
+                          CmmProc infos _ _ graph -> (infos, graph)
+                          CmmData _ v -> case v of
                       label = entryLabel block
                       info = mapLookup label infos
                       blocks | top       = seqList childs childs
@@ -190,26 +197,26 @@ cmmDebugGen modLoc decls = map (blocksForScope Nothing) topScopes
 
               -- A source tick scopes over all nested blocks. However
               -- their source ticks might take priority.
-              isSourceTick SourceNote {} = True
-              isSourceTick _             = False
+              isSourceTick (SourceNote span a) = Just (span, a)
+              isSourceTick _ = Nothing
               -- Collect ticks from all blocks inside the tick scope.
               -- We attempt to filter out duplicates while we're at it.
               ticks = nubBy (flip tickishContains) $
                       bCtxsTicks bctxs ++ ticksToCopy scope
-              stick = case filter isSourceTick ticks of
-                []     -> cstick
-                sticks -> Just $! bestSrcTick (sticks ++ maybeToList cstick)
+              stick = case nonEmpty $ mapMaybe isSourceTick ticks of
+                Nothing -> cstick
+                Just sticks -> Just $! bestSrcTick (sticks `NE.appendList` maybeToList cstick)
 
 -- | Build a map of blocks sorted by their tick scopes
 --
 -- This involves a pre-order traversal, as we want blocks in rough
 -- control flow order (so ticks have a chance to be sorted in the
 -- right order).
-blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
-blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
-  where walkProc :: RawCmmDecl
-                 -> Map.Map CmmTickScope [BlockContext]
-                 -> Map.Map CmmTickScope [BlockContext]
+blockContexts :: [GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph] -> Map.Map CmmTickScope (NonEmpty BlockContext)
+blockContexts = Map.map NE.reverse . foldr walkProc Map.empty
+  where walkProc :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph
+                 -> Map.Map CmmTickScope (NonEmpty BlockContext)
+                 -> Map.Map CmmTickScope (NonEmpty BlockContext)
         walkProc CmmData{}                 m = m
         walkProc prc@(CmmProc _ _ _ graph) m
           | mapNull blocks = m
@@ -218,29 +225,30 @@ blockContexts decls = Map.map reverse $ foldr walkProc Map.empty decls
                 entry  = [mapFind (g_entry graph) blocks]
                 emptyLbls = setEmpty :: LabelSet
 
-        walkBlock :: RawCmmDecl -> [Block CmmNode C C]
-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
-                  -> (LabelSet, Map.Map CmmTickScope [BlockContext])
+        walkBlock :: GenCmmDecl a (LabelMap RawCmmStatics) CmmGraph -> [Block CmmNode C C]
+                  -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext))
+                  -> (LabelSet, Map.Map CmmTickScope (NonEmpty BlockContext))
         walkBlock _   []             c            = c
-        walkBlock prc (block:blocks) (visited, m)
-          | lbl `setMember` visited
-          = walkBlock prc blocks (visited, m)
-          | otherwise
-          = walkBlock prc blocks $
-            walkBlock prc succs
-              (lbl `setInsert` visited,
-               insertMulti scope (block, prc) m)
+        walkBlock prc (block:blocks) (visited, m) = case (prc, setMember lbl visited) of
+            (CmmProc x y z graph, False) ->
+                let succs = flip mapFind (toBlockMap graph) <$>
+                        successors (lastNode block) in
+                walkBlock prc blocks $
+                walkBlock prc succs
+                  ( lbl `setInsert` visited
+                  , insertMultiNE scope (block, CmmProc x y z graph) m )
+            _ -> walkBlock prc blocks (visited, m)
           where CmmEntry lbl scope = firstNode block
-                (CmmProc _ _ _ graph) = prc
-                succs = map (flip mapFind (toBlockMap graph))
-                            (successors (lastNode block))
         mapFind = mapFindWithDefault (error "contextTree: block not found!")
 
 insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
 insertMulti k v = Map.insertWith (const (v:)) k [v]
 
-cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
-cmmDebugLabels isMeta nats = seqList lbls lbls
+insertMultiNE :: Ord k => k -> a -> Map.Map k (NonEmpty a) -> Map.Map k (NonEmpty a)
+insertMultiNE k v = Map.insertWith (const (v NE.<|)) k (NE.singleton v)
+
+cmmDebugLabels :: (BlockId -> Bool) -> (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
+cmmDebugLabels is_valid_label isMeta nats = seqList lbls lbls
   where -- Find order in which procedures will be generated by the
         -- back-end (that actually matters for DWARF generation).
         --
@@ -248,7 +256,7 @@ cmmDebugLabels isMeta nats = seqList lbls lbls
         -- consist of meta instructions -- we will declare them missing,
         -- which will skip debug data generation without messing up the
         -- block hierarchy.
-        lbls = map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
+        lbls = filter is_valid_label $ map blockId $ filter (not . allMeta) $ concatMap getBlocks nats
         getBlocks (CmmProc _ _ _ (ListGraph bs)) = bs
         getBlocks _other                         = []
         allMeta (BasicBlock _ instrs) = all isMeta instrs
@@ -257,14 +265,18 @@ cmmDebugLabels isMeta nats = seqList lbls lbls
 -- native generated code.
 cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
              -> [DebugBlock] -> [DebugBlock]
-cmmDebugLink labels unwindPts blocks = map link blocks
+cmmDebugLink labels unwindPts blocks = mapMaybe link blocks
   where blockPos :: LabelMap Int
         blockPos = mapFromList $ flip zip [0..] labels
-        link block = block { dblPosition = mapLookup (dblLabel block) blockPos
-                           , dblBlocks   = map link (dblBlocks block)
-                           , dblUnwind   = fromMaybe mempty
-                                         $ mapLookup (dblLabel block) unwindPts
-                           }
+        link block = case mapLookup (dblLabel block) blockPos of
+          -- filter dead blocks: we generated debug infos from Cmm blocks but
+          -- asm-shortcutting may remove some blocks later (#22792)
+          Nothing  -> Nothing
+          pos      -> Just $ block
+                         { dblPosition = pos
+                         , dblBlocks   = mapMaybe link (dblBlocks block)
+                         , dblUnwind   = fromMaybe mempty $ mapLookup (dblLabel block) unwindPts
+                         }
 
 -- | Converts debug blocks into a label map for easier lookups
 debugToMap :: [DebugBlock] -> LabelMap DebugBlock

compiler/GHC/Cmm/Dominators.hs

@@ -23,7 +23,6 @@ where
 import GHC.Prelude
 
 import Data.Array.IArray
-import Data.Foldable()
 import qualified Data.Tree as Tree
 
 import Data.Word
@@ -32,7 +31,6 @@ import qualified GHC.CmmToAsm.CFG.Dominators as LT
 
 import GHC.Cmm.Dataflow
 import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Collections
 import GHC.Cmm.Dataflow.Graph
 import GHC.Cmm.Dataflow.Label
 import GHC.Cmm

compiler/GHC/Cmm/Expr.hs

-{-# LANGUAGE BangPatterns #-}
 {-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE UndecidableInstances #-}
 
 module GHC.Cmm.Expr
@@ -510,6 +506,8 @@ pprExpr9 platform e =
         CmmMachOp mop args  -> genMachOp platform mop args
 
 genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
+genMachOp platform (MO_RelaxedRead w) [x] =
+    ppr (cmmBits w) <> text "!" <> brackets (pdoc platform x)
 genMachOp platform mop args
    | Just doc <- infixMachOp mop = case args of
         -- dyadic

compiler/GHC/Cmm/GenericOpt.hs

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