compiler/GHC/CmmToAsm/AArch64/CodeGen.hs

@@ -51,7 +51,6 @@ import GHC.Data.OrdList
 import GHC.Utils.Outputable
 
 import Control.Monad    ( mapAndUnzipM, foldM )
-import Data.Maybe
 import GHC.Float
 
 import GHC.Types.Basic
@@ -149,8 +148,8 @@ basicBlockCodeGen block = do
             let line = srcSpanStartLine span; col = srcSpanStartCol span
             return $ unitOL $ LOCATION fileId line col (unpackFS name)
     _ -> return nilOL
-  (mid_instrs,mid_bid) <- stmtsToInstrs id stmts
-  (!tail_instrs,_) <- stmtToInstrs mid_bid tail
+  mid_instrs <- stmtsToInstrs stmts
+  (!tail_instrs) <- stmtToInstrs tail
   let instrs = header_comment_instr `appOL` loc_instrs `appOL` mid_instrs `appOL` tail_instrs
   -- TODO: Then x86 backend run @verifyBasicBlock@ here and inserts
   --      unwinding info. See Ticket 19913
@@ -252,38 +251,27 @@ generateJumpTableForInstr _ _ = Nothing
 -- -----------------------------------------------------------------------------
 -- Top-level of the instruction selector
 
--- See Note [Keeping track of the current block] for why
--- we pass the BlockId.
-stmtsToInstrs :: BlockId -- ^ Basic block these statement will start to be placed in.
-              -> [CmmNode O O] -- ^ Cmm Statement
-              -> NatM (InstrBlock, BlockId) -- ^ Resulting instruction
-stmtsToInstrs bid stmts =
-    go bid stmts nilOL
+stmtsToInstrs :: [CmmNode O O] -- ^ Cmm Statements
+              -> NatM InstrBlock -- ^ Resulting instructions
+stmtsToInstrs stmts =
+    go stmts nilOL
   where
