GitLab

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

 +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

 +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'])