GitLab

Simon Peyton Jones pushed to branch wip/T26831 at Glasgow Haskell Compiler / GHC

Commits:

57e474c2
by Simon Peyton Jones at 2026-03-13T13:06:04+00:00
```
Wibbles to eta expansion
```

2 changed files:

compiler/GHC/CoreToStg.hs
compiler/GHC/Driver/Main.hs

Changes:

@@ -39,6 +39,8 @@ import GHC.Types.Basic  ( Arity, TypeOrConstraint(..) )
  import GHC.Types.Literal
  import GHC.Types.ForeignCall
  import GHC.Types.IPE
 +import GHC.Types.Unique.Supply
 +import GHC.Types.Unique
  import GHC.Unit.Module
  import GHC.Platform        ( Platform )
@@ -49,6 +51,7 @@ import GHC.Utils.Outputable
  import GHC.Utils.Monad
  import GHC.Utils.Misc (HasDebugCallStack)
  import GHC.Utils.Panic
 +import GHC.Data.FastString
  import Control.Monad (ap)
@@ -239,107 +242,98 @@ import Control.Monad (ap)
  -- --------------------------------------------------------------
 -coreToStg :: CoreToStgOpts -> Module -> ModLocation -> CoreProgram
 -          -> ([StgTopBinding], InfoTableProvMap, CollectedCCs)
 -coreToStg opts@CoreToStgOpts
 -  { coreToStg_ways = ways
 -  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
 -  , coreToStg_InfoTableMap = opt_InfoTableMap
 -  , coreToStg_stgDebugOpts = stgDebugOpts
 -  } this_mod ml pgm
 -  = (pgm'', denv, final_ccs)
 +coreToStg :: CoreToStgOpts -> Module -> ModLocation
 +          -> CoreProgram
 +          -> IO ([StgTopBinding], InfoTableProvMap, CollectedCCs)
 +coreToStg opts this_mod ml pgm
 +  = do { us <- mkSplitUniqSupply StgTag
 +       ; let (_, (local_ccs, local_cc_stacks), pgm')
 +                = initCts opts us $
 +                  coreTopBindsToStg opts this_mod emptyCollectedCCs pgm
++
 +             -- See Note [Mapping Info Tables to Source Positions]
 +             (!pgm'', !denv)
 +               | opt_InfoTableMap
 +               = collectDebugInformation stgDebugOpts ml pgm'
 +               | otherwise = (pgm', emptyInfoTableProvMap)
++
 +             final_ccs
 +               | prof && opt_AutoSccsOnIndividualCafs
 +               = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
 +               | prof
 +               = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
 +               | otherwise
 +               = emptyCollectedCCs
++
 +      ; return (pgm'', denv, final_ccs) }
    where
 -    (_, (local_ccs, local_cc_stacks), pgm')
 -      = coreTopBindsToStg opts this_mod emptyVarEnv emptyCollectedCCs pgm
+-
 -    -- See Note [Mapping Info Tables to Source Positions]
 -    (!pgm'', !denv)
 -      | opt_InfoTableMap
 -      = collectDebugInformation stgDebugOpts ml pgm'
 -      | otherwise = (pgm', emptyInfoTableProvMap)
 +    CoreToStgOpts { coreToStg_ways = ways
 +                  , coreToStg_AutoSccsOnIndividualCafs = opt_AutoSccsOnIndividualCafs
 +                  , coreToStg_InfoTableMap = opt_InfoTableMap
 +                  , coreToStg_stgDebugOpts = stgDebugOpts }
 +       = opts
      prof = hasWay ways WayProf
+-
 -    final_ccs
 -      | prof && opt_AutoSccsOnIndividualCafs
 -      = (local_ccs,local_cc_stacks)  -- don't need "all CAFs" CC
 -      | prof
 -      = (all_cafs_cc:local_ccs, all_cafs_ccs:local_cc_stacks)
 -      | otherwise
 -      = emptyCollectedCCs
+-
      (all_cafs_cc, all_cafs_ccs) = getAllCAFsCC this_mod
  coreTopBindsToStg
      :: CoreToStgOpts
      -> Module
 -    -> IdEnv HowBound           -- environment for the bindings
      -> CollectedCCs
      -> CoreProgram
 -    -> (IdEnv HowBound, CollectedCCs, [StgTopBinding])
 +    -> CtsM (IdEnv HowBound, CollectedCCs, [StgTopBinding])
++
 +coreTopBindsToStg _ _ ccs []
 +  = do { env <- getCtsEnv
 +       ; return (env, ccs, []) }
 -coreTopBindsToStg _      _        env ccs []
 -  = (env, ccs, [])
 -coreTopBindsToStg opts this_mod env ccs (b:bs)
 +coreTopBindsToStg opts this_mod ccs (b:bs)
    | NonRec _ rhs <- b, isTyCoArg rhs
 -  = coreTopBindsToStg opts this_mod env1 ccs1 bs
 +  = coreTopBindsToStg opts this_mod ccs bs
    | otherwise
 -  = (env2, ccs2, b':bs')
 -  where
 -    (env1, ccs1, b' ) = coreTopBindToStg opts this_mod env ccs b
 -    (env2, ccs2, bs') = coreTopBindsToStg opts this_mod env1 ccs1 bs
 +  = do { (env1, ccs1, b' ) <- coreTopBindToStg opts this_mod ccs b
 +       ; (env2, ccs2, bs') <- setCtsEnv env1 $
 +                              coreTopBindsToStg opts this_mod ccs1 bs
 +      ; return (env2, ccs2, b':bs') }
  coreTopBindToStg
          :: CoreToStgOpts
          -> Module
 -        -> IdEnv HowBound
          -> CollectedCCs
          -> CoreBind
 -        -> (IdEnv HowBound, CollectedCCs, StgTopBinding)
 +        -> CtsM (IdEnv HowBound, CollectedCCs, StgTopBinding)
 -coreTopBindToStg _ _ env ccs (NonRec id e)
 +coreTopBindToStg _ _ ccs (NonRec id e)
    | Just str <- exprIsTickedString_maybe e
    -- top-level string literal
    -- See Note [Core top-level string literals] in GHC.Core
 -  = let
 -        env' = extendVarEnv env id how_bound
 -        how_bound = LetBound TopLet 0
 -    in (env', ccs, StgTopStringLit id str)
+-
 -coreTopBindToStg opts@CoreToStgOpts
 -  { coreToStg_platform = platform
 -  } this_mod env ccs (NonRec id rhs)
 -  = let
 -        env'      = extendVarEnv env id how_bound
 -        how_bound = LetBound TopLet $! manifestArity rhs
+-
 -        (ccs', (id', stg_rhs)) =
 -            initCts platform env $
 -              coreToTopStgRhs opts this_mod ccs (id,rhs)
+-
 -        bind = StgTopLifted $ StgNonRec id' stg_rhs
 -    in
 -      -- NB: previously the assertion printed 'rhs' and 'bind'
 -      --     as well as 'id', but that led to a black hole
 -      --     where printing the assertion error tripped the
 -      --     assertion again!
 -    (env', ccs', bind)
+-
 -coreTopBindToStg opts@CoreToStgOpts
 -  { coreToStg_platform = platform
 -  } this_mod env ccs (Rec pairs)
 +  = do { env <- getCtsEnv
 +       ; let env' = extendVarEnv env id how_bound
 +             how_bound = LetBound TopLet 0
 +       ; return (env', ccs, StgTopStringLit id str) }
++
 +coreTopBindToStg opts this_mod ccs (NonRec id rhs)
 +  = do { (ccs', (id', stg_rhs)) <- coreToTopStgRhs opts this_mod ccs (id,rhs)
++
 +       ; env <- getCtsEnv
 +       ; let env'      = extendVarEnv env id how_bound
 +             how_bound = LetBound TopLet $! manifestArity rhs
 +             bind      = StgTopLifted $ StgNonRec id' stg_rhs
 +       ; return (env', ccs', bind) }
++
 +coreTopBindToStg opts this_mod ccs (Rec pairs)
    = assert (not (null pairs)) $
 -    let
 -        extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
 -                     | (b, rhs) <- pairs ]
 -        env' = extendVarEnvList env extra_env'
+-
 -        -- generate StgTopBindings and CAF cost centres created for CAFs
 -        (ccs', stg_rhss)
 -          = initCts platform env' $ mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs
 -        bind = StgTopLifted $ StgRec stg_rhss
 -    in
 -    (env', ccs', bind)
 +    do { env <- getCtsEnv
 +       ; let extra_env' = [ (b, LetBound TopLet $! manifestArity rhs)
 +                          | (b, rhs) <- pairs ]
 +             env' = extendVarEnvList env extra_env'
++
 +       -- Generate StgTopBindings and CAF cost centres created for CAFs
 +       ; (ccs', stg_rhss) <- setCtsEnv env' $
 +                             mapAccumLM (coreToTopStgRhs opts this_mod) ccs pairs
 +       ; let bind = StgTopLifted $ StgRec stg_rhss
++
 +       ; return (env', ccs', bind) }
  coreToTopStgRhs
          :: CoreToStgOpts
@@ -426,16 +420,17 @@ coreToStgExpr expr@(Lam {})
    | otherwise
    = do { body' <- extendVarEnvCts [ (a, LambdaBound) | a <- val_bndrs ] $
                    coreToStgExpr body
 +       ; uniq <- getCtsUnique
         ; let body_ty = exprType body
 -             fun_ty  = mkLamTypes bndrs body_ty
 +             fun_ty  = mkLamTypes val_bndrs body_ty
 +                       -- This type is a bit ill-formed but it doesn't matter
               rhs = StgRhsClosure noExtFieldSilent currentCCS
                                   ReEntrant val_bndrs body' body_ty
 -             tmp_fun = mkTemplateLocal 0 fun_ty
 +             tmp_fun = mkSysLocal (fsLit "pap") uniq ManyTy fun_ty
         ; return (StgLet noExtFieldSilent (StgNonRec tmp_fun rhs) $
                   StgApp tmp_fun []) }
    where
 -    (bndrs, body) = myCollectBinders expr
 -    val_bndrs = filterStgBinders bndrs
 +    (val_bndrs, body) = myCollectBinders NotJoinPoint expr
  coreToStgExpr (Tick tick expr)
    = do
@@ -715,12 +710,11 @@ coreToStgRhs (bndr, rhs) = do
  -- coreToStgExpr that can handle value lambdas.
  coreToMkStgRhs :: HasDebugCallStack => Id -> CoreExpr -> CtsM MkStgRhs
  coreToMkStgRhs bndr expr = do
 -  let (args, body) = myCollectBinders expr
 -  let args'        = filterStgBinders args
 -  extendVarEnvCts [ (a, LambdaBound) | a <- args' ] $ do
 +  let (bndrs, body) = myCollectBinders (idJoinPointHood bndr) expr
 +  extendVarEnvCts [ (a, LambdaBound) | a <- bndrs ] $ do
      body' <- coreToStgExpr body
      let mk_rhs = MkStgRhs
 -          { rhs_args = args'
 +          { rhs_args = bndrs
            , rhs_expr = body'
            , rhs_type = exprType body
            , rhs_is_join = isJoinId bndr
@@ -738,7 +732,7 @@ coreToMkStgRhs bndr expr = do
  newtype CtsM a = CtsM
      { unCtsM :: Platform -- Needed for checking for bad coercions in coreToStgArgs
               -> IdEnv HowBound
 -             -> a
 +             -> UniqSM a
+     }
      deriving (Functor)
@@ -774,20 +768,22 @@ data LetInfo
  -- The std monad functions:
 -initCts :: Platform -> IdEnv HowBound -> CtsM a -> a
 -initCts platform env m = unCtsM m platform env
+-
 +initCts :: CoreToStgOpts -> UniqSupply -> CtsM a -> a
 +initCts opts us cts_m
 +  = initUs_ us $
 +    unCtsM cts_m (coreToStg_platform opts) emptyVarEnv
  {-# INLINE thenCts #-}
  {-# INLINE returnCts #-}
  returnCts :: a -> CtsM a
 -returnCts e = CtsM $ \_ _ -> e
 +returnCts e = CtsM $ \_ _ -> return e
  thenCts :: CtsM a -> (a -> CtsM b) -> CtsM b
 -thenCts m k = CtsM $ \platform env
 -  -> unCtsM (k (unCtsM m platform env)) platform env
 +thenCts m k = CtsM $ \platform env ->
 +              do { v <- unCtsM m platform env
 +                 ; unCtsM (k v) platform env }
  instance Applicative CtsM where
      pure = returnCts
@@ -797,17 +793,26 @@ instance Monad CtsM where
      (>>=)  = thenCts
  getPlatform :: CtsM Platform
 -getPlatform = CtsM const
 +getPlatform = CtsM $ \platform _ -> return platform
  -- Functions specific to this monad:
 +setCtsEnv :: IdEnv HowBound -> CtsM a -> CtsM a
 +setCtsEnv env thing = CtsM $ \platform _ -> unCtsM thing platform env
++
 +getCtsEnv :: CtsM (IdEnv HowBound)
 +getCtsEnv = CtsM $ \_ env -> return env
++
 +getCtsUnique :: CtsM Unique
 +getCtsUnique = CtsM $ \_ _ -> getUniqueM
++
  extendVarEnvCts :: [(Id, HowBound)] -> CtsM a -> CtsM a
  extendVarEnvCts ids_w_howbound expr
     =    CtsM $   \platform env
     -> unCtsM expr platform (extendVarEnvList env ids_w_howbound)
  lookupVarCts :: Id -> CtsM HowBound
 -lookupVarCts v = CtsM $ \_ env -> lookupBinding env v
 +lookupVarCts v = CtsM $ \_ env -> return (lookupBinding env v)
  lookupBinding :: IdEnv HowBound -> Id -> HowBound
  lookupBinding env v = case lookupVarEnv env v of
@@ -819,13 +824,26 @@ lookupBinding env v = case lookupVarEnv env v of
  filterStgBinders :: [Var] -> [Var]
  filterStgBinders bndrs = filter isId bndrs
 -myCollectBinders :: Expr Var -> ([Var], Expr Var)
 -myCollectBinders expr
 +myCollectBinders :: JoinPointHood -> Expr Var -> ([Var], Expr Var)
 +-- Collect the binders from a lambda:
 +--   * Dropping type lambdas
 +--   * Stopping at join-point arity
 +myCollectBinders NotJoinPoint expr
    = go [] expr
    where
 -    go bs (Lam b e)          = go (b:bs) e
 -    go bs (Cast e _)         = go bs e
 -    go bs e                  = (reverse bs, e)
 +    go bs (Lam b e) | isRuntimeVar b = go (b:bs) e
 +                    | otherwise      = go bs     e
 +    go bs (Cast e _)                 = go bs e
 +    go bs e                          = (reverse bs, e)
++
 +myCollectBinders (JoinPoint n) expr
 +  = go n [] expr
 +  where
 +    go n bs e | n==0                   = (reverse bs, e)
 +    go n bs (Lam b e) | isRuntimeVar b = go (n-1) (b:bs) e
 +                      | otherwise      = go (n-1) bs     e
 +    go n bs (Cast e _)                 = go n bs e
 +    go _ bs e                          = (reverse bs, e)
  -- | If the argument expression is (potential chain of) 'App', return the head
  -- of the app chain, and collect ticks/args along the chain.

compiler/GHC/Driver/Main.hs

@@ -2447,8 +2447,8 @@ myCoreToStg :: Logger -> DynFlags -> [Var]
                    , CollectedCCs -- CAF cost centre info (declared and used)
                    , StgCgInfos )
  myCoreToStg logger dflags ic_inscope for_bytecode this_mod ml prepd_binds = do
 -    let (stg_binds, denv, cost_centre_info)
 -         = {-# SCC "Core2Stg" #-}
 +    (stg_binds, denv, cost_centre_info)
 +       <- {-# SCC "Core2Stg" #-}
             coreToStg (initCoreToStgOpts dflags) this_mod ml prepd_binds
      (stg_binds_with_fvs,stg_cg_info)