[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: configure: Set LD_STAGE0 appropiately when 9.10.1 is used as a boot compiler
Marge Bot (@marge-bot)
gitlab at gitlab.haskell.org
Mon Jul 8 11:13:49 UTC 2024
Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC
Commits:
564981bd by Matthew Pickering at 2024-07-05T07:35:29-04:00
configure: Set LD_STAGE0 appropiately when 9.10.1 is used as a boot compiler
In 9.10.1 the "ld command" has been removed, so we fall back to using
the more precise "merge objects command" when it's available as
LD_STAGE0 is only used to set the object merging command in hadrian.
Fixes #24949
- - - - -
a949c792 by Matthew Pickering at 2024-07-05T07:35:29-04:00
hadrian: Don't build ghci object files for ./hadrian/ghci target
There is some convoluted logic which determines whether we build ghci
object files are not. In any case, if you set `ghcDynPrograms = pure
False` then it forces them to be built.
Given we aren't ever building executables with this flavour it's fine
to leave `ghcDynPrograms` as the default and it should be a bit faster
to build less.
Also fixes #24949
- - - - -
48bd8f8e by Matthew Pickering at 2024-07-05T07:36:06-04:00
hadrian: Remove STG dump from ticky_ghc flavour transformer
This adds 10-15 minutes to build time, it is a better strategy to
precisely enable dumps for the modules which show up prominently in a
ticky profile.
Given I am one of the only people regularly building ticky compilers I
think it's worthwhile to remove these.
Fixes #23635
- - - - -
5b1aefb7 by Matthew Pickering at 2024-07-05T07:36:06-04:00
hadrian: Add dump_stg flavour transformer
This allows you to write `--flavour=default+ticky_ghc+dump_stg` if you
really want STG for all modules.
- - - - -
a66c5454 by Sven Tennie at 2024-07-08T07:13:31-04:00
AArch64: Simplify stmtToInstrs type
There's no need to hand `Nothing`s around... (there was no case with a
`BlockId`.)
- - - - -
2c1bcbd6 by Sven Tennie at 2024-07-08T07:13:31-04:00
AArch64: Simplify stmtsToInstrs type
The `BlockId` parameter (`bid`) is never used, only handed around.
Deleting it simplifies the surrounding code.
- - - - -
5cc08d8d by Simon Peyton Jones at 2024-07-08T07:13:31-04:00
Fix eta-expansion in Prep
As #25033 showed, we were eta-expanding in a way that broke a join point,
which messed up Note [CorePrep invariants].
The fix is rather easy. See Wrinkle (EA1) of
Note [Eta expansion of arguments in CorePrep]
- - - - -
8 changed files:
- compiler/GHC/CmmToAsm/AArch64/CodeGen.hs
- compiler/GHC/CoreToStg/Prep.hs
- configure.ac
- hadrian/doc/flavours.md
- hadrian/src/Flavour.hs
- hadrian/src/Settings/Flavours/GhcInGhci.hs
- + testsuite/tests/simplCore/should_compile/T25033.hs
- testsuite/tests/simplCore/should_compile/all.T
Changes:
=====================================
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
=====================================
@@ -0,0 +1,18 @@
+{-# 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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d2c779b4bdfa00ce71b7bd52db24a64f65219d66...5cc08d8d280fea12e52c0cefd3cf2d93f6bfd6e1
--
This project does not include diff previews in email notifications.
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/d2c779b4bdfa00ce71b7bd52db24a64f65219d66...5cc08d8d280fea12e52c0cefd3cf2d93f6bfd6e1
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20240708/77a6df53/attachment-0001.html>
More information about the ghc-commits
mailing list