David Eichmann pushed to branch wip/davide/hadrian-windows-symlink at Glasgow Haskell Compiler / GHC Commits: f9bcfac2 by sheaf at 2026-06-03T14:47:19-04:00 Avoid mkTick in Core Prep breaking ANF As discovered in #27182, mkTick can break ANF. This patch introduces a variant of mkTick that skips the single optimisation that could break ANF. This is preferrable over switching to the raw Tick constructor, as the latter may introduce spurious cost centres in profiling reports. This is a temporary measure until we more thoroughly refactor how mkTick works (see #27141). See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep. Fixes #27182 - - - - - cf1fd661 by Artem Pelenitsyn at 2026-06-03T14:48:09-04:00 clarify comment for getSizeofMutableByteArray#: we get the size in bytes, not "elements" - - - - - 7a23957d by David Eichmann at 2026-06-04T12:24:02+01:00 Hadrian: remove unused wrapper scripts from windows bindist These wrapper scripts are only installed on non-relocatable builds which are not generally supported on windows. - - - - - 7 changed files: - + changelog.d/T27182.md - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - hadrian/src/Rules/BinaryDist.hs - + testsuite/tests/profiling/should_compile/T27182.hs - testsuite/tests/profiling/should_compile/all.T Changes: ===================================== changelog.d/T27182.md ===================================== @@ -0,0 +1,8 @@ +section: compiler +issues: #27182 +mrs: !16003 +synopsis: + Fix `getStgArgFromTrivialArg` panic in CoreToStg +description: + Avoid a `getStgArgFromTrivialArg` panic in CoreToStg due to a call to `mkTick` + in Core Prep which invalidated ANF. ===================================== compiler/GHC/Builtin/primops.txt.pp ===================================== @@ -2149,7 +2149,7 @@ primop SizeofMutableByteArrayOp "sizeofMutableByteArray#" GenPrimOp primop GetSizeofMutableByteArrayOp "getSizeofMutableByteArray#" GenPrimOp MutableByteArray# s -> State# s -> (# State# s, Int# #) - {Return the number of elements in the array, correctly accounting for + {Return the number of bytes in the array, correctly accounting for the effect of 'shrinkMutableByteArray#' and 'resizeMutableByteArray#'. @since 0.5.0.0} ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -11,6 +11,7 @@ module GHC.Core.Utils ( -- * Constructing expressions mkCast, mkCastMCo, mkPiMCo, mkTick, mkTicks, mkTickNoHNF, tickHNFArgs, + mkTickCpe, bindNonRec, needsCaseBinding, needsCaseBindingL, mkAltExpr, mkDefaultCase, mkSingleAltCase, @@ -319,7 +320,18 @@ mkCast expr co -- * Split profiling ticks into counting/scoping parts so that the two parts -- can be placed independently into the AST. mkTick :: CoreTickish -> CoreExpr -> CoreExpr -mkTick t orig_expr = mkTick' orig_expr +mkTick = mk_tick False + +-- | A version of 'mkTick' that preserves ANF, for use in Core Prep. +-- +-- See Note [mkTick breaks ANF] in GHC.CoreToStg.Prep. +mkTickCpe :: CoreTickish -> CoreExpr -> CoreExpr +mkTickCpe = mk_tick True + +-- | Internal function used to define both 'mkTick' and 'mkTickCpe' +-- without duplication. +mk_tick :: Bool -> CoreTickish -> CoreExpr -> CoreExpr +mk_tick preserve_anf t orig_expr = mkTick' orig_expr where -- Some ticks (cost-centres) can be split in two, with the -- non-counting part having laxer placement properties. @@ -343,7 +355,7 @@ mkTick t orig_expr = mkTick' orig_expr -- Push SCCs into lambdas. -- See (PSCC2) in Note [Pushing SCCs inwards]. | can_split - -> Tick (mkNoScope t) $ Lam x $ mkTick (mkNoCount t) e + -> Tick (mkNoScope t) $ Lam x $ mk_tick preserve_anf (mkNoCount t) e App f arg -- All ticks float inwards through non-runtime arguments, as per @@ -353,7 +365,9 @@ mkTick t orig_expr = mkTick' orig_expr -- Push SCCs into saturated constructor applications. -- See (PSCC3) in Note [Pushing SCCs inwards]. - | isSaturatedConApp expr + | not preserve_anf -- this optimisation breaks ANF; + -- see Note [mkTick breaks ANF] in GHC.CoreToStg.Prep + , isSaturatedConApp expr , tickishPlace t == PlaceCostCentre || can_split -> if tickishPlace t == PlaceCostCentre then tickHNFArgs t expr ===================================== compiler/GHC/CoreToStg/Prep.hs ===================================== @@ -801,7 +801,9 @@ cpeBodyF env (Tick tickish expr) ; return (FloatTick tickish `consFloat` floats, body) } | otherwise = do { body <- cpeBody env expr - ; return (emptyFloats, mkTick tickish' body) } + ; return (emptyFloats, mkTickCpe tickish' body) } + -- Use mkTickCpe and not mkTick, as the latter may break ANF (#27182). + -- See (TickANF2) in Note [mkTick breaks ANF]. where tickish' | Breakpoint ext bid fvs <- tickish -- See also 'substTickish' @@ -905,6 +907,28 @@ cpeBodyF env (Case scrut bndr ty alts) ; rhs' <- cpeBody env2 rhs ; return (Alt con bs' rhs') } +{- Note [mkTick breaks ANF] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +mkTick does not preserve the ANF property as required by Core Prep (see +Note [CorePrep invariants]), as seen in #27182. Given: + + mkTick scc<foo> (\ (eta :: Char -> Bool) -> BindP (p :: Int) eta) + +mkTick will push the SCC into the constructor application, resulting in: + + \ (eta :: Char -> Bool) -> BindP (p :: Int) (scc<oneM> eta) + +To avoid this problem (at least until 'mkTick' is more thoroughly reworked to +avoid this infelicity, see #27141), we define a variant of 'mkTick', called +'mkTickCpe', which does not push ticks into constructor applications (this is +the only optimisation done by 'mkTick' that can break ANF). + +We prefer using a small variant of 'mkTick' rather than using the 'Tick' +constructor, as the latter can slightly degrade profiling reports by failing to +combine ticks (can result in spurious cost centres with 0 entries appearing in +profiling reports). +-} + -- --------------------------------------------------------------------------- -- CpeBody: produces a result satisfying CpeBody -- --------------------------------------------------------------------------- @@ -1207,7 +1231,7 @@ cpeApp top_env expr rebuild_app' env (a : as) fun' floats ss rt_ticks req_depth = case a of -- See Note [Ticks and mandatory eta expansion] _ | not (null rt_ticks), req_depth <= 0 - -> let tick_fun = foldr mkTick fun' rt_ticks + -> let tick_fun = foldr mkTickCpe fun' rt_ticks in rebuild_app' env (a : as) tick_fun floats ss rt_ticks req_depth AIApp (Type arg_ty) @@ -2307,7 +2331,7 @@ wrapBinds floats body mk_bind (UnsafeEqualityCase scrut b con bs) body = mkSingleAltCase scrut b con bs body mk_bind (FloatTick tickish) body - = mkTick tickish body + = mkTickCpe tickish body -- | Put floats at top-level deFloatTop :: Floats -> [CoreBind] @@ -2735,7 +2759,7 @@ newVar env ty wrapTicks :: Floats -> CoreExpr -> (Floats, CoreExpr) wrapTicks floats expr | (floats1, ticks1) <- fold_fun go floats - = (floats1, foldrOL mkTick expr ticks1) + = (floats1, foldrOL mkTickCpe expr ticks1) where fold_fun f floats = let (binds, ticks) = foldlOL f (nilOL,nilOL) (fs_binds floats) in (floats { fs_binds = binds }, ticks) @@ -2755,8 +2779,8 @@ wrapTicks floats expr wrap t (Float bind bound info) = Float (wrapBind t bind) bound info wrap _ f = pprPanic "Unexpected FloatingBind" (ppr f) - wrapBind t (NonRec binder rhs) = NonRec binder (mkTick t rhs) - wrapBind t (Rec pairs) = Rec (mapSnd (mkTick t) pairs) + wrapBind t (NonRec binder rhs) = NonRec binder (mkTickCpe t rhs) + wrapBind t (Rec pairs) = Rec (mapSnd (mkTickCpe t) pairs) ------------------------------------------------------------------------------ -- Numeric literals ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -289,23 +289,25 @@ bindistRules = do copyFile ("hadrian" -/- "cfg" -/- "default.target.in") (bindistFilesDir -/- "default.target.in") copyFile ("hadrian" -/- "cfg" -/- "default.host.target.in") (bindistFilesDir -/- "default.host.target.in") - -- todo: do we need these wrappers on windows - forM_ bin_targets $ \(pkg, _) -> do - needed_wrappers <- pkgToWrappers pkg - forM_ needed_wrappers $ \wrapper_name -> do - let suffix = if useGhcPrefix pkg - then "ghc-" ++ version - else version - wrapper_content <- wrapper wrapper_name - let unversioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- wrapper_name - versioned_wrapper = wrapper_name ++ "-" ++ suffix - versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper - -- Write the wrapper to the versioned path - writeFile' versioned_wrapper_path wrapper_content - -- Create a symlink from the non-versioned to the versioned. - liftIO $ do - IO.removeFile unversioned_wrapper_path <|> return () - IO.createFileLink versioned_wrapper unversioned_wrapper_path + -- These wrapper scripts are only necessary in the configure/install + -- workflow which is not supported on windows. + unless windowsHost $ do + forM_ bin_targets $ \(pkg, _) -> do + needed_wrappers <- pkgToWrappers pkg + forM_ needed_wrappers $ \wrapper_name -> do + let suffix = if useGhcPrefix pkg + then "ghc-" ++ version + else version + wrapper_content <- wrapper wrapper_name + let unversioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- wrapper_name + versioned_wrapper = wrapper_name ++ "-" ++ suffix + versioned_wrapper_path = bindistFilesDir -/- "wrappers" -/- versioned_wrapper + -- Write the wrapper to the versioned path + writeFile' versioned_wrapper_path wrapper_content + -- Create a symlink from the non-versioned to the versioned. + liftIO $ do + IO.removeFile unversioned_wrapper_path <|> return () + IO.createFileLink versioned_wrapper unversioned_wrapper_path let buildBinDist compressor = do win_target <- isWinTarget ===================================== testsuite/tests/profiling/should_compile/T27182.hs ===================================== @@ -0,0 +1,6 @@ +module T27182 ( oneM ) where + +data Parser = BindP Int ( Char -> Bool ) + +oneM :: Int -> ( Char -> Bool ) -> Parser +oneM p = BindP p ===================================== testsuite/tests/profiling/should_compile/all.T ===================================== @@ -22,3 +22,4 @@ test('T19894', [test_opts, extra_files(['T19894'])], multimod_compile, ['Main', test('T20938', [test_opts], compile, ['-O -prof']) test('T26056', [test_opts], compile, ['-O -prof']) test('T27121', [test_opts, extra_files(['T27121_aux.hs'])], multimod_compile, ['T27121', '-v0 -O -prof -fprof-auto']) +test('T27182', [test_opts], compile, ['-O -prof -fprof-late']) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4f8b0e0d3471d1f592ce66007c7b2fa... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/4f8b0e0d3471d1f592ce66007c7b2fa... You're receiving this email because of your account on gitlab.haskell.org.