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: ===================================== compiler/GHC/CoreToStg.hs ===================================== @@ -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) View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57e474c2938309241e5f26108cffe111... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/57e474c2938309241e5f26108cffe111... You're receiving this email because of your account on gitlab.haskell.org.