.gitmodules

@@ -129,3 +129,6 @@
 [submodule ".arc-linters/arcanist-external-json-linter"]
 	path = .arc-linters/arcanist-external-json-linter
 	url = ../arcanist-external-json-linter.git
+[submodule "hadrian"]
+	path = hadrian
+	url = ../hadrian.git

aclocal.m4

@@ -1237,15 +1237,18 @@ if test -z "$CC"
 then
   AC_MSG_ERROR([gcc is required])
 fi
+GccLT46=NO
 AC_CACHE_CHECK([version of gcc], [fp_cv_gcc_version],
 [
     # Be sure only to look at the first occurrence of the "version " string;
     # Some Apple compilers emit multiple messages containing this string.
     fp_cv_gcc_version="`$CC -v 2>&1 | sed -n -e '1,/version /s/.*version [[^0-9]]*\([[0-9.]]*\).*/\1/p'`"
-    FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.7],
-                        [AC_MSG_ERROR([Need at least gcc version 4.7])])
+    FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.4],
+                        [AC_MSG_ERROR([Need at least gcc version 4.4 (4.7+ recommended)])])
+    FP_COMPARE_VERSIONS([$fp_cv_gcc_version], [-lt], [4.6], GccLT46=YES)
 ])
 AC_SUBST([GccVersion], [$fp_cv_gcc_version])
+AC_SUBST(GccLT46)
 ])# FP_GCC_VERSION
 
 dnl Check to see if the C compiler is clang or llvm-gcc
@@ -1278,6 +1281,24 @@ AC_SUBST(GccIsClang)
 rm -f conftest.txt
 ])
 
+# FP_GCC_SUPPORTS__ATOMICS
+# ------------------------
+# Does gcc support the __atomic_* family of builtins?
+AC_DEFUN([FP_GCC_SUPPORTS__ATOMICS],
+[
+   AC_REQUIRE([AC_PROG_CC])
+   AC_MSG_CHECKING([whether GCC supports __atomic_ builtins])
+   echo 'int test(int *x) { int y; __atomic_load(&x, &y, __ATOMIC_SEQ_CST); return x; }' > conftest.c
+   if $CC -c conftest.c > /dev/null 2>&1; then
+       CONF_GCC_SUPPORTS__ATOMICS=YES
+       AC_MSG_RESULT([yes])
+   else
+       CONF_GCC_SUPPORTS__ATOMICS=NO
+       AC_MSG_RESULT([no])
+   fi
+   rm -f conftest.c conftest.o
+])
+
 # FP_GCC_SUPPORTS_NO_PIE
 # ----------------------
 # Does gcc support the -no-pie option? If so we should pass it to gcc when
@@ -1848,6 +1869,9 @@ case "$1" in
   mips*)
     $2="mips"
     ;;
+  nios2)
+    $2="nios2"
+    ;;
   powerpc64le*)
     $2="powerpc64le"
     ;;
@@ -1954,8 +1978,11 @@ AC_DEFUN([GHC_CONVERT_OS],[
       linux-*|linux)
         $3="linux"
         ;;
+      openbsd*)
+        $3="openbsd"
+        ;;
       # As far as I'm aware, none of these have relevant variants
-      freebsd|netbsd|openbsd|dragonfly|hpux|linuxaout|kfreebsdgnu|freebsd2|solaris2|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|haiku)
+      freebsd|netbsd|dragonfly|hpux|linuxaout|kfreebsdgnu|freebsd2|mingw32|darwin|gnu|nextstep2|nextstep3|sunos4|ultrix|haiku)
         $3="$1"
         ;;
       aix*) # e.g. powerpc-ibm-aix7.1.3.0
@@ -1964,6 +1991,9 @@ AC_DEFUN([GHC_CONVERT_OS],[
       darwin*) # e.g. aarch64-apple-darwin14
         $3="darwin"
         ;;
+      solaris2*)
+        $3="solaris2"
+        ;;
       freebsd*) # like i686-gentoo-freebsd7
                 #      i686-gentoo-freebsd8
                 #      i686-gentoo-freebsd8.2
@@ -2334,6 +2364,7 @@ AC_DEFUN([FIND_LD],[
         # Make sure the user didn't specify LD manually.
         if test "z$LD" != "z"; then
             AC_CHECK_TARGET_TOOL([LD], [ld])
+            LD_NO_GOLD=$LD
             return
         fi
 
@@ -2346,10 +2377,16 @@ AC_DEFUN([FIND_LD],[
             if test "x$TmpLd" = "x"; then continue; fi
 
             out=`$TmpLd --version`
+            LD_NO_GOLD=$TmpLd
             case $out in
-              "GNU ld"*)   FP_CC_LINKER_FLAG_TRY(bfd, $2) ;;
-              "GNU gold"*) FP_CC_LINKER_FLAG_TRY(gold, $2) ;;
-              "LLD"*)      FP_CC_LINKER_FLAG_TRY(lld, $2) ;;
+              "GNU ld"*)
+                   FP_CC_LINKER_FLAG_TRY(bfd, $2) ;;
+              "GNU gold"*)
+                   FP_CC_LINKER_FLAG_TRY(gold, $2)
+                   LD_NO_GOLD=ld
+                   ;;
+              "LLD"*)
+                   FP_CC_LINKER_FLAG_TRY(lld, $2) ;;
               *) AC_MSG_NOTICE([unknown linker version $out]) ;;
             esac
             if test "z$$2" = "z"; then
@@ -2366,12 +2403,16 @@ AC_DEFUN([FIND_LD],[
 
         # Fallback
         AC_CHECK_TARGET_TOOL([LD], [ld])
+        # This isn't entirely safe since $LD may have been discovered to be
+        $ ld.gold, but what else can we do?
+        if test "x$LD_NO_GOLD" = "x"; then LD_NO_GOLD=$LD; fi
     }
 
     if test "x$enable_ld_override" = "xyes"; then
         find_ld
     else
         AC_CHECK_TARGET_TOOL([LD], [ld])
+        if test "x$LD_NO_GOLD" = "x"; then LD_NO_GOLD=$LD; fi
     fi
 
     CHECK_LD_COPY_BUG([$1])

compiler/backpack/RnModIface.hs

@@ -654,6 +654,7 @@ rnIfaceCo (IfaceForAllCo bndr co1 co2)
     = IfaceForAllCo <$> rnIfaceTvBndr bndr <*> rnIfaceCo co1 <*> rnIfaceCo co2
 rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c)
 rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl
+rnIfaceCo (IfaceHoleCo lcl)  = IfaceHoleCo  <$> pure lcl
 rnIfaceCo (IfaceAxiomInstCo n i cs)
     = IfaceAxiomInstCo <$> rnIfaceGlobal n <*> pure i <*> mapM rnIfaceCo cs
 rnIfaceCo (IfaceUnivCo s r t1 t2)

compiler/basicTypes/VarEnv.hs

