.gitlab-ci.yml

@@ -1014,10 +1014,6 @@ abi-test:
       optional: true
   dependencies: null
   image: "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-fedora33:$DOCKER_REV"
-  rules:
-    - if: $CI_MERGE_REQUEST_ID
-    - if: '$CI_COMMIT_BRANCH == "master"'
-    - if: '$CI_COMMIT_BRANCH =~ /ghc-[0.9]+\.[0-9]+/'
   tags:
     - x86_64-linux
   script:
@@ -1038,6 +1034,7 @@ abi-test:
       - out
   rules:
     - *full-ci
+    - if: '$CI_MERGE_REQUEST_LABELS =~ /.*test-abi.*/'
 
 
 ############################################################

.gitlab/ci.sh

@@ -675,12 +675,25 @@ function test_hadrian() {
 }
 
 function summarise_hi_files() {
-  for iface in $(find . -type f -name "*.hi" | sort); do echo "$iface  $($HC --show-iface $iface | grep "  ABI hash:")"; done | tee $OUT/abis
-  for iface in $(find . -type f -name "*.hi" | sort); do echo "$iface  $($HC --show-iface $iface | grep "  interface hash:")"; done | tee $OUT/interfaces
-  for iface in $(find . -type f -name "*.hi" | sort); do
-      fname="$OUT/$(dirname $iface)"
-      mkdir -p $fname
-      $HC --show-iface $iface > "$OUT/$iface"
+  hi_files=$(find . -type f -name "*.hi" | sort)
+  for iface in $hi_files; do echo "$iface  $($HC --show-iface "$iface" | grep "  ABI hash:")"; done | tee $OUT/abis
+  for iface in $hi_files; do echo "$iface  $($HC --show-iface "$iface" | grep "  interface hash:")"; done | tee $OUT/interfaces
+  for iface in $hi_files; do
+      fname="$OUT/$(dirname "$iface")"
+      mkdir -p "$fname"
+      $HC --show-iface "$iface" > "$OUT/$iface"
+  done
+}
+
+function summarise_o_files() {
+  OBJDUMP=$(if test "$(uname)" == "Darwin"; then echo "objdump -m"; else echo "objdump"; fi)
+  o_files=$(find . -type f -name "*.o" | sort)
+  for o in $o_files; do
+      fname="$OUT/objs/$(dirname "$o")"
+      mkdir -p "$fname"
+      # To later compare object dumps except for the first line which prints the file path
+      $OBJDUMP --all-headers "$o" | tail -n+2 > "$OUT/objs/$o.all-headers"
+      $OBJDUMP --disassemble-all "$o" | tail -n+2 > "$OUT/objs/$o.disassemble-all"
   done
 }
 
@@ -700,6 +713,7 @@ function cabal_abi_test() {
     -iCabal/Cabal/src -XNoPolyKinds Distribution.Simple -j"$cores" \
     "$@" 2>&1 | tee $OUT/log
   summarise_hi_files
+  summarise_o_files
   popd
   end_section "Cabal test: $OUT"
 }
