David Eichmann pushed to branch wip/davide/hadrian-aclocal_path 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" - - - - - a3b431f3 by David Eichmann at 2026-06-04T10:10:19+00:00 Hadrian: convert env variable ACLOCAL_PATH to unix paths. Convert ACLOCAL_PATH to a unix style path when invoking autoreconf. Autoreconf doesn't handle windows paths. See Note [Autoreconf unix paths from ACLOCAL_PATH]. Fixes #27311 - - - - - 9 changed files: - boot - + changelog.d/T27182.md - compiler/GHC/Builtin/primops.txt.pp - compiler/GHC/Core/Utils.hs - compiler/GHC/CoreToStg/Prep.hs - hadrian/src/Hadrian/Oracles/Path.hs - hadrian/src/Rules/BinaryDist.hs - + testsuite/tests/profiling/should_compile/T27182.hs - testsuite/tests/profiling/should_compile/all.T Changes: ===================================== boot ===================================== @@ -52,9 +52,8 @@ def autoreconf(): # Run autoreconf on everything that needs it. processes = {} if os.name == 'nt': - # Get the normalized ACLOCAL_PATH for Windows - # This is necessary since on Windows this will be a Windows - # path, which autoreconf doesn't know doesn't know how to handle. + # Convert ACLOCAL_PATH env variable to unix style paths on Windows + # See Note [Autoreconf unix paths from ACLOCAL_PATH] ac_local = os.getenv('ACLOCAL_PATH', '') ac_local_arg = re.sub(r';', r':', ac_local) ac_local_arg = re.sub(r'\\', r'/', ac_local_arg) ===================================== 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/Hadrian/Oracles/Path.hs ===================================== @@ -1,6 +1,7 @@ {-# LANGUAGE TypeFamilies #-} module Hadrian.Oracles.Path ( - lookupInPath, fixAbsolutePathOnWindows, pathOracle + lookupInPath, fixAbsolutePathOnWindows, fixUnixPathsOnWindows, + pathOracle ) where import Control.Monad @@ -33,6 +34,14 @@ fixAbsolutePathOnWindows path = else return path +-- | Fix a unix path list on Windows: +-- * "C:\\foo\\bar;C:\\msys2\\bin" => "/c/foo/bar:/c/msys2/bin" +fixUnixPathsOnWindows :: FilePath -> Action FilePath +fixUnixPathsOnWindows paths = + if isWindows + then askOracle $ UnixPathList paths + else return paths + newtype LookupInPath = LookupInPath String deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult LookupInPath = String @@ -41,6 +50,10 @@ newtype WindowsPath = WindowsPath FilePath deriving (Binary, Eq, Hashable, NFData, Show) type instance RuleResult WindowsPath = String +newtype UnixPathList = UnixPathList FilePath + deriving (Binary, Eq, Hashable, NFData, Show) +type instance RuleResult UnixPathList = String + -- | Oracles for looking up paths. These are slow and require caching. pathOracle :: Rules () pathOracle = do @@ -50,6 +63,12 @@ pathOracle = do putVerbose $ "| Windows path mapping: " ++ path ++ " => " ++ windowsPath return windowsPath + void $ addOracleCache $ \(UnixPathList paths) -> do + Stdout out <- quietly $ cmd ["cygpath", "-p", "-u", paths] + let unixPaths = unifyPath $ dropWhileEnd isSpace out + putVerbose $ "| Unix path mapping: " ++ paths ++ " => " ++ unixPaths + return unixPaths + void $ addOracleCache $ \(LookupInPath name) -> do path <- liftIO getSearchPath exes <- liftIO (findExecutablesInDirectories path name) ===================================== hadrian/src/Rules/BinaryDist.hs ===================================== @@ -3,18 +3,19 @@ module Rules.BinaryDist where import CommandLine import Context +import Data.Either +import qualified Data.Set as Set import Expression +import Hadrian.Oracles.Path (fixUnixPathsOnWindows) +import Oracles.Flavour import Oracles.Setting import Packages +import Rules.Generate (generateSettings) import Settings +import qualified System.Directory.Extra as IO import Settings.Program (programContext) import Target import Utilities -import qualified System.Directory.Extra as IO -import Data.Either -import qualified Data.Set as Set -import Oracles.Flavour -import Rules.Generate (generateSettings) {- Note [Binary distributions] @@ -343,7 +344,25 @@ bindistRules = do ghcRoot <- topDirectory copyFile (ghcRoot -/- "aclocal.m4") (ghcRoot -/- "distrib" -/- "aclocal.m4") copyDirectory (ghcRoot -/- "m4") (ghcRoot -/- "distrib") - buildWithCmdOptions [] $ + + -- Note [Autoreconf unix paths from ACLOCAL_PATH] + -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + -- On Windows, autoreconf fails when the ACLOCAL_PATH env variable contains Windows- + -- style paths. This happens because MSYS2 automatically converts env variables to + -- Windows-style paths. To fix this, we convert ACLOCAL_PATH back to Unix style. + -- This is done both in the boot Python script and here when building a bindist. + win_host <- isWinHost + env <- if not win_host + then pure [] + else do + aclocalPathMay <- getEnv "ACLOCAL_PATH" + case aclocalPathMay of + Nothing -> pure [] + Just aclocalPath -> do + unixAclocalPath <- fixUnixPathsOnWindows aclocalPath + pure [AddEnv "ACLOCAL_PATH" unixAclocalPath] + + buildWithCmdOptions env $ target (vanillaContext Stage1 ghc) (Autoreconf $ ghcRoot -/- "distrib") [] [] -- We clean after ourselves, moving the configure script we generated in -- our bindist dir ===================================== 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/53e0626b3dc3f4a79045fa1560990da... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/53e0626b3dc3f4a79045fa1560990da... You're receiving this email because of your account on gitlab.haskell.org.