@@ -34,7 +34,7 @@ module VarEnv (
         extendDVarEnvList,
         lookupDVarEnv, elemDVarEnv,
         isEmptyDVarEnv, foldDVarEnv,
-        mapDVarEnv,
+        mapDVarEnv, filterDVarEnv,
         modifyDVarEnv,
         alterDVarEnv,
         plusDVarEnv, plusDVarEnv_C,
@@ -557,6 +557,9 @@ foldDVarEnv = foldUDFM
 mapDVarEnv :: (a -> b) -> DVarEnv a -> DVarEnv b
 mapDVarEnv = mapUDFM
 
+filterDVarEnv      :: (a -> Bool) -> DVarEnv a -> DVarEnv a
+filterDVarEnv = filterUDFM
+
 alterDVarEnv :: (Maybe a -> Maybe a) -> DVarEnv a -> Var -> DVarEnv a
 alterDVarEnv = alterUDFM
 

compiler/cmm/CmmCommonBlockElim.hs

@@ -24,7 +24,6 @@ import qualified Data.List as List
 import Data.Word
 import qualified Data.Map as M
 import Outputable
-import DynFlags (DynFlags)
 import UniqFM
 import UniqDFM
 import qualified TrieMap as TM
@@ -60,11 +59,11 @@ import Control.Arrow (first, second)
 -- rightfully complained: #10397
 
 -- TODO: Use optimization fuel
-elimCommonBlocks :: DynFlags -> CmmGraph -> CmmGraph
-elimCommonBlocks dflags g = replaceLabels env $ copyTicks env g
+elimCommonBlocks :: CmmGraph -> CmmGraph
+elimCommonBlocks g = replaceLabels env $ copyTicks env g
   where
-     env = iterate dflags mapEmpty blocks_with_key
-     groups = groupByInt (hash_block dflags) (postorderDfs g)
+     env = iterate mapEmpty blocks_with_key
+     groups = groupByInt hash_block (postorderDfs g)
      blocks_with_key = [ [ (successors b, [b]) | b <- bs] | bs <- groups]
 
 -- Invariant: The blocks in the list are pairwise distinct
@@ -74,47 +73,42 @@ type Key = [Label]
 type Subst = LabelMap BlockId
 
 -- The outer list groups by hash. We retain this grouping throughout.
-iterate :: DynFlags -> Subst -> [[(Key, DistinctBlocks)]] -> Subst
-iterate dflags subst blocks
+iterate :: Subst -> [[(Key, DistinctBlocks)]] -> Subst
+iterate subst blocks
     | mapNull new_substs = subst
-    | otherwise = iterate dflags subst' updated_blocks
+    | otherwise = iterate subst' updated_blocks
   where
     grouped_blocks :: [[(Key, [DistinctBlocks])]]
     grouped_blocks = map groupByLabel blocks
 
     merged_blocks :: [[(Key, DistinctBlocks)]]
-    (new_substs, merged_blocks) =
-        List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
+    (new_substs, merged_blocks) = List.mapAccumL (List.mapAccumL go) mapEmpty grouped_blocks
       where
         go !new_subst1 (k,dbs) = (new_subst1 `mapUnion` new_subst2, (k,db))
           where
-            (new_subst2, db) = mergeBlockList dflags subst dbs
+            (new_subst2, db) = mergeBlockList subst dbs
 
     subst' = subst `mapUnion` new_substs
     updated_blocks = map (map (first (map (lookupBid subst')))) merged_blocks
 
-mergeBlocks :: DynFlags -> Subst
-            -> DistinctBlocks -> DistinctBlocks
-            -> (Subst, DistinctBlocks)
-mergeBlocks dflags subst existing new = go new
+mergeBlocks :: Subst -> DistinctBlocks -> DistinctBlocks -> (Subst, DistinctBlocks)
+mergeBlocks subst existing new = go new
   where
     go [] = (mapEmpty, existing)
-    go (b:bs) =
-        case List.find (eqBlockBodyWith dflags (eqBid subst) b) existing of
-          -- This block is a duplicate. Drop it, and add it to the substitution
-          Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
-          -- This block is not a duplicate, keep it.
-          Nothing -> second (b:) $ go bs
-
-mergeBlockList :: DynFlags -> Subst -> [DistinctBlocks]
-               -> (Subst, DistinctBlocks)
-mergeBlockList _      _     [] = pprPanic "mergeBlockList" empty
-mergeBlockList dflags subst (b:bs) = go mapEmpty b bs
+    go (b:bs) = case List.find (eqBlockBodyWith (eqBid subst) b) existing of
+        -- This block is a duplicate. Drop it, and add it to the substitution
+        Just b' -> first (mapInsert (entryLabel b) (entryLabel b')) $ go bs
+        -- This block is not a duplicate, keep it.
+        Nothing -> second (b:) $ go bs
+
+mergeBlockList :: Subst -> [DistinctBlocks] -> (Subst, DistinctBlocks)
+mergeBlockList _ [] = pprPanic "mergeBlockList" empty
+mergeBlockList subst (b:bs) = go mapEmpty b bs
   where
     go !new_subst1 b [] = (new_subst1, b)
     go !new_subst1 b1 (b2:bs) = go new_subst b bs
       where
-        (new_subst2, b) =  mergeBlocks dflags subst b1 b2
+        (new_subst2, b) =  mergeBlocks subst b1 b2
         new_subst = new_subst1 `mapUnion` new_subst2
 
 
@@ -132,110 +126,39 @@ mergeBlockList dflags subst (b:bs) = go mapEmpty b bs
 -- expensive. So include as much as possible in the hash. Ideally everything
 -- that is compared with (==) in eqBlockBodyWith.
 
-{-
-Note [Equivalence up to local registers in CBE]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-
-CBE treats two blocks which are equivalent up to alpha-renaming of locally-bound
-local registers as equivalent. This was not always the case (see #14226) but is
-quite important for effective CBE. For instance, consider the blocks,
-
-    c2VZ: // global
-        _c2Yd::I64 = _s2Se::I64 + 1;
-        _s2Sx::I64 = _c2Yd::I64;
-        _s2Se::I64 = _s2Sx::I64;
-        goto c2TE;
-
-    c2VY: // global
-        _c2Yb::I64 = _s2Se::I64 + 1;
-        _s2Sw::I64 = _c2Yb::I64;
-        _s2Se::I64 = _s2Sw::I64;
-        goto c2TE;
-
-These clearly implement precisely the same logic, differing only register
-naming. This happens quite often in the code produced by GHC.
-
-This alpha-equivalence relation must be accounted for in two places:
-
- 1. the block hash function (hash_block), which we use for approximate "binning"
- 2. the exact block comparison function, which computes pair-wise equivalence
-
-In (1) we maintain a de Bruijn numbering of each block's locally-bound local
-registers and compute the hash relative to this numbering.
-
-For (2) we maintain a substitution which maps the local registers of one block
-onto those of the other. We then compare local registers modulo this
-substitution.
-
--}
-
 type HashCode = Int
 
-type LocalRegEnv a = UniqFM a
-type DeBruijn = Int
-
--- | Maintains a de Bruijn numbering of local registers bound within a block.
---
--- See Note [Equivalence up to local registers in CBE]
-data HashEnv = HashEnv { localRegHashEnv :: !(LocalRegEnv DeBruijn)
-                       , nextIndex       :: !DeBruijn
-                       }
-
-hash_block :: DynFlags -> CmmBlock -> HashCode
-hash_block dflags block =
-  --pprTrace "hash_block" (ppr (entryLabel block) $$ ppr hash)
-  hash
-  where hash_fst _ (env, h) = (env, h)
-        hash_mid m (env, h) = let (env', h') = hash_node env m
-                              in (env', h' + h `shiftL` 1)
-        hash_lst m (env, h) = let (env', h') = hash_node env m
-                              in (env', h' + h `shiftL` 1)
-
-        hash =
-            let (_, raw_hash) =
-                    foldBlockNodesF3 (hash_fst, hash_mid, hash_lst)
-                                     block
-                                     (emptyEnv, 0 :: Word32)
-                emptyEnv = HashEnv mempty 0
-            in fromIntegral (raw_hash .&. (0x7fffffff :: Word32))
-               -- UniqFM doesn't like negative Ints
-
-        hash_node :: HashEnv -> CmmNode O x -> (HashEnv, Word32)
-        hash_node env n =
-            (env', hash)
-          where
-            hash =
-              case n of
-                n | dont_care n -> 0  -- don't care
-                -- don't include register as it is a binding occurrence
-                CmmAssign (CmmLocal _) e -> hash_e env e
-                CmmAssign r e   -> hash_reg env r + hash_e env e
-                CmmStore e e'   -> hash_e env e + hash_e env e'
-                CmmUnsafeForeignCall t _ as
-                                -> hash_tgt env t + hash_list (hash_e env) as
-                CmmBranch _     ->  23 -- NB. ignore the label
-                CmmCondBranch p _ _ _ -> hash_e env p
-                CmmCall e _ _ _ _ _   -> hash_e env e
-                CmmForeignCall t _ _ _ _ _ _ -> hash_tgt env t
-                CmmSwitch e _   -> hash_e env e
-                _               -> error "hash_node: unknown Cmm node!"
-            env' = foldLocalRegsDefd dflags (flip bind_local_reg) env n
-
-        hash_reg :: HashEnv -> CmmReg -> Word32
-        hash_reg env (CmmLocal localReg)
-          | Just idx <- lookupUFM (localRegHashEnv env) localReg
-          = fromIntegral idx
-          | otherwise
-          = hash_unique localReg -- important for performance, see #10397
-        hash_reg _  (CmmGlobal _)    = 19
-
-        hash_e :: HashEnv -> CmmExpr -> Word32
-        hash_e _   (CmmLit l) = hash_lit l
-        hash_e env (CmmLoad e _) = 67 + hash_e env e
-        hash_e env (CmmReg r) = hash_reg env r
-        hash_e env (CmmMachOp _ es) = hash_list (hash_e env) es -- pessimal - no operator check
-        hash_e env (CmmRegOff r i) = hash_reg env r + cvt i
-        hash_e _   (CmmStackSlot _ _) = 13
+hash_block :: CmmBlock -> HashCode
+hash_block block =
+  fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
+  -- UniqFM doesn't like negative Ints
+  where hash_fst _ h = h
+        hash_mid m h = hash_node m + h `shiftL` 1
+        hash_lst m h = hash_node m + h `shiftL` 1
+
+        hash_node :: CmmNode O x -> Word32
+        hash_node n | dont_care n = 0 -- don't care
+        hash_node (CmmAssign r e) = hash_reg r + hash_e e
+        hash_node (CmmStore e e') = hash_e e + hash_e e'
+        hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
+        hash_node (CmmBranch _) = 23 -- NB. ignore the label
+        hash_node (CmmCondBranch p _ _ _) = hash_e p
+        hash_node (CmmCall e _ _ _ _ _) = hash_e e
+        hash_node (CmmForeignCall t _ _ _ _ _ _) = hash_tgt t
+        hash_node (CmmSwitch e _) = hash_e e
+        hash_node _ = error "hash_node: unknown Cmm node!"
+
+        hash_reg :: CmmReg -> Word32
+        hash_reg   (CmmLocal localReg) = hash_unique localReg -- important for performance, see #10397
+        hash_reg   (CmmGlobal _)    = 19
+
+        hash_e :: CmmExpr -> Word32
+        hash_e (CmmLit l) = hash_lit l
+        hash_e (CmmLoad e _) = 67 + hash_e e
+        hash_e (CmmReg r) = hash_reg r
+        hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
+        hash_e (CmmRegOff r i) = hash_reg r + cvt i
+        hash_e (CmmStackSlot _ _) = 13
 
         hash_lit :: CmmLit -> Word32
         hash_lit (CmmInt i _) = fromInteger i
@@ -247,21 +170,13 @@ hash_block dflags block =
         hash_lit (CmmBlock _) = 191 -- ugh
         hash_lit (CmmHighStackMark) = cvt 313
 
-        hash_tgt :: HashEnv -> ForeignTarget -> Word32
-        hash_tgt env (ForeignTarget e _) = hash_e env e
-        hash_tgt _   (PrimTarget _) = 31 -- lots of these
+        hash_tgt (ForeignTarget e _) = hash_e e
+        hash_tgt (PrimTarget _) = 31 -- lots of these
 
-        hash_list f = List.foldl' (\z x -> f x + z) (0::Word32)
+        hash_list f = foldl (\z x -> f x + z) (0::Word32)
 
         cvt = fromInteger . toInteger
 
-        bind_local_reg :: LocalReg -> HashEnv -> HashEnv
-        bind_local_reg reg env =
-            env { localRegHashEnv =
-                    addToUFM (localRegHashEnv env) reg (nextIndex env)
-                , nextIndex = nextIndex env + 1
-                }
-
         hash_unique :: Uniquable a => a -> Word32
         hash_unique = cvt . getKey . getUnique
 
@@ -282,76 +197,34 @@ lookupBid subst bid = case mapLookup bid subst of
                         Just bid  -> lookupBid subst bid
                         Nothing -> bid
 
--- | Maps the local registers of one block to those of another
---
--- See Note [Equivalence up to local registers in CBE]
-type LocalRegMapping = LocalRegEnv LocalReg
-
 -- Middle nodes and expressions can contain BlockIds, in particular in
 -- CmmStackSlot and CmmBlock, so we have to use a special equality for
 -- these.
 --
-eqMiddleWith :: DynFlags
-             -> (BlockId -> BlockId -> Bool)
-             -> LocalRegMapping
-             -> CmmNode O O -> CmmNode O O
-             -> (LocalRegMapping, Bool)
-eqMiddleWith dflags eqBid env a b =
-  case (a, b) of
-     -- registers aren't compared since they are binding occurrences
-    (CmmAssign (CmmLocal _) e1,  CmmAssign (CmmLocal _) e2) ->
-        let eq = eqExprWith eqBid env e1 e2
-        in (env', eq)
-
-    (CmmAssign r1 e1,  CmmAssign r2 e2) ->
-        let eq = r1 == r2
-              && eqExprWith eqBid env e1 e2
-        in (env', eq)
-
-    (CmmStore l1 r1,  CmmStore l2 r2) ->
-        let eq = eqExprWith eqBid env l1 l2
-              && eqExprWith eqBid env r1 r2
-        in (env', eq)
-
-     -- result registers aren't compared since they are binding occurrences
-    (CmmUnsafeForeignCall t1 _ a1,  CmmUnsafeForeignCall t2 _ a2) ->
-        let eq = t1 == t2
-              && eqLists (eqExprWith eqBid env) a1 a2
-        in (env', eq)
-
-    _ -> (env, False)
-  where
-    env' = List.foldl' (\acc (ra,rb) -> addToUFM acc ra rb) emptyUFM
-           $ List.zip defd_a defd_b
-    defd_a = foldLocalRegsDefd dflags (flip (:)) [] a
-    defd_b = foldLocalRegsDefd dflags (flip (:)) [] b
-
-eqLists :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-eqLists f (a:as) (b:bs) = f a b && eqLists f as bs
-eqLists _ []     []     = True
-eqLists _ _      _      = False
+eqMiddleWith :: (BlockId -> BlockId -> Bool)
+             -> CmmNode O O -> CmmNode O O -> Bool
+eqMiddleWith eqBid (CmmAssign r1 e1) (CmmAssign r2 e2)
+  = r1 == r2 && eqExprWith eqBid e1 e2
+eqMiddleWith eqBid (CmmStore l1 r1) (CmmStore l2 r2)
+  = eqExprWith eqBid l1 l2 && eqExprWith eqBid r1 r2
+eqMiddleWith eqBid (CmmUnsafeForeignCall t1 r1 a1)
+                   (CmmUnsafeForeignCall t2 r2 a2)
+  = t1 == t2 && r1 == r2 && eqListWith (eqExprWith eqBid) a1 a2
+eqMiddleWith _ _ _ = False
 
 eqExprWith :: (BlockId -> BlockId -> Bool)
-           -> LocalRegMapping
-           -> CmmExpr -> CmmExpr
-           -> Bool
-eqExprWith eqBid env = eq
+           -> CmmExpr -> CmmExpr -> Bool
+eqExprWith eqBid = eq
  where
   CmmLit l1          `eq` CmmLit l2          = eqLit l1 l2
   CmmLoad e1 _       `eq` CmmLoad e2 _       = e1 `eq` e2
-  CmmReg r1          `eq` CmmReg r2          = r1 `eqReg` r2
-  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1 `eqReg` r2 && i1==i2
+  CmmReg r1          `eq` CmmReg r2          = r1==r2
+  CmmRegOff r1 i1    `eq` CmmRegOff r2 i2    = r1==r2 && i1==i2
   CmmMachOp op1 es1  `eq` CmmMachOp op2 es2  = op1==op2 && es1 `eqs` es2
   CmmStackSlot a1 i1 `eq` CmmStackSlot a2 i2 = eqArea a1 a2 && i1==i2
   _e1                `eq` _e2                = False
 
-  xs `eqs` ys = eqLists eq xs ys
-
-  -- See Note [Equivalence up to local registers in CBE]
-  CmmLocal a `eqReg` CmmLocal b
-    | Just a' <- lookupUFM env a
-    = a' == b
-  a `eqReg` b = a == b
+  xs `eqs` ys = eqListWith eq xs ys
 
   eqLit (CmmBlock id1) (CmmBlock id2) = eqBid id1 id2
   eqLit l1 l2 = l1 == l2
@@ -362,10 +235,8 @@ eqExprWith eqBid env = eq
 
 -- Equality on the body of a block, modulo a function mapping block
 -- IDs to block IDs.
-eqBlockBodyWith :: DynFlags
-                -> (BlockId -> BlockId -> Bool)
-                -> CmmBlock -> CmmBlock -> Bool
-eqBlockBodyWith dflags eqBid block block'
+eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
+eqBlockBodyWith eqBid block block'
   {-
   | equal     = pprTrace "equal" (vcat [ppr block, ppr block']) True
   | otherwise = pprTrace "not equal" (vcat [ppr block, ppr block']) False
@@ -376,46 +247,30 @@ eqBlockBodyWith dflags eqBid block block'
         (_,m',l') = blockSplit block'
         nodes'    = filter (not . dont_care) (blockToList m')
 
-        eqMids :: LocalRegMapping -> [CmmNode O O] -> [CmmNode O O] -> Bool
-        eqMids env (a:as) (b:bs)
-          | eq = eqMids env' as bs
-          where
-            (env', eq) = eqMiddleWith dflags eqBid env a b
-        eqMids env [] [] = eqLastWith eqBid env l l'
-        eqMids _ _ _ = False
-
-        equal = eqMids emptyUFM nodes nodes'
-
-
-eqLastWith :: (BlockId -> BlockId -> Bool) -> LocalRegMapping
-           -> CmmNode O C -> CmmNode O C -> Bool
-eqLastWith eqBid env a b =
-    case (a, b) of
-      (CmmBranch bid1, CmmBranch bid2) -> eqBid bid1 bid2
-      (CmmCondBranch c1 t1 f1 l1, CmmCondBranch c2 t2 f2 l2) ->
-          eqExprWith eqBid env c1 c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
-      (CmmCall t1 c1 g1 a1 r1 u1, CmmCall t2 c2 g2 a2 r2 u2) ->
-             t1 == t2
-          && eqMaybeWith eqBid c1 c2
-          && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
-      (CmmSwitch e1 ids1, CmmSwitch e2 ids2) ->
-          eqExprWith eqBid env e1 e2 && eqSwitchTargetWith eqBid ids1 ids2
-      -- result registers aren't compared since they are binding occurrences
-      (CmmForeignCall t1 _ a1 s1 ret_args1 ret_off1 intrbl1,
-       CmmForeignCall t2 _ a2 s2 ret_args2 ret_off2 intrbl2) ->
-             t1 == t2
-          && eqLists (eqExprWith eqBid env) a1 a2
-          && s1 == s2
-          && ret_args1 == ret_args2
-          && ret_off1 == ret_off2
-          && intrbl1 == intrbl2
-      _ -> False
+        equal = eqListWith (eqMiddleWith eqBid) nodes nodes' &&
+                eqLastWith eqBid l l'
+
+
+eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
+eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
+eqLastWith eqBid (CmmCondBranch c1 t1 f1 l1) (CmmCondBranch c2 t2 f2 l2) =
+  c1 == c2 && l1 == l2 && eqBid t1 t2 && eqBid f1 f2
+eqLastWith eqBid (CmmCall t1 c1 g1 a1 r1 u1) (CmmCall t2 c2 g2 a2 r2 u2) =
+  t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2 && g1 == g2
+eqLastWith eqBid (CmmSwitch e1 ids1) (CmmSwitch e2 ids2) =
+  e1 == e2 && eqSwitchTargetWith eqBid ids1 ids2
+eqLastWith _ _ _ = False
 
 eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
 eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
 eqMaybeWith _ Nothing Nothing = True
 eqMaybeWith _ _ _ = False
 
+eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqListWith f (a : as) (b : bs) = f a b && eqListWith f as bs
+eqListWith _ []       []       = True
+eqListWith _ _        _        = False
+
 -- | Given a block map, ensure that all "target" blocks are covered by
 -- the same ticks as the respective "source" blocks. This not only
 -- means copying ticks, but also adjusting tick scopes where

compiler/cmm/CmmMachOp.hs

@@ -587,6 +587,8 @@ data CallishMachOp
   | MO_Memcmp Int
 
   | MO_PopCnt Width
+  | MO_Pdep Width
+  | MO_Pext Width
   | MO_Clz Width
   | MO_Ctz Width
 

compiler/cmm/CmmParse.y

@@ -1006,6 +1006,16 @@ callishMachOps = listToUFM $
         ( "popcnt32", (,) $ MO_PopCnt W32 ),
         ( "popcnt64", (,) $ MO_PopCnt W64 ),
 
+        ( "pdep8",  (,) $ MO_Pdep W8  ),
+        ( "pdep16", (,) $ MO_Pdep W16 ),
+        ( "pdep32", (,) $ MO_Pdep W32 ),
+        ( "pdep64", (,) $ MO_Pdep W64 ),
+
+        ( "pext8",  (,) $ MO_Pext W8  ),
+        ( "pext16", (,) $ MO_Pext W16 ),
+        ( "pext32", (,) $ MO_Pext W32 ),
+        ( "pext64", (,) $ MO_Pext W64 ),
+
         ( "cmpxchg8",  (,) $ MO_Cmpxchg W8  ),
         ( "cmpxchg16", (,) $ MO_Cmpxchg W16 ),
         ( "cmpxchg32", (,) $ MO_Cmpxchg W32 ),

compiler/cmm/CmmPipeline.hs

@@ -68,7 +68,7 @@ cpsTop hsc_env proc =
 
        ----------- Eliminate common blocks -------------------------------------
        g <- {-# SCC "elimCommonBlocks" #-}
-            condPass Opt_CmmElimCommonBlocks (elimCommonBlocks dflags) g
+            condPass Opt_CmmElimCommonBlocks elimCommonBlocks g
                           Opt_D_dump_cmm_cbe "Post common block elimination"
 
        -- Any work storing block Labels must be performed _after_

compiler/cmm/Hoopl/Block.hs

@@ -24,7 +24,6 @@ module Hoopl.Block
     , foldBlockNodesB
     , foldBlockNodesB3
     , foldBlockNodesF
-    , foldBlockNodesF3
     , isEmptyBlock
     , lastNode
     , mapBlock

compiler/cmm/PprC.hs

@@ -789,6 +789,8 @@ pprCallishMachOp_for_C mop
         MO_Memcmp _     -> text "memcmp"
         (MO_BSwap w)    -> ptext (sLit $ bSwapLabel w)
         (MO_PopCnt w)   -> ptext (sLit $ popCntLabel w)
+        (MO_Pext w)     -> ptext (sLit $ pextLabel w)
+        (MO_Pdep w)     -> ptext (sLit $ pdepLabel w)
         (MO_Clz w)      -> ptext (sLit $ clzLabel w)
         (MO_Ctz w)      -> ptext (sLit $ ctzLabel w)
         (MO_AtomicRMW w amop) -> ptext (sLit $ atomicRMWLabel w amop)

compiler/codeGen/StgCmmBind.hs

@@ -113,7 +113,8 @@ cgTopRhsClosure dflags rec id ccs _ upd_flag args body =
                  -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
         ; emitDataLits closure_label closure_rep
         ; let fv_details :: [(NonVoid Id, ByteOff)]
-              (_, _, fv_details) = mkVirtHeapOffsets dflags (isLFThunk lf_info) []
+              header = if isLFThunk lf_info then ThunkHeader else StdHeader
+              (_, _, fv_details) = mkVirtHeapOffsets dflags header []
         -- Don't drop the non-void args until the closure info has been made
         ; forkClosureBody (closureCodeBody True id closure_info ccs
                                 (nonVoidIds args) (length args) body fv_details)
@@ -350,9 +351,9 @@ mkRhsClosure dflags bndr cc _ fvs upd_flag args body
         ; let   name  = idName bndr
                 descr = closureDescription dflags mod_name name
                 fv_details :: [(NonVoid Id, ByteOff)]
+                header = if isLFThunk lf_info then ThunkHeader else StdHeader
                 (tot_wds, ptr_wds, fv_details)
-                   = mkVirtHeapOffsets dflags (isLFThunk lf_info)
-                                       (addIdReps reduced_fvs)
+                   = mkVirtHeapOffsets dflags header (addIdReps reduced_fvs)
                 closure_info = mkClosureInfo dflags False       -- Not static
                                              bndr lf_info tot_wds ptr_wds
                                              descr
@@ -395,9 +396,10 @@ cgRhsStdThunk bndr lf_info payload
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
   ; dflags <- getDynFlags
-  ; let (tot_wds, ptr_wds, payload_w_offsets)
-            = mkVirtHeapOffsets dflags (isLFThunk lf_info)
-                                (addArgReps (nonVoidStgArgs payload))
+  ; let header = if isLFThunk lf_info then ThunkHeader else StdHeader
+        (tot_wds, ptr_wds, payload_w_offsets)
+            = mkVirtHeapOffsets dflags header
+                (addArgReps (nonVoidStgArgs payload))
 
         descr = closureDescription dflags mod_name (idName bndr)
         closure_info = mkClosureInfo dflags False       -- Not static

compiler/codeGen/StgCmmCon.hs

@@ -79,11 +79,10 @@ cgTopRhsCon dflags id con args =
 
         -- LAY IT OUT
         ; let
-            is_thunk = False
             (tot_wds, --  #ptr_wds + #nonptr_wds
              ptr_wds, --  #ptr_wds
              nv_args_w_offsets) =
-                 mkVirtHeapOffsetsWithPadding dflags is_thunk (addArgReps args)
+                 mkVirtHeapOffsetsWithPadding dflags StdHeader (addArgReps args)
 
             mk_payload (Padding len _) = return (CmmInt 0 (widthFromBytes len))
             mk_payload (FieldOff arg _) = do

compiler/codeGen/StgCmmExpr.hs

@@ -61,7 +61,8 @@ cgExpr  :: StgExpr -> FCode ReturnKind
 
 cgExpr (StgApp fun args)     = cgIdApp fun args
 
-{- seq# a s ==> a -}
+-- seq# a s ==> a
+-- See Note [seq# magic] in PrelRules
 cgExpr (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _res_ty) =
   cgIdApp a []
 
@@ -446,13 +447,14 @@ cgCase scrut@(StgApp v []) _ (PrimAlt _) _
 
 {- Note [Handle seq#]
 ~~~~~~~~~~~~~~~~~~~~~
-case seq# a s of v
-  (# s', a' #) -> e
+See Note [seq# magic] in PrelRules.
+The special case for seq# in cgCase does this:
 
+  case seq# a s of v
+    (# s', a' #) -> e
 ==>
-
-case a of v
-  (# s', a' #) -> e
+  case a of v
+    (# s', a' #) -> e
 
 (taking advantage of the fact that the return convention for (# State#, a #)
 is the same as the return convention for just 'a')
@@ -460,6 +462,7 @@ is the same as the return convention for just 'a')
 
 cgCase (StgOpApp (StgPrimOp SeqOp) [StgVarArg a, _] _) bndr alt_type alts
   = -- Note [Handle seq#]
+    -- And see Note [seq# magic] in PrelRules
     -- Use the same return convention as vanilla 'a'.
     cgCase (StgApp a []) bndr alt_type alts
 

compiler/codeGen/StgCmmLayout.hs

@@ -19,6 +19,7 @@ module StgCmmLayout (
         slowCall, directCall,
 
         FieldOffOrPadding(..),
+        ClosureHeader(..),
         mkVirtHeapOffsets,
         mkVirtHeapOffsetsWithPadding,
         mkVirtConstrOffsets,
@@ -399,9 +400,17 @@ data FieldOffOrPadding a
     | Padding ByteOff  -- Length of padding in bytes.
               ByteOff  -- Offset in bytes.
 
+-- | Used to tell the various @mkVirtHeapOffsets@ functions what kind
+-- of header the object has.  This will be accounted for in the
+-- offsets of the fields returned.
+data ClosureHeader
+  = NoHeader
+  | StdHeader
+  | ThunkHeader
+
 mkVirtHeapOffsetsWithPadding
   :: DynFlags
-  -> Bool                     -- True <=> is a thunk
+  -> ClosureHeader            -- What kind of header to account for
   -> [NonVoid (PrimRep, a)]   -- Things to make offsets for
   -> ( WordOff                -- Total number of words allocated
      , WordOff                -- Number of words allocated for *pointers*
@@ -415,15 +424,17 @@ mkVirtHeapOffsetsWithPadding
 -- mkVirtHeapOffsetsWithPadding always returns boxed things with smaller offsets
 -- than the unboxed things
 
-mkVirtHeapOffsetsWithPadding dflags is_thunk things =
+mkVirtHeapOffsetsWithPadding dflags header things =
     ASSERT(not (any (isVoidRep . fst . fromNonVoid) things))
     ( tot_wds
     , bytesToWordsRoundUp dflags bytes_of_ptrs
     , concat (ptrs_w_offsets ++ non_ptrs_w_offsets) ++ final_pad
     )
   where
-    hdr_words | is_thunk   = thunkHdrSize dflags
-              | otherwise  = fixedHdrSizeW dflags
+    hdr_words = case header of
+      NoHeader -> 0
+      StdHeader -> fixedHdrSizeW dflags
+      ThunkHeader -> thunkHdrSize dflags
     hdr_bytes = wordsToBytes dflags hdr_words
 
     (ptrs, non_ptrs) = partition (isGcPtrRep . fst . fromNonVoid) things
@@ -472,25 +483,25 @@ mkVirtHeapOffsetsWithPadding dflags is_thunk things =
 
 mkVirtHeapOffsets
   :: DynFlags
-  -> Bool                     -- True <=> is a thunk
+  -> ClosureHeader            -- What kind of header to account for
   -> [NonVoid (PrimRep,a)]    -- Things to make offsets for
   -> (WordOff,                -- _Total_ number of words allocated
       WordOff,                -- Number of words allocated for *pointers*
       [(NonVoid a, ByteOff)])
-mkVirtHeapOffsets dflags is_thunk things =
+mkVirtHeapOffsets dflags header things =
     ( tot_wds
     , ptr_wds
     , [ (field, offset) | (FieldOff field offset) <- things_offsets ]
     )
   where
    (tot_wds, ptr_wds, things_offsets) =
-       mkVirtHeapOffsetsWithPadding dflags is_thunk things
+       mkVirtHeapOffsetsWithPadding dflags header things
 
 -- | Just like mkVirtHeapOffsets, but for constructors
 mkVirtConstrOffsets
   :: DynFlags -> [NonVoid (PrimRep, a)]
   -> (WordOff, WordOff, [(NonVoid a, ByteOff)])
-mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags False
+mkVirtConstrOffsets dflags = mkVirtHeapOffsets dflags StdHeader
 
 -- | Just like mkVirtConstrOffsets, but used when we don't have the actual
 -- arguments. Useful when e.g. generating info tables; we just need to know

compiler/codeGen/StgCmmPrim.hs

@@ -584,6 +584,20 @@ emitPrimOp _      [res] PopCnt32Op [w] = emitPopCntCall res w W32
 emitPrimOp _      [res] PopCnt64Op [w] = emitPopCntCall res w W64
 emitPrimOp dflags [res] PopCntOp   [w] = emitPopCntCall res w (wordWidth dflags)
 
+-- Parallel bit deposit
+emitPrimOp _      [res] Pdep8Op  [src, mask] = emitPdepCall res src mask W8
+emitPrimOp _      [res] Pdep16Op [src, mask] = emitPdepCall res src mask W16
+emitPrimOp _      [res] Pdep32Op [src, mask] = emitPdepCall res src mask W32
+emitPrimOp _      [res] Pdep64Op [src, mask] = emitPdepCall res src mask W64
+emitPrimOp dflags [res] PdepOp   [src, mask] = emitPdepCall res src mask (wordWidth dflags)
+
+-- Parallel bit extract
+emitPrimOp _      [res] Pext8Op  [src, mask] = emitPextCall res src mask W8
+emitPrimOp _      [res] Pext16Op [src, mask] = emitPextCall res src mask W16
+emitPrimOp _      [res] Pext32Op [src, mask] = emitPextCall res src mask W32
+emitPrimOp _      [res] Pext64Op [src, mask] = emitPextCall res src mask W64
+emitPrimOp dflags [res] PextOp   [src, mask] = emitPextCall res src mask (wordWidth dflags)
+
 -- count leading zeros
 emitPrimOp _      [res] Clz8Op  [w] = emitClzCall res w W8
 emitPrimOp _      [res] Clz16Op [w] = emitClzCall res w W16
@@ -1732,8 +1746,51 @@ doCompareByteArraysOp res ba1 ba1_off ba2 ba2_off n = do
     dflags <- getDynFlags
     ba1_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba1 (arrWordsHdrSize dflags)) ba1_off
     ba2_p <- assignTempE $ cmmOffsetExpr dflags (cmmOffsetB dflags ba2 (arrWordsHdrSize dflags)) ba2_off
+
+    -- short-cut in case of equal pointers avoiding a costly
+    -- subroutine call to the memcmp(3) routine; the Cmm logic below
+    -- results in assembly code being generated for
+    --
+    --   cmpPrefix10 :: ByteArray# -> ByteArray# -> Int#
+    --   cmpPrefix10 ba1 ba2 = compareByteArrays# ba1 0# ba2 0# 10#
+    --
+    -- that looks like
+    --
+    --          leaq 16(%r14),%rax
+    --          leaq 16(%rsi),%rbx
+    --          xorl %ecx,%ecx
+    --          cmpq %rbx,%rax
+    --          je l_ptr_eq
+    --
+    --          ; NB: the common case (unequal pointers) falls-through
+    --          ; the conditional jump, and therefore matches the
+    --          ; usual static branch prediction convention of modern cpus
+    --
+    --          subq $8,%rsp
+    --          movq %rbx,%rsi
+    --          movq %rax,%rdi
+    --          movl $10,%edx
+    --          xorl %eax,%eax
+    --          call memcmp
+    --          addq $8,%rsp
+    --          movslq %eax,%rax
+    --          movq %rax,%rcx
+    --  l_ptr_eq:
+    --          movq %rcx,%rbx
+    --          jmp *(%rbp)
+
+    l_ptr_eq <- newBlockId
+    l_ptr_ne <- newBlockId
+
+    emit (mkAssign (CmmLocal res) (zeroExpr dflags))
+    emit (mkCbranch (cmmEqWord dflags ba1_p ba2_p)
+                    l_ptr_eq l_ptr_ne (Just False))
+
+    emitLabel l_ptr_ne
     emitMemcmpCall res ba1_p ba2_p n 1
 
+    emitLabel l_ptr_eq
+
 -- ----------------------------------------------------------------------------
 -- Copying byte arrays
 
@@ -2266,6 +2323,20 @@ emitPopCntCall res x width = do
         (MO_PopCnt width)
         [ x ]
 
+emitPdepCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPdepCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pdep width)
+        [ x, y ]
+
+emitPextCall :: LocalReg -> CmmExpr -> CmmExpr -> Width -> FCode ()
+emitPextCall res x y width = do
+    emitPrimCall
+        [ res ]
+        (MO_Pext width)
+        [ x, y ]
+
 emitClzCall :: LocalReg -> CmmExpr -> Width -> FCode ()
 emitClzCall res x width = do
     emitPrimCall

compiler/codeGen/StgCmmProf.hs

@@ -209,7 +209,7 @@ ifProfilingL dflags xs
 
 initCostCentres :: CollectedCCs -> FCode ()
 -- Emit the declarations
-initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
+initCostCentres (local_CCs, singleton_CCSs)
   = do dflags <- getDynFlags
        when (gopt Opt_SccProfilingOn dflags) $
            do mapM_ emitCostCentreDecl local_CCs

compiler/coreSyn/CoreFVs.hs

@@ -386,13 +386,13 @@ orphNamesOfCo (CoherenceCo co1 co2) = orphNamesOfCo co1 `unionNameSet` orphNames
 orphNamesOfCo (KindCo co)           = orphNamesOfCo co
 orphNamesOfCo (SubCo co)            = orphNamesOfCo co
 orphNamesOfCo (AxiomRuleCo _ cs)    = orphNamesOfCos cs
+orphNamesOfCo (HoleCo _)            = emptyNameSet
 
 orphNamesOfProv :: UnivCoProvenance -> NameSet
 orphNamesOfProv UnsafeCoerceProv    = emptyNameSet
 orphNamesOfProv (PhantomProv co)    = orphNamesOfCo co
 orphNamesOfProv (ProofIrrelProv co) = orphNamesOfCo co
 orphNamesOfProv (PluginProv _)      = emptyNameSet
-orphNamesOfProv (HoleProv _)        = emptyNameSet
 
 orphNamesOfCos :: [Coercion] -> NameSet
 orphNamesOfCos = orphNamesOfThings orphNamesOfCo

compiler/coreSyn/CoreLint.hs

@@ -531,7 +531,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
        ; checkL ( isJoinId binder
                || not (isUnliftedType binder_ty)
                || (isNonRec rec_flag && exprOkForSpeculation rhs)
-               || exprIsLiteralString rhs)
+               || exprIsTickedString rhs)
            (badBndrTyMsg binder (text "unlifted"))
 
         -- Check that if the binder is top-level or recursive, it's not
@@ -539,14 +539,14 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
         -- computation to perform, see Note [CoreSyn top-level string literals].
        ; checkL (not (isStrictId binder)
             || (isNonRec rec_flag && not (isTopLevel top_lvl_flag))
-            || exprIsLiteralString rhs)
+            || exprIsTickedString rhs)
            (mkStrictMsg binder)
 
         -- Check that if the binder is at the top level and has type Addr#,
         -- that it is a string literal, see
         -- Note [CoreSyn top-level string literals].
        ; checkL (not (isTopLevel top_lvl_flag && binder_ty `eqType` addrPrimTy)
-                 || exprIsLiteralString rhs)
+                 || exprIsTickedString rhs)
            (mkTopNonLitStrMsg binder)
 
        ; flags <- getLintFlags
@@ -1123,7 +1123,7 @@ checkCaseAlts e ty alts =
   where
     (con_alts, maybe_deflt) = findDefault alts
 
-        -- Check that successive alternatives have increasing tags
+        -- Check that successive alternatives have strictly increasing tags
     increasing_tag (alt1 : rest@( alt2 : _)) = alt1 `ltAlt` alt2 && increasing_tag rest
     increasing_tag _                         = True
 
@@ -1666,8 +1666,6 @@ lintCoercion co@(UnivCo prov r ty1 ty2)
                                     ; check_kinds kco k1 k2 }
 
            PluginProv _     -> return ()  -- no extra checks
-           HoleProv h       -> addErrL $
-                               text "Unfilled coercion hole:" <+> ppr h
 
        ; when (r /= Phantom && classifiesTypeWithValues k1
                             && classifiesTypeWithValues k2)
@@ -1874,6 +1872,11 @@ lintCoercion this@(AxiomRuleCo co cs)
                           [ text "Expected:" <+> int (n + length es)
                           , text "Provided:" <+> int n ]
 
+lintCoercion (HoleCo h)
+  = do { addErrL $ text "Unfilled coercion hole:" <+> ppr h
+       ; lintCoercion (CoVarCo (coHoleCoVar h)) }
+
+
 ----------
 lintUnliftedCoVar :: CoVar -> LintM ()
 lintUnliftedCoVar cv

compiler/coreSyn/CoreOpt.hs

@@ -22,7 +22,7 @@ module CoreOpt (
 
 import GhcPrelude
 
-import CoreArity( joinRhsArity, etaExpandToJoinPoint )
+import CoreArity( etaExpandToJoinPoint )
 
 import CoreSyn
 import CoreSubst
@@ -644,58 +644,18 @@ joinPointBinding_maybe bndr rhs
   = Just (bndr, rhs)
 
   | AlwaysTailCalled join_arity <- tailCallInfo (idOccInfo bndr)
-  , not (bad_unfolding join_arity (idUnfolding bndr))
   , (bndrs, body) <- etaExpandToJoinPoint join_arity rhs
   = Just (bndr `asJoinId` join_arity, mkLams bndrs body)
 
   | otherwise
   = Nothing
 
-  where
-    -- bad_unfolding returns True if we should /not/ convert a non-join-id
-    -- into a join-id, even though it is AlwaysTailCalled
-    -- See Note [Join points and INLINE pragmas]
-    bad_unfolding join_arity (CoreUnfolding { uf_src = src, uf_tmpl = rhs })
-      = isStableSource src && join_arity > joinRhsArity rhs
-    bad_unfolding _ (DFunUnfolding {})
-      = True
-    bad_unfolding _ _
-      = False
-
 joinPointBindings_maybe :: [(InBndr, InExpr)] -> Maybe [(InBndr, InExpr)]
 joinPointBindings_maybe bndrs
   = mapM (uncurry joinPointBinding_maybe) bndrs
 
 
-{- Note [Join points and INLINE pragmas]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Consider
-   f x = let g = \x. not  -- Arity 1
-             {-# INLINE g #-}
-         in case x of
-              A -> g True True
-              B -> g True False
-              C -> blah2
-
-Here 'g' is always tail-called applied to 2 args, but the stable
-unfolding captured by the INLINE pragma has arity 1.  If we try to
-convert g to be a join point, its unfolding will still have arity 1
-(since it is stable, and we don't meddle with stable unfoldings), and
-Lint will complain (see Note [Invariants on join points], (2a), in
-CoreSyn.  Trac #13413.
-
-Moreover, since g is going to be inlined anyway, there is no benefit
-from making it a join point.
-
-If it is recursive, and uselessly marked INLINE, this will stop us
-making it a join point, which is annoying.  But occasionally
-(notably in class methods; see Note [Instances and loop breakers] in
-TcInstDcls) we mark recursive things as INLINE but the recursion
-unravels; so ignoring INLINE pragmas on recursive things isn't good
-either.
-
-
-************************************************************************
+{- *********************************************************************
 *                                                                      *
          exprIsConApp_maybe
 *                                                                      *

compiler/coreSyn/CorePrep.hs

@@ -60,12 +60,14 @@ import Name             ( NamedThing(..), nameSrcSpan )
 import SrcLoc           ( SrcSpan(..), realSrcLocSpan, mkRealSrcLoc )
 import Data.Bits
 import MonadUtils       ( mapAccumLM )
-import Data.List        ( mapAccumL )
+import Data.List        ( mapAccumL, foldl' )
 import Control.Monad
+import CostCentre       ( CostCentre, ccFromThisModule )
+import qualified Data.Set as S
 
 {-
 -- ---------------------------------------------------------------------------
--- Overview
+-- Note [CorePrep Overview]
 -- ---------------------------------------------------------------------------
 
 The goal of this pass is to prepare for code generation.
@@ -124,6 +126,10 @@ The goal of this pass is to prepare for code generation.
     (non-type) applications where we can, and make sure that we
     annotate according to scoping rules when floating.
 
+12. Collect cost centres (including cost centres in unfoldings) if we're in
+    profiling mode. We have to do this here beucase we won't have unfoldings
+    after this pass (see `zapUnfolding` and Note [Drop unfoldings and rules].
+
 This is all done modulo type applications and abstractions, so that
 when type erasure is done for conversion to STG, we don't end up with
 any trivial or useless bindings.
@@ -169,7 +175,7 @@ type CpeRhs  = CoreExpr    -- Non-terminal 'rhs'
 -}
 
 corePrepPgm :: HscEnv -> Module -> ModLocation -> CoreProgram -> [TyCon]
-            -> IO CoreProgram
+            -> IO (CoreProgram, S.Set CostCentre)
 corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
     withTiming (pure dflags)
                (text "CorePrep"<+>brackets (ppr this_mod))
@@ -177,7 +183,13 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
     us <- mkSplitUniqSupply 's'
     initialCorePrepEnv <- mkInitialCorePrepEnv dflags hsc_env
 
-    let implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
+    let cost_centres
+          | WayProf `elem` ways dflags
+          = collectCostCentres this_mod binds
+          | otherwise
+          = S.empty
+
+        implicit_binds = mkDataConWorkers dflags mod_loc data_tycons
             -- NB: we must feed mkImplicitBinds through corePrep too
             -- so that they are suitably cloned and eta-expanded
 
@@ -187,7 +199,7 @@ corePrepPgm hsc_env this_mod mod_loc binds data_tycons =
                       return (deFloatTop (floats1 `appendFloats` floats2))
 
     endPassIO hsc_env alwaysQualify CorePrep binds_out []
-    return binds_out
+    return (binds_out, cost_centres)
   where
     dflags = hsc_dflags hsc_env
 
@@ -1600,3 +1612,39 @@ wrapTicks (Floats flag floats0) expr =
                                              (ppr other)
         wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs)
         wrapBind t (Rec pairs)         = Rec (mapSnd (mkTick t) pairs)
+
+------------------------------------------------------------------------------
+-- Collecting cost centres
+-- ---------------------------------------------------------------------------
+
+-- | Collect cost centres defined in the current module, including those in
+-- unfoldings.
+collectCostCentres :: Module -> CoreProgram -> S.Set CostCentre
+collectCostCentres mod_name
+  = foldl' go_bind S.empty
+  where
+    go cs e = case e of
+      Var{} -> cs
+      Lit{} -> cs
+      App e1 e2 -> go (go cs e1) e2
+      Lam _ e -> go cs e
+      Let b e -> go (go_bind cs b) e
+      Case scrt _ _ alts -> go_alts (go cs scrt) alts
+      Cast e _ -> go cs e
+      Tick (ProfNote cc _ _) e ->
+        go (if ccFromThisModule cc mod_name then S.insert cc cs else cs) e
+      Tick _ e -> go cs e
+      Type{} -> cs
+      Coercion{} -> cs
+
+    go_alts = foldl' (\cs (_con, _bndrs, e) -> go cs e)
+
+    go_bind :: S.Set CostCentre -> CoreBind -> S.Set CostCentre
+    go_bind cs (NonRec b e) =
+      go (maybe cs (go cs) (get_unf b)) e
+    go_bind cs (Rec bs) =
+      foldl' (\cs' (b, e) -> go (maybe cs' (go cs') (get_unf b)) e) cs bs
+
+    -- Unfoldings may have cost centres that in the original definion are
+    -- optimized away, see #5889.
+    get_unf = maybeUnfoldingTemplate . realIdUnfolding