@@ -744,8 +758,34 @@ function check_interfaces(){
      for line in $(echo "$difference" | tr ' ' '\n' | grep ".hi" | sort | uniq); do
        diff "$1/$line" "$2/$line"
      done
-     fail "$3"
+     fail "$4"
+  fi
+}
+
+function check_objects(){
+
+  # Big fast check
+  if diff -r "$1" "$2"
+  then
+    echo "Objects are the same"
+  else
+    echo "--------------------------------------------------------------------------------"
+    echo "Comparing all objects (1. headers, 2. disassembly). Stopping at first failure..."
+    echo "--------------------------------------------------------------------------------"
+
+    pushd "$1" >/dev/null
+    OBJ_DUMPS=$(find . -type f -name "*.all-headers" -or -name "*.disassemble-all")
+    popd >/dev/null
+
+    for dump in $OBJ_DUMPS
+    do
+      if diff "$1/$dump" "$2/$dump"
+      then
+        fail "Mismatched object: $dump"
+      fi
+    done
   fi
+
 }
 
 function abi_test() {
@@ -761,6 +801,7 @@ function run_abi_test() {
   OUT="$PWD/out/run2" DIR=$(mktemp -d XXXX-short) cabal_abi_test -O0
   check_interfaces out/run1 out/run2 abis "Mismatched ABI hash"
   check_interfaces out/run1 out/run2 interfaces "Mismatched interface hashes"
+  check_objects out/run1 out/run2
 }
 
 function save_test_output() {

.gitlab/merge_request_templates/Haddock.md

+Thank your for your contribution to Haddock!
+
+  * [ ] This MR relates to \<ticket number>
+  * [ ] I have read the [CONTRIBUTING](./utils/haddock/CONTRIBUTING.md) guide
+  * [ ] I have inserted a CHANGELOG entry if this warrants it
+  * [ ] I have squashed my commits
+  * [ ] I have added tests if necessary
+
+  * [ ] I have updated the documentation
+
+If you have any questions don't hesitate to open your merge request and inquire
+in a comment. If your patch isn't quite done yet please do add prefix your MR
+title with `Draft:`.
+
+Once your change is ready please remove the `Draft:` tag and wait for review. If
+no one has offered a review in a few days then please leave a comment mentioning
+@triagers and apply the ~"Blocked on Review" label.

CODEOWNERS

@@ -66,6 +66,7 @@
 /utils/iserv/                     @angerman @simonmar
 /utils/fs/                        @Phyx
 /utils/jsffi                      @TerrorJack
+/utils/haddock                     @Kleidukos
 
 [WinIO related code]
 /libraries/base/GHC/Event/Windows/                   @Phyx

compiler/GHC/Cmm/UniqueRenamer.hs

+{-# LANGUAGE LambdaCase #-}
+module GHC.Cmm.UniqueRenamer
+  ( detRenameUniques
+
+  -- Careful! Not for general use!
+  , DetUniqFM, emptyDetUFM)
+  where
+
+import Prelude
+import Control.Monad.Trans.State
+import GHC.Word
+import GHC.Cmm
+import GHC.Cmm.CLabel
+import GHC.Cmm.Dataflow.Block
+import GHC.Cmm.Dataflow.Graph
+import GHC.Cmm.Dataflow.Label
+import GHC.Types.Unique
+import GHC.Types.Unique.FM
+import Data.Tuple (swap)
+
+{-
+--------------------------------------------------------------------------------
+-- * Deterministic Objects
+--------------------------------------------------------------------------------
+
+** Write many notes in a collective note.
+
+Topics:
+* Before generating Code, we rename all uniques of local symbols deterministically
+* The code generation (like Assembly fix ups) need
+
+-}
+
+-- | A mapping from non-deterministic uniques to deterministic uniques, to
+-- rename local symbols with the end goal of producing deterministic object files.
+-- See Note [....TODO]
+data DetUniqFM = DetUniqFM
+  { mapping :: UniqFM Unique Unique
+  , supply :: !Word64
+  }
+
+type DetRnM = State DetUniqFM
+
+emptyDetUFM :: DetUniqFM
+emptyDetUFM = DetUniqFM { mapping = emptyUFM, supply = 1 }
+
+newDetUniq :: DetRnM Unique
+newDetUniq = do
+  w <- gets supply
+  modify' (\d -> d{supply = supply d + 1})
+  return $ mkUniqueGrimily w
+
+-- Rename local symbols deterministically (in order of appearance)
+detRenameUniques :: DetUniqFM -> RawCmmGroup -> (DetUniqFM, RawCmmGroup)
+detRenameUniques dufm group = swap $ runState (mapM uniqRename group) dufm
+
+-- The most important function here, which does the actual renaming.
+-- Arguably, maybe we should rename this to CLabelRenamer
+detRenameCLabel :: CLabel -> DetRnM CLabel
+detRenameCLabel = \case
+  _ -> _
+
+
+--------------------------------------------------------------------------------
+-- Traversals
+--------------------------------------------------------------------------------
+-- I think I should be able to implement this using some generic traversal,
+-- which would be cleaner
+
+class UniqRenamable a where
+  uniqRename :: a -> DetRnM a
+
+instance UniqRenamable CLabel where
+  -- The most important renaming. The rest are just traversals.
+  uniqRename = detRenameCLabel
+
+instance UniqRenamable (GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph) where
+  uniqRename (CmmProc h lbl regs g)
+    = CmmProc <$> uniqRename h <*> uniqRename lbl <*> mapM uniqRename regs <*> uniqRename g
+  uniqRename (CmmData sec d)
+    = CmmData <$> uniqRename sec <*> uniqRename d
+
+instance UniqRenamable Section where
+  uniqRename (Section ty lbl) = Section ty <$> uniqRename lbl
+
+instance UniqRenamable RawCmmStatics where
+  uniqRename (CmmStaticsRaw lbl sts)
+    = CmmStaticsRaw <$> uniqRename lbl <*> mapM uniqRename sts
+
+instance UniqRenamable CmmStatic where
+  uniqRename = \case
+    CmmStaticLit l -> CmmStaticLit <$> uniqRename l
+    CmmUninitialised x -> pure $ CmmUninitialised x
+    CmmString x -> pure $ CmmString x
+    CmmFileEmbed f i -> pure $ CmmFileEmbed f i
+
+instance UniqRenamable CmmLit where
+  uniqRename = \case
+    CmmInt i w -> pure $ CmmInt i w
+    CmmFloat r w -> pure $ CmmFloat r w
+    CmmVec lits -> CmmVec <$> mapM uniqRename lits
+    CmmLabel lbl -> CmmLabel <$> uniqRename lbl
+    CmmLabelOff lbl i -> CmmLabelOff <$> uniqRename lbl <*> pure i
+    CmmLabelDiffOff lbl1 lbl2 i w ->
+      CmmLabelDiffOff <$> uniqRename lbl1 <*> uniqRename lbl2 <*> pure i <*> pure w
+    CmmBlock bid -> pure $ CmmBlock bid
+    CmmHighStackMark -> pure CmmHighStackMark
+
+instance UniqRenamable a {- for 'Body' and on 'RawCmmStatics' -}
+  => UniqRenamable (LabelMap a) where
+  uniqRename = traverse uniqRename
+
+instance UniqRenamable CmmGraph where
+  uniqRename (CmmGraph e g) = CmmGraph e <$> uniqRename g
+
+instance UniqRenamable (Graph CmmNode n m) where
+  uniqRename = \case
+    GNil  -> pure GNil
+    GUnit block -> GUnit <$> uniqRename block
+    GMany m1 b m2 -> GMany <$> uniqRename m1 <*> uniqRename b <*> uniqRename m2
+
+instance UniqRenamable t => UniqRenamable (MaybeO n t) where
+  uniqRename (JustO x) = JustO <$> uniqRename x
+  uniqRename NothingO = pure NothingO
+
+instance UniqRenamable (Block CmmNode n m) where
+  uniqRename = \case
+    BlockCO n bn -> BlockCO <$> uniqRename n <*> uniqRename bn
+    BlockCC n1 bn n2 -> BlockCC <$> uniqRename n1 <*> uniqRename bn <*> uniqRename n2
+    BlockOC bn n -> BlockOC <$> uniqRename bn <*> uniqRename n
+                                                             
+    BNil    -> pure BNil
+    BMiddle n -> BMiddle <$> uniqRename n
+    BCat    b1 b2 -> BCat <$> uniqRename b1 <*> uniqRename b2
+    BSnoc   bn n -> BSnoc <$> uniqRename bn <*> uniqRename n
+    BCons   n bn -> BCons <$> uniqRename n <*> uniqRename bn
+
+instance UniqRenamable (CmmNode n m) where
+  uniqRename = \case
+    CmmEntry l t -> CmmEntry l <$> uniqRename t
+    CmmComment fs -> pure $ CmmComment fs
+    CmmTick tickish -> CmmTick <$> uniqRename tickish
+    CmmUnwind xs -> CmmUnwind <$> mapM uniqRename xs
+    CmmAssign reg e -> CmmAssign <$> uniqRename reg <*> uniqRename e
+    CmmStore e1 e2 align -> CmmStore <$> uniqRename e1 <*> uniqRename e2 <*> pure align
+    CmmUnsafeForeignCall ftgt cmmformal cmmactual ->
+      CmmUnsafeForeignCall <$> uniqRename ftgt <*> mapM uniqRename cmmformal <*> mapM uniqRename cmmactual
+    CmmBranch l -> pure $ CmmBranch l
+    CmmCondBranch pred t f likely ->
+      CmmCondBranch <$> uniqRename pred <*> pure t <*> pure f <*> pure likely
+    CmmSwitch e sts -> CmmSwitch <$> uniqRename e <*> pure sts
+    CmmCall tgt cont regs args retargs retoff ->
+      CmmCall <$> uniqRename tgt <*> pure cont <*> mapM uniqRename regs
+              <*> pure args <*> pure retargs <*> pure retoff
+    CmmForeignCall tgt res args succ retargs retoff intrbl ->
+      CmmForeignCall <$> uniqRename tgt <*> mapM uniqRename res <*> mapM uniqRename args
+                     <*> pure succ <*> pure retargs <*> pure retoff <*> pure intrbl
+
+instance UniqRenamable GlobalReg where
+  uniqRename = _
+
+instance UniqRenamable CmmExpr where
+  uniqRename = _
+
+instance UniqRenamable ForeignTarget where
+  uniqRename = _
+
+instance UniqRenamable CmmFormal where
+  uniqRename = _
+
+instance UniqRenamable CmmReg where
+  -- ROMES:TODO: Also hard! There's a unique there but what shall we do?
+  uniqRename = _
+
+instance UniqRenamable CmmTickScope where
+  -- ROMES:TODO: What about this one for ticks? Ask Andreas
+  uniqRename = _
+
+instance UniqRenamable CmmTickish where
+  -- ROMES:TODO: Yet harder! What about this one?
+  uniqRename = _
+
+instance (UniqRenamable a, UniqRenamable b) => UniqRenamable (a, b) where
+  uniqRename (a, b) = (,) <$> uniqRename a <*> uniqRename b
+
+instance (UniqRenamable a) => UniqRenamable (Maybe a) where
+  uniqRename Nothing = pure Nothing
+  uniqRename (Just x) = Just <$> uniqRename x

compiler/GHC/CmmToAsm.hs

@@ -494,6 +494,8 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
                 FormatCMM
                 (vcat $ map (pprLiveCmmDecl platform) withLiveness)
 
+        -- ROMES:TODO: RENAME VIRTUAL REGISTERS DETERMINISTICALLY
+
         -- allocate registers
         (alloced, usAlloc, ppr_raStatsColor, ppr_raStatsLinear, raStats, stack_updt_blks) <-
          if ( ncgRegsGraph config || ncgRegsIterative config )
@@ -555,6 +557,7 @@ cmmNativeGen logger ncgImpl us fileIds dbgMap cmm count
                         , [], stack_updt_blks)
 
           else do
+
                 -- do linear register allocation
                 let reg_alloc proc = do
                        (alloced, maybe_more_stack, ra_stats) <-

compiler/GHC/CmmToAsm/PPC/CodeGen.hs

@@ -1912,8 +1912,15 @@ genCCall' config gcp target dest_regs args
                          -- "Single precision floating point values
                          -- are mapped to the second word in a single
                          -- doubleword"
-                         GCP64ELF 1      -> stackOffset' + 4
-                         _               -> stackOffset'
+                         GCP64ELF 1 -> stackOffset' + 4
+                         -- ELF v2 ABI Revision 1.5 Section 2.2.3.3. requires
+                         -- a single-precision floating-point value
+                         -- to be mapped to the least-significant
+                         -- word in a single doubleword.
+                         GCP64ELF 2 -> case platformByteOrder platform of
+                                       BigEndian    -> stackOffset' + 4
+                                       LittleEndian -> stackOffset'
+                         _          -> stackOffset'
                      | otherwise = stackOffset'
 
                 stackSlot = AddrRegImm sp (ImmInt stackOffset'')

compiler/GHC/Core/Opt/Arity.hs

@@ -2369,8 +2369,8 @@ mkEtaForAllMCo (Bndr tcv vis) ty mco
                                 (mkNomReflCo (varType tcv)) co)
     -- coreTyLamForAllTyFlag: See Note [The EtaInfo mechanism], particularly
     -- the (EtaInfo Invariant).  (sym co) wraps a lambda that always has
-    -- a ForAllTyFlag of coreTyLamForAllTyFlag; see wrinkle (FC4) in
-    -- Note [ForAllCo] in GHC.Core.TyCo.Rep
+    -- a ForAllTyFlag of coreTyLamForAllTyFlag; see Note [Required foralls in Core]
+    -- in GHC.Core.TyCo.Rep
 
 {-
 ************************************************************************

compiler/GHC/Core/TyCo/Rep.hs

@@ -1195,6 +1195,24 @@ among branches, but that doesn't quite concern us here.)
 The Int in the AxiomInstCo constructor is the 0-indexed number
 of the chosen branch.
 
+Note [Required foralls in Core]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider the CoreExpr (Lam a e) where `a` is a TyVar, and (e::e_ty).
+It has type
+   forall a. e_ty
+Note the Specified visibility of (forall a. e_ty); the Core type just isn't able
+to express more than one visiblity, and we pick `Specified`.  See `exprType` and
+`mkLamType` in GHC.Core.Utils, and `GHC.Type.Var.coreLamForAllTyFlag`.
+
+So how can we ever get a term of type (forall a -> e_ty)?  Answer: /only/ via a
+cast built with ForAllCo.  See `GHC.Tc.Types.Evidence.mkWpForAllCast`.  This does
+not seem very satisfying, but it does the job.
+
+An alternative would be to put a visibility flag into `Lam` (a huge change),
+or into a `TyVar` (a more plausible change), but we leave that for the future.
+
+See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.
+
 Note [ForAllCo]
 ~~~~~~~~~~~~~~~
 See also Note [ForAllTy and type equality] in GHC.Core.TyCo.Compare.
@@ -1251,10 +1269,7 @@ Several things to note here
   in the typing rule.  See also Note [ForAllTy and type equality] in
   GHC.Core.TyCo.Compare.
 
-(FC4) A lambda term (Lam a e) has type (forall a. ty), with visibility
-  flag `GHC.Type.Var.coreTyLamForAllTyFlag`, not (forall a -> ty).
-  See `GHC.Type.Var.coreTyLamForAllTyFlag` and `GHC.Core.Utils.mkLamType`.
-  The only way to get a term of type (forall a -> ty) is to cast a lambda.
+(FC4) See Note [Required foralls in Core].
 
 (FC5) In a /type/, in (ForAllTy cv ty) where cv is a CoVar, we insist that
   `cv` must appear free in `ty`; see Note [Unused coercion variable in ForAllTy]

compiler/GHC/Core/Utils.hs

@@ -170,7 +170,7 @@ mkLamTypes :: [Var] -> Type -> Type
 mkLamType v body_ty
    | isTyVar v
    = mkForAllTy (Bndr v coreTyLamForAllTyFlag) body_ty
-     -- coreTyLamForAllTyFlag: see (FC4) in Note [ForAllCo]
+     -- coreTyLamForAllTyFlag: see Note [Required foralls in Core]
      --                        in GHC.Core.TyCo.Rep
 
    | isCoVar v

compiler/GHC/Driver/CodeOutput.hs

@@ -38,6 +38,7 @@ import GHC.Driver.Backend
 import qualified GHC.Data.ShortText as ST
 import GHC.Data.Stream           ( Stream )
 import qualified GHC.Data.Stream as Stream
+import GHC.Cmm.UniqueRenamer
 
 import GHC.Utils.TmpFs
 
@@ -94,11 +95,21 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g
   cmm_stream
   =
     do  {
+        -- To produce deterministic object code, we alpha-rename all Uniques to deterministic uniques before Cmm linting.
+        -- From here on out, the backend code generation can't use (non-deterministic) Uniques, or risk producing non-deterministic code.
+        -- For example, the fix-up action in the ASM NCG should use determinist names for potential new blocks it has to create.
+        -- Therefore, in the ASM NCG `NatM` Monad we use a deterministic `UniqSuply` (which won't be shared about multiple threads)
+        -- TODO: Put these all into notes carefully organized
+        ; let renamed_cmm_stream =
+                -- if gopt Opt_DeterministicObjects dflags
+
+                snd  <$> Stream.mapAccumL_ (fmap pure . detRenameUniques) emptyDetUFM cmm_stream
+
         -- Lint each CmmGroup as it goes past
         ; let linted_cmm_stream =
                  if gopt Opt_DoCmmLinting dflags
-                    then Stream.mapM do_lint cmm_stream
-                    else cmm_stream
+                    then Stream.mapM do_lint renamed_cmm_stream
+                    else renamed_cmm_stream
 
               do_lint cmm = withTimingSilent logger
                   (text "CmmLint"<+>brackets (ppr this_mod))
@@ -397,3 +408,4 @@ ipInitCode do_info_table platform this_mod
 
    ipe_buffer_decl =
        text "extern IpeBufferListNode" <+> ipe_buffer_label <> text ";"
+

compiler/GHC/Tc/Types/Evidence.hs

@@ -7,7 +7,7 @@ module GHC.Tc.Types.Evidence (
 
   -- * HsWrapper
   HsWrapper(..),
-  (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpVisTyLam,
+  (<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams, mkWpForAllCast,
   mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta,
   collectHsWrapBinders,
   idHsWrapper, isIdHsWrapper,
@@ -258,20 +258,20 @@ mkWpEvVarApps vs = mk_co_app_fn WpEvApp (map (EvExpr . evId) vs)
 mkWpTyLams :: [TyVar] -> HsWrapper
 mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
 
--- Construct a type lambda and cast its type
--- from `forall tv. res` to `forall tv -> res`.
+-- mkWpForAllCast [tv{vis}] constructs a cast
+--   forall tv. res  ~R#   forall tv{vis} res`.
+-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep
 --
--- (\ @tv -> e )
---    `cast` (forall (tv[spec]~[req] :: <*>_N). <res>_R       -- ForAllCo is the evidence that...
---              :: (forall tv. res) ~R# (forall tv -> res))   -- invisible and visible foralls are representationally equal
---
-mkWpVisTyLam :: TyVar -> Type -> HsWrapper
-mkWpVisTyLam tv res =
-  WpCast (mkForAllCo tv coreTyLamForAllTyFlag Required kind_co body_co)
-  <.> WpTyLam tv
+-- It's a no-op if all binders are invisible;
+-- but in that case we refrain from calling it.
+mkWpForAllCast :: [ForAllTyBinder] -> Type -> HsWrapper
+mkWpForAllCast bndrs res_ty
+  = mkWpCastR (go bndrs)
   where
-    kind_co = mkNomReflCo (varType tv)
-    body_co = mkRepReflCo res
+    go []                 = mkRepReflCo res_ty
+    go (Bndr tv vis : bs) = mkForAllCo tv coreTyLamForAllTyFlag vis kind_co (go bs)
+      where
+        kind_co = mkNomReflCo (varType tv)
 
 mkWpEvLams :: [Var] -> HsWrapper
 mkWpEvLams ids = mk_co_lam_fn WpEvLam ids

compiler/GHC/Tc/Utils/Instantiate.hs

@@ -11,7 +11,7 @@
 -}
 
 module GHC.Tc.Utils.Instantiate (
-     topSkolemise,
+     topSkolemise, skolemiseRequired,
      topInstantiate,
      instantiateSigma,
      instCall, instDFunType, instStupidTheta, instTyVarsWith,
@@ -75,7 +75,7 @@ import GHC.Tc.Errors.Types
 import GHC.Tc.Zonk.Monad ( ZonkM )
 
 import GHC.Types.Id.Make( mkDictFunId )
-import GHC.Types.Basic ( TypeOrKind(..), Arity )
+import GHC.Types.Basic ( TypeOrKind(..), Arity, VisArity )
 import GHC.Types.Error
 import GHC.Types.SourceText
 import GHC.Types.SrcLoc as SrcLoc
@@ -145,22 +145,16 @@ newMethodFromName origin name ty_args
 Note [Skolemisation]
 ~~~~~~~~~~~~~~~~~~~~
 topSkolemise decomposes and skolemises a type, returning a type
-with no top level foralls or (=>)
+with no top level foralls or (=>).
 
 Examples:
 
   topSkolemise (forall a. Ord a => a -> a)
     =  ( wp, [a], [d:Ord a], a->a )
-    where wp = /\a. \(d:Ord a). <hole> a d
+    where
+      wp = /\a. \(d:Ord a). <hole> a d
 
-  topSkolemise  (forall a. Ord a => forall b. Eq b => a->b->b)
-    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b )
-    where wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). <hole> a d1 b d2
-
-This second example is the reason for the recursive 'go' function in
-topSkolemise: we remove successive layers of foralls and (=>).  This
-is really just an optimisation; see wrinkle (SK1) in GHC.Tc.Utils.Unify
-Note [Skolemisation overview].
+For nested foralls, see Note [Skolemisation en-bloc]
 
 In general,
   if      topSkolemise ty = (wrap, tvs, evs, rho)
@@ -168,6 +162,41 @@ In general,
   then    wrap e :: ty
     and   'wrap' binds {tvs, evs}
 
+Note [Skolemisation en-bloc]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Consider this case:
+
+  topSkolemise  (forall a. Ord a => forall b. Eq b => a->b->b)
+
+We /could/ return just
+  (wp, [a], [d:Ord a, forall b. Eq b => a -> b -> b)
+
+But in fact we skolemise "en-bloc", looping around (in `topSkolemise` for
+example) to skolemise the (forall b. Eq b =>).  So in fact
+
+  topSkolemise  (forall a. Ord a => forall b. Eq b => a->b->b)
+    =  ( wp, [a,b], [d1:Ord a,d2:Eq b], a->b->b )
+    where
+      wp = /\a.\(d1:Ord a)./\b.\(d2:Ord b). <hole> a d1 b d2
+
+This applies regardless of DeepSubsumption.
+
+Why do we do this "en-bloc" loopy thing?  It is /nearly/ just an optimisation.
+But not quite!  At the call site of `topSkolemise` (and its cousins) we
+use `checkConstraints` to gather constraints and build an implication
+constraint.   So skolemising just one level at a time would lead to nested
+implication constraints. That is a bit less efficient, but there is /also/ a small
+user-visible effect: see Note [Let-bound skolems] in GHC.Tc.Solver.InertSet.
+Specifically, consider
+
+   forall a. Eq a => forall b. (a ~ [b]) => blah
+
+If we skolemise en-bloc, the equality (a~[b]) is like a let-binding and we
+don't treat it like a GADT pattern match, limiting unification. With nested
+implications, the inner one would be treated as having-given-equalities.
+
+This is also relevant when Required foralls are involved; see #24810, and
+the loop in `skolemiseRequired`.
 -}
 
 topSkolemise :: SkolemInfo
@@ -182,7 +211,7 @@ topSkolemise skolem_info ty
   where
     init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))
 
-    -- Why recursive?  See Note [Skolemisation]
+    -- Why recursive?  See Note [Skolemisation en-bloc]
     go subst wrap tv_prs ev_vars ty
       | (bndrs, theta, inner_ty) <- tcSplitSigmaTyBndrs ty
       , let tvs = binderVars bndrs
@@ -202,6 +231,51 @@ topSkolemise skolem_info ty
       = return (wrap, tv_prs, ev_vars, substTy subst ty)
         -- substTy is a quick no-op on an empty substitution
 
+skolemiseRequired :: SkolemInfo -> VisArity -> TcSigmaType
+                  -> TcM (VisArity, HsWrapper, [Name], [ForAllTyBinder], [EvVar], TcRhoType)
+-- Skolemise up to N required (visible) binders,
+--    plus any invisible ones "in the way",
+--    /and/ any trailing invisible ones.
+-- So the result has no top-level invisible quantifiers.
+-- Return the depleted arity.
+skolemiseRequired skolem_info n_req sigma
+  = go n_req init_subst idHsWrapper [] [] [] sigma
+  where
+    init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType sigma))
+
+    -- Why recursive?  See Note [Skolemisation en-bloc]
+    go n_req subst wrap acc_nms acc_bndrs ev_vars ty
+      | (n_req', bndrs, inner_ty) <- tcSplitForAllTyVarsReqTVBindersN n_req ty
+      , not (null bndrs)
+      = do { (subst', bndrs1) <- tcInstSkolTyVarBndrsX skolem_info subst bndrs
+           ; let tvs1 = binderVars bndrs1
+                 -- fix_up_vis: see Note [Required foralls in Core]
+                 --             in GHC.Core.TyCo.Rep
+                 fix_up_vis | n_req == n_req'
+                            = idHsWrapper
+                            | otherwise
+                            = mkWpForAllCast bndrs1 (substTy subst' inner_ty)
+           ; go n_req' subst'
+                (wrap <.> fix_up_vis <.> mkWpTyLams tvs1)
+                (acc_nms   ++ map (tyVarName . binderVar) bndrs)
+                (acc_bndrs ++ bndrs1)
+                ev_vars
+                inner_ty }
+
+      | (theta, inner_ty) <- tcSplitPhiTy ty
+      , not (null theta)
+      = do { ev_vars1 <- newEvVars (substTheta subst theta)
+           ; go n_req subst
+                (wrap <.> mkWpEvLams ev_vars1)
+                acc_nms
+                acc_bndrs
+                (ev_vars ++ ev_vars1)
+                inner_ty }
+
+      | otherwise
+      = return (n_req, wrap, acc_nms, acc_bndrs, ev_vars, substTy subst ty)
+        -- substTy is a quick no-op on an empty substitution
+
 topInstantiate :: CtOrigin -> TcSigmaType -> TcM (HsWrapper, TcRhoType)
 -- Instantiate outer invisible binders (both Inferred and Specified)
 -- If    top_instantiate ty = (wrap, inner_ty)

compiler/GHC/Tc/Utils/TcType.hs

@@ -67,7 +67,7 @@ module GHC.Tc.Utils.TcType (
   --------------------------------
   -- Splitters
   getTyVar, getTyVar_maybe, getCastedTyVar_maybe,
-  tcSplitForAllTyVarBinder_maybe,
+  tcSplitForAllTyVarBinder_maybe, tcSplitForAllTyVarsReqTVBindersN,
   tcSplitForAllTyVars, tcSplitForAllInvisTyVars, tcSplitSomeForAllTyVars,
   tcSplitForAllReqTVBinders, tcSplitForAllInvisTVBinders,
   tcSplitPiTys, tcSplitPiTy_maybe, tcSplitForAllTyVarBinders,
@@ -1410,6 +1410,18 @@ tcSplitSomeForAllTyVars argf_pred ty
     split orig_ty ty tvs | Just ty' <- coreView ty = split orig_ty ty' tvs
     split orig_ty _                            tvs = (reverse tvs, orig_ty)
 
+tcSplitForAllTyVarsReqTVBindersN :: Arity -> Type -> (Arity, [ForAllTyBinder], Type)
+-- Split off at most N /required/ (aka visible) binders, plus any invisible ones
+-- in the way, /and/ any trailing invisible ones
+tcSplitForAllTyVarsReqTVBindersN n_req ty
+  = split n_req ty ty []
+  where
+    split n_req _orig_ty (ForAllTy b@(Bndr _ argf) ty) bs
+      | isVisibleForAllTyFlag argf, n_req > 0           = split (n_req - 1) ty ty (b:bs)
+      | otherwise                                       = split n_req       ty ty (b:bs)
+    split n_req orig_ty ty bs | Just ty' <- coreView ty = split n_req orig_ty ty' bs
+    split n_req orig_ty _ty bs                          = (n_req, reverse bs, orig_ty)
+
 -- | Like 'tcSplitForAllTyVars', but only splits 'ForAllTy's with 'Required' type
 -- variable binders. All split tyvars are annotated with '()'.
 tcSplitForAllReqTVBinders :: Type -> ([TcReqTVBinder], Type)

compiler/GHC/Tc/Utils/Unify.hs

@@ -350,8 +350,8 @@ Some wrinkles
       The implication constraint will look like
           forall a b. (Eq a, Ord b) => <constraints>
       See the loop in GHC.Tc.Utils.Instantiate.topSkolemise.
-      This is just an optimisation; it would be fine to generate one implication
-      constraint for each nesting layer.
+      and Note [Skolemisation en-bloc] in that module
+
 
 Some examples:
 
@@ -777,29 +777,40 @@ matchExpectedFunTys herald _ arity (Infer inf_res) thing_inside
        ; return (mkWpCastN co, result) }
 
 matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
-  = check 0 [] top_ty
+  = check arity [] top_ty
   where
     check :: VisArity -> [ExpPatType] -> TcSigmaType -> TcM (HsWrapper, a)
     -- `check` is called only in the Check{} case
     -- It collects rev_pat_tys in reversed order
-    -- n_so_far is the number of /visible/ arguments seen so far:
-    --     i.e. length (filterOut isExpForAllPatTyInvis rev_pat_tys)
-
-    -- Do shallow skolemisation if there are top-level invisible quantifiers
-    check n_so_far rev_pat_tys ty
-      | isSigmaTy ty  -- Type has invisible quantifiers
-      = do { (wrap_gen, (wrap_res, result))
-                 <- tcSkolemiseGeneral Shallow ctx top_ty ty $ \tv_bndrs ty' ->
-                    let rev_pat_tys' = reverse (map (mkInvisExpPatType . snd) tv_bndrs)
-                                       ++ rev_pat_tys
-                    in check n_so_far rev_pat_tys' ty'
-           ; return (wrap_gen <.> wrap_res, result) }
-
-    -- (n_so_far == arity): no more args
-    -- rho_ty has no top-level quantifiers
-    -- If there is deep subsumption, do deep skolemisation
-    check n_so_far rev_pat_tys rho_ty
-      | n_so_far == arity
+    -- n_req is the number of /visible/ arguments still needed
+
+    ----------------------------
+    -- Skolemise quantifiers, both visible (up to n_req) and invisible
+    -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App
+    check n_req rev_pat_tys ty
+      | isSigmaTy ty                     -- An invisible quantifier at the top
+        || (n_req > 0 && isForAllTy ty)  -- A visible quantifier at top, and we need it
+      = do { rec { (n_req', wrap_gen, tv_nms, bndrs, given, inner_ty) <- skolemiseRequired skol_info n_req ty
+                 ; let sig_skol = SigSkol ctx top_ty (tv_nms `zip` skol_tvs)
+                       skol_tvs = binderVars bndrs
+                 ; skol_info <- mkSkolemInfo sig_skol }
+             -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]
+             --           in GHC.Tc.Utils.TcType
+           ; (ev_binds, (wrap_res, result))
+                  <- checkConstraints (getSkolemInfo skol_info) skol_tvs given $
+                     check n_req'
+                           (reverse (map ExpForAllPatTy bndrs) ++ rev_pat_tys)
+                           inner_ty
+           ; assertPpr (not (null bndrs && null given)) (ppr ty) $
+                       -- The guard ensures that we made some progress
+             return (wrap_gen <.> mkWpLet ev_binds <.> wrap_res, result) }
+
+    ----------------------------
+    -- Base case: (n_req == 0): no more args
+    --    The earlier skolemisation ensurs that rho_ty has no top-level invisible quantifiers
+    --    If there is deep subsumption, do deep skolemisation now
+    check n_req rev_pat_tys rho_ty
+      | n_req == 0
       = do { let pat_tys = reverse rev_pat_tys
            ; ds_flag <- getDeepSubsumptionFlag
            ; case ds_flag of
@@ -810,52 +821,34 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
                           -- They do not line up with binders in the Match
                           thing_inside pat_tys (mkCheckExpType rho_ty) }
 
-    -- NOW do coreView.  We didn't do it before, so that we do not unnecessarily
-    -- unwrap a synonym in the returned rho_ty
-    check n_so_far rev_pat_tys ty
-      | Just ty' <- coreView ty = check n_so_far rev_pat_tys ty'
-
-    -- Decompose /visible/ (forall a -> blah), to give an ExpForAllPat
-    -- NB: invisible binders are handled by tcSplitSigmaTy/tcTopSkolemise above
-    -- NB: visible foralls "count" for the Arity argument; they correspond
-    --     to syntactically visible patterns in the source program
-    -- See Note [Visible type application and abstraction] in GHC.Tc.Gen.App
-    check n_so_far rev_pat_tys ty
-      | Just (Bndr tv vis, body_ty) <- splitForAllForAllTyBinder_maybe ty
-      = assertPpr (isVisibleForAllTyFlag vis) (ppr ty) $
-        -- isSigmaTy case above has dealt with /invisible/ quantifiers,
-        -- so this one must be /visible/ (= Required)
-        do { let init_subst = mkEmptySubst (mkInScopeSet (tyCoVarsOfType ty))
-             -- rec {..}: see Note [Keeping SkolemInfo inside a SkolemTv]
-             --           in GHC.Tc.Utils.TcType
-           ; rec { (subst', [tv']) <- tcInstSkolTyVarsX skol_info init_subst [tv]
-                 ; let tv_prs = [(tyVarName tv, tv')]
-                 ; skol_info <- mkSkolemInfo (SigSkol ctx top_ty tv_prs) }
-           ; let body_ty' = substTy subst' body_ty
-                 pat_ty   = ExpForAllPatTy (mkForAllTyBinder Required tv')
-           ; (ev_binds, (wrap_res, result)) <- checkConstraints (getSkolemInfo skol_info) [tv'] [] $
-                                               check (n_so_far+1) (pat_ty : rev_pat_tys) body_ty'
-           ; let wrap_gen = mkWpVisTyLam tv' body_ty' <.> mkWpLet ev_binds
-           ; return (wrap_gen <.> wrap_res, result) }
-
-    check n_so_far rev_pat_tys (FunTy { ft_af = af, ft_mult = mult
-                                      , ft_arg = arg_ty, ft_res = res_ty })
+    ----------------------------
+    -- Function types
+    check n_req rev_pat_tys (FunTy { ft_af = af, ft_mult = mult
+                                   , ft_arg = arg_ty, ft_res = res_ty })
       = assert (isVisibleFunArg af) $
-        do { let arg_pos = n_so_far + 1
+        do { let arg_pos = arity - n_req + 1   -- 1 for the first argument etc
            ; (arg_co, arg_ty) <- hasFixedRuntimeRep (FRRExpectedFunTy herald arg_pos) arg_ty
-           ; (wrap_res, result) <- check arg_pos
+           ; (wrap_res, result) <- check (n_req - 1)
                                          (mkCheckExpFunPatTy (Scaled mult arg_ty) : rev_pat_tys)
                                          res_ty
            ; let wrap_arg = mkWpCastN arg_co
                  fun_wrap = mkWpFun wrap_arg wrap_res (Scaled mult arg_ty) res_ty
            ; return (fun_wrap, result) }
 
-    check n_so_far rev_pat_tys ty@(TyVarTy tv)
+    ----------------------------
+    -- Type variables
+    check n_req rev_pat_tys ty@(TyVarTy tv)
       | isMetaTyVar tv
       = do { cts <- readMetaTyVar tv
            ; case cts of
-               Indirect ty' -> check n_so_far rev_pat_tys ty'
-               Flexi        -> defer n_so_far rev_pat_tys ty }
+               Indirect ty' -> check n_req rev_pat_tys ty'
+               Flexi        -> defer n_req rev_pat_tys ty }
+
+    ----------------------------
+    -- NOW do coreView.  We didn't do it before, so that we do not unnecessarily
+    -- unwrap a synonym in the returned rho_ty
+    check n_req rev_pat_tys ty
+      | Just ty' <- coreView ty = check n_req rev_pat_tys ty'
 
        -- In all other cases we bale out into ordinary unification
        -- However unlike the meta-tyvar case, we are sure that the
@@ -872,14 +865,14 @@ matchExpectedFunTys herald ctx arity (Check top_ty) thing_inside
        --
        -- But in that case we add specialized type into error context
        -- anyway, because it may be useful. See also #9605.
-    check n_so_far rev_pat_tys res_ty
+    check n_req rev_pat_tys res_ty
       = addErrCtxtM (mkFunTysMsg herald (arity, top_ty))  $
-        defer n_so_far rev_pat_tys res_ty
+        defer n_req rev_pat_tys res_ty
 
     ------------
     defer :: VisArity -> [ExpPatType] -> TcRhoType -> TcM (HsWrapper, a)
-    defer n_so_far rev_pat_tys fun_ty
-      = do { more_arg_tys <- mapM (new_check_arg_ty herald) [n_so_far + 1 .. arity]
+    defer n_req rev_pat_tys fun_ty
+      = do { more_arg_tys <- mapM (new_check_arg_ty herald) [arity - n_req + 1 .. arity]
            ; let all_pats = reverse rev_pat_tys ++ map mkCheckExpFunPatTy more_arg_tys
            ; res_ty <- newOpenFlexiTyVarTy
            ; result <- thing_inside all_pats (mkCheckExpType res_ty)
@@ -894,7 +887,7 @@ new_infer_arg_ty herald arg_pos -- position for error messages only
        ; return (mkScaled mult inf_hole) }
 
 new_check_arg_ty :: ExpectedFunTyOrigin -> Int -> TcM (Scaled TcType)
-new_check_arg_ty herald arg_pos -- Position for error messages only
+new_check_arg_ty herald arg_pos -- Position for error messages only, 1 for first arg
   = do { mult   <- newFlexiTyVarTy multiplicityTy
        ; arg_ty <- newOpenFlexiFRRTyVarTy (FRRExpectedFunTy herald arg_pos)
        ; return (mkScaled mult arg_ty) }

compiler/GHC/ThToHs.hs

@@ -1485,7 +1485,8 @@ cvtp (ListP ps)        = do { ps' <- cvtPats ps
                             ; return
                                    $ ListPat noAnn ps'}
 cvtp (SigP p t)        = do { p' <- cvtPat p; t' <- cvtType t
-                            ; return $ SigPat noAnn p' (mkHsPatSigType noAnn t') }
+                            ; let pp = parenthesizePat sigPrec p'
+                            ; return $ SigPat noAnn pp (mkHsPatSigType noAnn t') }
 cvtp (ViewP e p)       = do { e' <- cvtl e; p' <- cvtPat p
                             ; return $ ViewPat noAnn e' p'}
 cvtp (TypeP t)         = do { t' <- cvtType t

compiler/GHC/Types/Unique.hs

@@ -249,6 +249,8 @@ use `deriving' because we want {\em precise} control of ordering
 -- the interface files are created, in particular we don't care about
 -- register allocation and code generation.
 -- To track progress on bit-for-bit determinism see #12262.
+--
+-- ROMES:TODO: Will need to update this ^ !
 
 eqUnique :: Unique -> Unique -> Bool
 eqUnique (MkUnique u1) (MkUnique u2) = u1 == u2

compiler/GHC/Types/Var.hs

@@ -503,7 +503,7 @@ isSpecifiedForAllTyFlag _                         = False
 coreTyLamForAllTyFlag :: ForAllTyFlag
 -- ^ The ForAllTyFlag on a (Lam a e) term, where `a` is a type variable.
 -- If you want other ForAllTyFlag, use a cast.
--- See Note [ForAllCo] in GHC.Core.TyCo.Rep
+-- See Note [Required foralls in Core] in GHC.Core.TyCo.Rep
 coreTyLamForAllTyFlag = Specified
 
 instance Outputable ForAllTyFlag where

compiler/ghc.cabal.in

@@ -260,6 +260,7 @@ Library
         GHC.Cmm.Switch
         GHC.Cmm.Switch.Implement
         GHC.Cmm.ThreadSanitizer
+        GHC.Cmm.UniqueRenamer
         GHC.CmmToAsm
         GHC.Cmm.LRegSet
         GHC.CmmToAsm.AArch64

libraries/base/src/Data/Array/Byte.hs

@@ -41,6 +41,22 @@ import Prelude
 -- but wrap and unwrap 'ByteArray' internally as they please
 -- and use functions from "GHC.Exts".
 --
+-- The memory representation of a 'ByteArray' is:
+--
+-- > ╭─────────────┬───╮  ╭────────┬──────┬─────────╮
+-- > │ Constructor │ * ┼─➤│ Header │ Size │ Payload │
+-- > ╰─────────────┴───╯  ╰────────┴──────┴─────────╯
+--
+-- And its overhead is the following:
+--
+-- * 'ByteArray' constructor: 1 word
+-- * Pointer to 'ByteArray#': 1 word
+-- * 'ByteArray#' Header: 1 word
+-- * 'ByteArray#' Size: 1 word
+--
+-- Where a word is the unit of heap allocation,
+-- measuring 8 bytes on 64-bit systems, and 4 bytes on 32-bit systems.
+--
 -- @since 4.17.0.0
 data ByteArray = ByteArray ByteArray#