-    go bid  []        instrs = return (instrs,bid)
-    go bid (s:stmts)  instrs = do
-      (instrs',bid') <- stmtToInstrs bid s
-      -- If the statement introduced a new block, we use that one
-      let !newBid = fromMaybe bid bid'
-      go newBid stmts (instrs `appOL` instrs')
-
--- | `bid` refers to the current block and is used to update the CFG
---   if new blocks are inserted in the control flow.
--- See Note [Keeping track of the current block] for more details.
-stmtToInstrs :: BlockId -- ^ Basic block this statement will start to be placed in.
-             -> CmmNode e x
-             -> NatM (InstrBlock, Maybe BlockId)
-             -- ^ Instructions, and bid of new block if successive
-             -- statements are placed in a different basic block.
-stmtToInstrs bid stmt = do
+    go []        instrs = return instrs
+    go (s:stmts) instrs = do
+      instrs' <- stmtToInstrs s
+      go stmts (instrs `appOL` instrs')
+
+stmtToInstrs :: CmmNode e x -- ^ Cmm Statement
+             -> NatM InstrBlock -- ^ Resulting Instructions
+stmtToInstrs stmt = do
   -- traceM $ "-- -------------------------- stmtToInstrs -------------------------- --\n"
   --     ++ showSDocUnsafe (ppr stmt)
   platform <- getPlatform
   case stmt of
     CmmUnsafeForeignCall target result_regs args
-       -> genCCall target result_regs args bid
+       -> genCCall target result_regs args
 
-    _ -> (,Nothing) <$> case stmt of
+    _ -> case stmt of
       CmmComment s   -> return (unitOL (COMMENT (ftext s)))
       CmmTick {}     -> return nilOL
 
@@ -304,7 +292,7 @@ stmtToInstrs bid stmt = do
       --We try to arrange blocks such that the likely branch is the fallthrough
       --in GHC.Cmm.ContFlowOpt. So we can assume the condition is likely false here.
       CmmCondBranch arg true false _prediction ->
-          genCondBranch bid true false arg
+          genCondBranch true false arg
 
       CmmSwitch arg ids -> genSwitch arg ids
 
@@ -1456,14 +1444,12 @@ genCondFarJump cond far_target = do
                 , B far_target
                 , NEWBLOCK skip_lbl_id]
 
-genCondBranch
-    :: BlockId      -- the source of the jump
-    -> BlockId      -- the true branch target
+genCondBranch :: BlockId      -- the true branch target
     -> BlockId      -- the false branch target
     -> CmmExpr      -- the condition on which to branch
     -> NatM InstrBlock -- Instructions
 
-genCondBranch _ true false expr = do
+genCondBranch true false expr = do
   b1 <- genCondJump true expr
   b2 <- genBranch false
   return (b1 `appOL` b2)
@@ -1549,11 +1535,10 @@ genCCall
     :: ForeignTarget      -- function to call
     -> [CmmFormal]        -- where to put the result
     -> [CmmActual]        -- arguments (of mixed type)
-    -> BlockId            -- The block we are in
-    -> NatM (InstrBlock, Maybe BlockId)
+    -> NatM InstrBlock
 -- TODO: Specialize where we can.
 -- Generic impl
-genCCall target dest_regs arg_regs bid = do
+genCCall target dest_regs arg_regs = do
   -- we want to pass arg_regs into allArgRegs
   -- pprTraceM "genCCall target" (ppr target)
   -- pprTraceM "genCCall formal" (ppr dest_regs)
@@ -1617,7 +1602,7 @@ genCCall target dest_regs arg_regs bid = do
             `appOL` (unitOL $ BL call_target passRegs) -- branch and link.
             `appOL` readResultsCode           -- parse the results into registers
             `appOL` moveStackUp (stackSpace `div` 8)
-      return (code, Nothing)
+      return code
 
     PrimTarget MO_F32_Fabs
       | [arg_reg] <- arg_regs, [dest_reg] <- dest_regs ->
@@ -1642,7 +1627,7 @@ genCCall target dest_regs arg_regs bid = do
               let lo = getRegisterReg platform (CmmLocal dst_lo)
                   hi = getRegisterReg platform (CmmLocal dst_hi)
                   nd = getRegisterReg platform (CmmLocal dst_needed)
-              return (
+              return $
                   code_x `appOL`
                   code_y `snocOL`
                   MUL   (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`
@@ -1651,7 +1636,6 @@ genCCall target dest_regs arg_regs bid = do
                   -- nd = (hi == ASR(lo,width-1)) ? 1 : 0
                   CMP   (OpReg W64 hi) (OpRegShift W64 lo SASR (widthInBits w - 1)) `snocOL`
                   CSET  (OpReg W64 nd) NE
-                  , Nothing)
             -- For sizes < platform width, we can just perform a multiply and shift
             -- using the normal 64 bit multiply. Calculating the dst_needed value is
             -- complicated a little by the need to be careful when truncation happens.
@@ -1674,7 +1658,7 @@ genCCall target dest_regs arg_regs bid = do
               (reg_a, code_a') <- signExtendReg w w' reg_a'
               (reg_b, code_b') <- signExtendReg w w' reg_b'
 
-              return (
+              return $
                   code_a  `appOL`
                   code_b  `appOL`
                   code_a' `appOL`
@@ -1704,7 +1688,6 @@ genCCall target dest_regs arg_regs bid = do
                   CSET  (OpReg w' nd) EQ `appOL`
                   -- Finally truncate hi to drop any extraneous sign bits.
                   truncateReg w' w hi
-                  , Nothing)
           -- Can't handle > 64 bit operands
           | otherwise -> unsupported (MO_S_Mul2 w)
     PrimTarget (MO_U_Mul2  w)
@@ -1724,7 +1707,7 @@ genCCall target dest_regs arg_regs bid = do
                   code_y `snocOL`
                   MUL   (OpReg W64 lo) (OpReg W64 reg_a) (OpReg W64 reg_b) `snocOL`
                   UMULH (OpReg W64 hi) (OpReg W64 reg_a) (OpReg W64 reg_b)
-                  , Nothing)
+                  )
             -- For sizes < platform width, we can just perform a multiply and shift
             -- Need to be careful to truncate the low half, but the upper half should be
             -- be ok if the invariant in [Signed arithmetic on AArch64] is maintained.
@@ -1755,7 +1738,7 @@ genCCall target dest_regs arg_regs bid = do
                       (OpImm (ImmInt $ widthInBits w)) -- width to extract
                       `appOL`
                   truncateReg W64 w lo
-                  , Nothing)
+                  )
           | otherwise -> unsupported (MO_U_Mul2  w)
     PrimTarget (MO_Clz  w)
           | w == W64 || w == W32
@@ -1767,7 +1750,7 @@ genCCall target dest_regs arg_regs bid = do
               return (
                   code_x `snocOL`
                   CLZ   (OpReg w dst_reg) (OpReg w reg_a)
-                  , Nothing)
+                  )
           | w == W16
           , [src] <- arg_regs
           , [dst] <- dest_regs
@@ -1783,7 +1766,7 @@ genCCall target dest_regs arg_regs bid = do
                     , ORR (r dst') (r dst')  (imm 0x00008000)
                     , CLZ (r dst') (r dst')
                     ]
-                  , Nothing)
+                  )
           | w == W8
           , [src] <- arg_regs
           , [dst] <- dest_regs
@@ -1793,13 +1776,12 @@ genCCall target dest_regs arg_regs bid = do
                   r n = OpReg W32 n
                   imm n = OpImm (ImmInt n)
               {- dst = clz(x << 24 | 0x0080_0000) -}
-              return (
+              return $
                   code_x `appOL` toOL
                     [ LSL (r dst') (r reg_a) (imm 24)
                     , ORR (r dst') (r dst')  (imm 0x00800000)
                     , CLZ (r dst') (r dst')
                     ]
-                  , Nothing)
             | otherwise -> unsupported (MO_Clz  w)
     PrimTarget (MO_Ctz  w)
           | w == W64 || w == W32
@@ -1808,11 +1790,10 @@ genCCall target dest_regs arg_regs bid = do
           -> do
               (reg_a, _format_x, code_x) <- getSomeReg src
               let dst_reg = getRegisterReg platform (CmmLocal dst)
-              return (
+              return $
                   code_x `snocOL`
                   RBIT (OpReg w dst_reg) (OpReg w reg_a) `snocOL`
                   CLZ  (OpReg w dst_reg) (OpReg w dst_reg)
-                  , Nothing)
           | w == W16
           , [src] <- arg_regs
           , [dst] <- dest_regs
@@ -1822,13 +1803,12 @@ genCCall target dest_regs arg_regs bid = do
                   r n = OpReg W32 n
                   imm n = OpImm (ImmInt n)
               {- dst = clz(reverseBits(x) | 0x0000_8000) -}
-              return (
+              return $
                   code_x `appOL` toOL
                     [ RBIT (r dst') (r reg_a)
                     , ORR  (r dst') (r dst') (imm 0x00008000)
                     , CLZ  (r dst') (r dst')
                     ]
-                  , Nothing)
           | w == W8
           , [src] <- arg_regs
           , [dst] <- dest_regs
@@ -1838,13 +1818,12 @@ genCCall target dest_regs arg_regs bid = do
                   r n = OpReg W32 n
                   imm n = OpImm (ImmInt n)
               {- dst = clz(reverseBits(x) | 0x0080_0000) -}
-              return (
+              return $
                   code_x `appOL` toOL
                     [ RBIT (r dst') (r reg_a)
                     , ORR (r dst')  (r dst') (imm 0x00800000)
                     , CLZ  (r dst')  (r dst')
                     ]
-                  , Nothing)
             | otherwise -> unsupported (MO_Ctz  w)
     PrimTarget (MO_BRev  w)
           | w == W64 || w == W32
@@ -1853,10 +1832,9 @@ genCCall target dest_regs arg_regs bid = do
           -> do
               (reg_a, _format_x, code_x) <- getSomeReg src
               let dst_reg = getRegisterReg platform (CmmLocal dst)
-              return (
+              return $
                   code_x `snocOL`
                   RBIT (OpReg w dst_reg) (OpReg w reg_a)
-                  , Nothing)
           | w == W16
           , [src] <- arg_regs
           , [dst] <- dest_regs
@@ -1866,12 +1844,11 @@ genCCall target dest_regs arg_regs bid = do
                   r n = OpReg W32 n
                   imm n = OpImm (ImmInt n)
               {- dst = reverseBits32(x << 16) -}
-              return (
+              return $
                   code_x `appOL` toOL
                     [ LSL  (r dst') (r reg_a) (imm 16)
                     , RBIT (r dst') (r dst')
                     ]
-                  , Nothing)
           | w == W8
           , [src] <- arg_regs
           , [dst] <- dest_regs
@@ -1881,12 +1858,11 @@ genCCall target dest_regs arg_regs bid = do
                   r n = OpReg W32 n
                   imm n = OpImm (ImmInt n)
               {- dst = reverseBits32(x << 24) -}
-              return (
+              return $
                   code_x `appOL` toOL
                     [ LSL  (r dst') (r reg_a) (imm 24)
                     , RBIT (r dst') (r dst')
                     ]
-                  , Nothing)
             | otherwise -> unsupported (MO_BRev  w)
 
 
@@ -1989,12 +1965,12 @@ genCCall target dest_regs arg_regs bid = do
         MO_SubIntC    _w -> unsupported mop
 
         -- Memory Ordering
-        MO_AcquireFence     ->  return (unitOL DMBISH, Nothing)
-        MO_ReleaseFence     ->  return (unitOL DMBISH, Nothing)
-        MO_SeqCstFence      ->  return (unitOL DMBISH, Nothing)
-        MO_Touch            ->  return (nilOL, Nothing) -- Keep variables live (when using interior pointers)
+        MO_AcquireFence     ->  return (unitOL DMBISH)
+        MO_ReleaseFence     ->  return (unitOL DMBISH)
+        MO_SeqCstFence      ->  return (unitOL DMBISH)
+        MO_Touch            ->  return nilOL -- Keep variables live (when using interior pointers)
         -- Prefetch
-        MO_Prefetch_Data _n -> return (nilOL, Nothing) -- Prefetch hint.
+        MO_Prefetch_Data _n -> return nilOL -- Prefetch hint.
 
         -- Memory copy/set/move/cmp, with alignment for optimization
 
@@ -2029,7 +2005,7 @@ genCCall target dest_regs arg_regs bid = do
                   code =
                     code_p `snocOL`
                     instr (intFormat w) (OpReg w dst) (OpAddr $ AddrReg p)
-              return (code, Nothing)
+              return code
           | otherwise -> panic "mal-formed AtomicRead"
         MO_AtomicWrite w ord
           | [p_reg, val_reg] <- arg_regs -> do
@@ -2042,7 +2018,7 @@ genCCall target dest_regs arg_regs bid = do
                     code_p `appOL`
                     code_val `snocOL`
                     instr fmt_val (OpReg w val) (OpAddr $ AddrReg p)
-              return (code, Nothing)
+              return code
           | otherwise -> panic "mal-formed AtomicWrite"
         MO_AtomicRMW w amop -> mkCCall (atomicRMWLabel w amop)
         MO_Cmpxchg w        -> mkCCall (cmpxchgLabel w)
@@ -2055,13 +2031,13 @@ genCCall target dest_regs arg_regs bid = do
     unsupported :: Show a => a -> b
     unsupported mop = panic ("outOfLineCmmOp: " ++ show mop
                           ++ " not supported here")
-    mkCCall :: FastString -> NatM (InstrBlock, Maybe BlockId)
+    mkCCall :: FastString -> NatM InstrBlock
     mkCCall name = do
       config <- getConfig
       target <- cmmMakeDynamicReference config CallReference $
           mkForeignLabel name ForeignLabelInThisPackage IsFunction
       let cconv = ForeignConvention CCallConv [NoHint] [NoHint] CmmMayReturn
-      genCCall (ForeignTarget target cconv) dest_regs arg_regs bid
+      genCCall (ForeignTarget target cconv) dest_regs arg_regs
 
     -- TODO: Optimize using paired stores and loads (STP, LDP). It is
     -- automatically done by the allocator for us. However it's not optimal,
@@ -2227,7 +2203,7 @@ genCCall target dest_regs arg_regs bid = do
       (reg_fx, _format_x, code_fx) <- getFloatReg arg_reg
       let dst = getRegisterReg platform (CmmLocal dest_reg)
       let code = code_fx `appOL` op (OpReg w dst) (OpReg w reg_fx)
-      return (code, Nothing)
+      return code
 
 {- Note [AArch64 far jumps]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~

compiler/GHC/CoreToStg/Prep.hs

@@ -1611,7 +1611,7 @@ cpeArgArity env float_decision floats1 arg
          -- See wrinkle (EA2) in Note [Eta expansion of arguments in CorePrep]
 
   | Just ao <- cp_arityOpts (cpe_config env) -- Just <=> -O1 or -O2
-  , not (has_join_in_tail_context arg)
+  , not (eta_would_wreck_join arg)
             -- See Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]
   = case exprEtaExpandArity ao arg of
       Nothing -> 0
@@ -1620,15 +1620,15 @@ cpeArgArity env float_decision floats1 arg
   | otherwise
   = exprArity arg -- this is cheap enough for -O0
 
-has_join_in_tail_context :: CoreExpr -> Bool
+eta_would_wreck_join :: CoreExpr -> Bool
 -- ^ Identify the cases where we'd generate invalid `CpeApp`s as described in
 -- Wrinkle (EA1) of Note [Eta expansion of arguments in CorePrep]
-has_join_in_tail_context (Let bs e)            = isJoinBind bs || has_join_in_tail_context e
-has_join_in_tail_context (Lam b e) | isTyVar b = has_join_in_tail_context e
-has_join_in_tail_context (Cast e _)            = has_join_in_tail_context e
-has_join_in_tail_context (Tick _ e)            = has_join_in_tail_context e
-has_join_in_tail_context (Case _ _ _ alts)     = any has_join_in_tail_context (rhssOfAlts alts)
-has_join_in_tail_context _                     = False
+eta_would_wreck_join (Let bs e)        = isJoinBind bs || eta_would_wreck_join e
+eta_would_wreck_join (Lam _ e)         = eta_would_wreck_join e
+eta_would_wreck_join (Cast e _)        = eta_would_wreck_join e
+eta_would_wreck_join (Tick _ e)        = eta_would_wreck_join e
+eta_would_wreck_join (Case _ _ _ alts) = any eta_would_wreck_join (rhssOfAlts alts)
+eta_would_wreck_join _                 = False
 
 maybeSaturate :: Id -> CpeApp -> Int -> [CoreTickish] -> UniqSM CpeRhs
 maybeSaturate fn expr n_args unsat_ticks
@@ -1761,7 +1761,8 @@ There is a nasty Wrinkle:
 
 (EA1) When eta expanding an argument headed by a join point, we might get
       "crap", as Note [Eta expansion for join points] in GHC.Core.Opt.Arity puts
-      it.
+      it.  This crap means the output does not conform to the syntax in
+      Note [CorePrep invariants], which then makes later passes crash (#25033).
       Consider
 
         f (join j x = rhs in ...(j 1)...(j 2)...)
@@ -1776,15 +1777,22 @@ There is a nasty Wrinkle:
       In our case, (join j x = rhs in ...(j 1)...(j 2)...) is not a valid
       `CpeApp` (see Note [CorePrep invariants]) and we'd get a crash in the App
       case of `coreToStgExpr`.
-      Hence we simply check for the cases where an intervening join point
-      binding in the tail context of the argument would lead to the introduction
-      of such crap via `has_join_in_tail_context`, in which case we abstain from
-      eta expansion.
+
+      Hence, in `eta_would_wreck_join`, we check for the cases where an
+      intervening join point binding in the tail context of the argument would
+      make eta-expansion break Note [CorePrep invariants], in which
+      case we abstain from eta expansion.
 
       This scenario occurs rarely; hence it's OK to generate sub-optimal code.
       The alternative would be to fix Note [Eta expansion for join points], but
       that's quite challenging due to unfoldings of (recursive) join points.
 
+      `eta_would_wreck_join` sees if there are any join points, like `j` above
+      that would be messed up.   It must look inside lambdas (#25033); consider
+             f (\x. join j y = ... in ...(j 1)...(j 3)...)
+      We can't eta expand that `\x` any more than we could if the join was at
+      the top.  (And when there's a lambda, we don't have a thunk anyway.)
+
 (EA2) In cpeArgArity, if float_decision=FloatNone the `arg` will look like
            let <binds> in rhs
       where <binds> is non-empty and can't be floated out of a lazy context (see

configure.ac

@@ -176,6 +176,12 @@ if test "$WithGhc" != ""; then
 
   if test -z "$LD_STAGE0"; then
     BOOTSTRAPPING_GHC_INFO_FIELD([LD_STAGE0],[ld command])
+    # ld command is removed in 9.10.1 as a boot compiler and supplies "Merge objects
+    # command" instead
+    if test -z "$LD_STAGE0"; then
+      BOOTSTRAPPING_GHC_INFO_FIELD([LD_STAGE0],[Merge objects command])
+    fi
+
   fi
   if test -z "$AR_STAGE0"; then
     BOOTSTRAPPING_GHC_INFO_FIELD([AR_STAGE0],[ar command])

hadrian/doc/flavours.md

@@ -320,6 +320,10 @@ The supported transformers are listed below:
         <td><code>late_ccs</code></td>
         <td>Enable <code>-fprof-late</code> in profiled libraries.</td>
     </tr>
+    <tr>
+        <td><code>dump_stg</code></td>
+        <td>Dump STG of all modules compiled by a stage1 compiler to a file</td>
+    </tr>
 </table>
 
 ### Static

hadrian/src/Flavour.hs

@@ -68,6 +68,7 @@ flavourTransformers = M.fromList
     , "hi_core"          =: enableHiCore
     , "late_ccs"         =: enableLateCCS
     , "boot_nonmoving_gc" =: enableBootNonmovingGc
+    , "dump_stg"         =: enableDumpStg
     ]
   where (=:) = (,)
 
@@ -176,11 +177,13 @@ tickyArgs = mconcat
   [ arg "-ticky"
   , arg "-ticky-allocd"
   , arg "-ticky-dyn-thunk"
-  -- You generally need STG dumps to interpret ticky profiles
-  , arg "-ddump-to-file"
-  , arg "-ddump-stg-final"
   ]
 
+enableDumpStg :: Flavour -> Flavour
+enableDumpStg =
+  addArgs $ stage1 ?
+    builder (Ghc CompileHs) ? mconcat [ arg "-ddump-to-file", arg "-ddump-stg-final" ]
+
 -- | Enable Core, STG, and (not C--) linting in all compilations with the stage1 compiler.
 enableLinting :: Flavour -> Flavour
 enableLinting =

hadrian/src/Settings/Flavours/GhcInGhci.hs

@@ -17,7 +17,7 @@ ghcInGhciFlavour = defaultFlavour
     -- checking for Windows seems simpler for now.
     , libraryWays = pure (Set.fromList [vanilla]) <> pure (Set.fromList [ dynamic | not windowsHost ])
     , rtsWays     = pure (Set.fromList [vanilla]) <> (targetSupportsThreadedRts ? pure (Set.fromList [threaded])) <> pure (Set.fromList [ dynamic | not windowsHost ])
-    , dynamicGhcPrograms = return False }
+    }
 
 ghciArgs :: Args
 ghciArgs = sourceArgs SourceArgs

testsuite/tests/simplCore/should_compile/T25033.hs

+{-# OPTIONS_GHC -fno-do-lambda-eta-expansion #-}
+-- It's hard to trigger #25033, because the Simplier eta-expands
+-- lambdas.  So I switched off that Simplifier ability, and thereby
+-- triggered the bug on this nice small example.
+
+module T25033 where
+
+{-# NOINLINE woo #-}
+woo x = x
+
+foo v = woo (\xs -> let
+                     j ys = \ws -> xs ++ (reverse . reverse . reverse . reverse .
+                                          reverse . reverse . reverse . reverse) ws
+                   in
+                   case v of
+                     "a" -> j "wim"
+                     _   -> j "wam"
+           )

testsuite/tests/simplCore/should_compile/all.T

@@ -527,3 +527,4 @@ test('T24808', [ grep_errmsg(r'myFunction') ], compile, ['-O -ddump-simpl'])
 test('T24944', [extra_files(['T24944a.hs'])], multimod_compile, ['T24944', '-v0 -O2'])
 
 test('T24725a', [ grep_errmsg(r'testedRule')], compile, ['-O -ddump-rule-firings'])
+test('T25033', normal, compile, ['-O'])