Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC Commits: d03142f5 by Simon Peyton Jones at 2025-07-25T17:46:56+01:00 More wibbles exp around mkPolyAbsLams - - - - - 6 changed files: - compiler/GHC/Core/Opt/Exitify.hs - compiler/GHC/Core/Opt/Simplify/Env.hs - compiler/GHC/Core/Opt/SpecConstr.hs - compiler/GHC/Core/Utils.hs - compiler/GHC/Types/Basic.hs - compiler/GHC/Types/Id.hs Changes: ===================================== compiler/GHC/Core/Opt/Exitify.hs ===================================== @@ -224,16 +224,11 @@ exitifyRec in_scope pairs -- We have something to float out! | otherwise - = do { -- Assemble the RHS of the exit join point - -- Reminder: see GHC.Core.Utils - -- Note [Type-lets and abstracting over free variables] - let rhs = mkCoreAbsLams abs_vars e - avoid = in_scope `extendInScopeSetList` captured - join_arity = count (isNothing . tyVarUnfolding_maybe) abs_vars - -- Remember this binding under a suitable name - ; v <- addExit avoid join_arity rhs - -- And jump to it from here - ; return $ mkAbsVarApps (Var v) abs_vars } + = do { let avoid = in_scope `extendInScopeSetList` captured + -- Create the new join-point binding, recording it in the monad + ; j <- addExitBinding avoid abs_vars e + -- Return a call of that join point + ; return $ mkAbsVarApps (Var j) abs_vars } where -- Used to detect exit expressions that are already proper exit jumps @@ -263,24 +258,27 @@ exitifyRec in_scope pairs captures_join_points = any isJoinId abs_vars -addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId -addExit in_scope join_arity rhs +addExitBinding :: InScopeSet -> AbsVars -> CoreExpr -> ExitifyM JoinId +addExitBinding avoid1 abs_vars join_body = do { fs <- S.get - ; let ty = exprType rhs - avoid = in_scope `extendInScopeSetList` (map fst fs) - `extendInScopeSet` exit_id1 -- just cosmetics - -- avoid: pick a new unique, that is disjoint from - -- * the free variables of the whole joinrec - -- * any bound variables (captured) - -- * any exit join points created so far (in `fs`) - - exit_id1 = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy ty - exit_id2 = uniqAway avoid exit_id1 - - bind_pr@(exit_id3,_) = mkNewJoinPointBinding exit_id2 join_arity rhs - -- NB: mkNewJoinPointBinding does eta-expansion if needed, - -- to make sure that the join-point binding has the - -- right number of lambdas all lined up at the top + ; let join_rhs = mkCoreAbsLams abs_vars join_body + -- mkCoreAbsLams: see GHC.Core.Utils + -- Note [Type-lets and abstracting over free variables] + join_arity = count (isNothing . tyVarUnfolding_maybe) abs_vars + + avoid2 = avoid1 `extendInScopeSetList` (map fst fs) + `extendInScopeSet` exit_id1 -- just cosmetics + -- avoid2: pick a new unique, that is disjoint from + -- * avoid1: the free variables of the whole joinrec + -- plus any bound variables (captured) + -- * adding exit join points created so far (in `fs`) + + join_ty = exprType join_rhs + exit_id1 = mkSysLocal (fsLit "exit") initExitJoinUnique ManyTy join_ty + exit_id2 = uniqAway avoid2 exit_id1 + + bind_pr@(exit_id3,_) = mkNewJoinPointBinding exit_id2 join_arity join_rhs + -- NB: mkNewJoinPointBinding adds the JoinId tag ; S.put (bind_pr : fs) ; return exit_id3 } ===================================== compiler/GHC/Core/Opt/Simplify/Env.hs ===================================== @@ -1095,7 +1095,8 @@ simplBinder !env bndr | otherwise = simplIdBndr env bndr --------------- -simplTyVarBndr :: SimplEnv -> InTyVar -> SimplM (SimplEnv, OutTyVar) +simplTyVarBndr :: HasDebugCallStack + => SimplEnv -> InTyVar -> SimplM (SimplEnv, OutTyVar) simplTyVarBndr env tv = do { let (env', tv1) = substTyVarBndr env tv ; seqTyVar tv1 `seq` return (env', tv1) } @@ -1387,7 +1388,7 @@ substTy env ty = Type.substTy (getTCvSubst env) ty substTyVar :: SimplEnv -> TyVar -> Type substTyVar env tv = Type.substTyVar (getTCvSubst env) tv -substTyVarBndr :: SimplEnv -> TyVar -> (SimplEnv, TyVar) +substTyVarBndr :: HasDebugCallStack => SimplEnv -> TyVar -> (SimplEnv, TyVar) substTyVarBndr env tv = case Type.substTyVarBndr (getTCvSubst env) tv of (Subst in_scope' _ tv_env' cv_env', tv') ===================================== compiler/GHC/Core/Opt/SpecConstr.hs ===================================== @@ -1312,6 +1312,7 @@ data ArgOcc = NoOcc -- Doesn't occur at all; or a type argument | ScrutOcc -- See Note [ScrutOcc] (DataConEnv [ArgOcc]) -- [ArgOcc]: how the sub-components are used + -- /including/ (existential) tyvar binders deadArgOcc :: ArgOcc -> Bool deadArgOcc (ScrutOcc {}) = False @@ -2717,24 +2718,27 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str -- Ignore `_wf` here; see Note [ConVal work-free-ness] (2) , not (ignoreDataCon env dc) -- See Note [NoSpecConstr] , Just arg_occs <- mb_scrut dc - = do { let (ty_args, rest_args) = splitAtList (dataConUnivTyVars dc) args - con_str, matched_str :: [StrictnessMark] - -- con_str corresponds 1-1 with the /value/ arguments - -- matched_str corresponds 1-1 with /all/ arguments + = do { let -- `con_str` corresponds 1-1 with the /value/ arguments + -- `all_str` corresponds 1-1 with /all/ arguments + con_str, all_str :: [StrictnessMark] con_str = dataConRepStrictness dc - matched_str = match_vals con_str rest_args - -- ; pprTraceM "bangs" (ppr (length rest_args == length con_str) $$ - -- ppr dc $$ - -- ppr con_str $$ - -- ppr rest_args $$ - -- ppr (map isTypeArg rest_args)) - ; prs <- zipWith3M (argToPat env in_scope val_env) rest_args arg_occs matched_str - ; let args' = map sndOf3 prs :: [CoreArg] - ; assertPpr (length con_str == length (filter isRuntimeArg rest_args)) - ( ppr con_str $$ ppr rest_args $$ - ppr (length con_str) $$ ppr (length rest_args) - ) $ return () - ; return (True, mkConApp dc (ty_args ++ args'), concat (map thdOf3 prs)) } + all_str = match_vals con_str args + + -- `arg_occs` corresponnds 1-1 with the binders of a data con + -- pattern, which omits the universal tyvars. We extend with + -- `UnkOcc` for the universals to get `all_arg_occs` + all_arg_occs :: [ArgOcc] + all_arg_occs = map (const UnkOcc) (dataConUnivTyVars dc) ++ arg_occs + + ; triples :: [(Bool, CoreArg, [Id])] <- zipWith3M (argToPat env in_scope val_env) + args all_arg_occs all_str + + ; let args' = map sndOf3 triples :: [CoreArg] + cbv_ids = concat (map thdOf3 triples) :: [Id] + + ; assertPpr (length con_str == valArgCount args) + (ppr dc $$ ppr args $$ ppr arg_occs) $ + return (True, mkConApp dc args', cbv_ids) } where mb_scrut dc = case arg_occ of ScrutOcc bs | Just occs <- lookupUFM bs dc @@ -2743,6 +2747,8 @@ argToPat1 env in_scope val_env arg arg_occ _arg_str -> Just (repeat UnkOcc) | otherwise -> Nothing + + match_vals :: [StrictnessMark] -> [CoreExpr] -> [StrictnessMark] match_vals bangs (arg:args) | isTypeArg arg = NotMarkedStrict : match_vals bangs args @@ -2828,6 +2834,8 @@ mkTyPat :: InScopeSet -> Type -> Type -- The tyvars `a` and `b` might have been in scope at the call site, -- but not at the definition site. We want a call pattern -- f @a @a (K @a) a +-- Here we are silently relying on non-shadowing; it's no good if a +-- /different/ `b` is in scope at the definition site! mkTyPat in_scope ty = expandSomeTyVarUnfoldings not_in_scope ty where ===================================== compiler/GHC/Core/Utils.hs ===================================== @@ -3115,26 +3115,56 @@ type AbsVar = Var type AbsVars = [AbsVar] type TaggedAbsVars t = [TaggedBndr t] -mkPolyAbsLams :: (b -> AbsVar, Var -> b -> b) - -> [b] -> Expr b -> Expr b +mkPolyAbsLams :: forall b. (b -> AbsVar, Var -> b -> b) + -> [b] -> Expr b -> Expr b -- `mkPolyAbsLams` is polymorphic in (get,set) so that we can -- use it for both CoreExpr and LevelledExpr {-# INLINE mkPolyAbsLams #-} -mkPolyAbsLams (get,set) bndrs body - = go bndrs +mkPolyAbsLams (getter,setter) bndrs body + = go emptyVarSet [] bndrs where - go [] = body - go (bndr:bndrs) + go :: TyVarSet -- Earlier TyVar bndrs that have TyVarUnfoldings + -> [Bind b] -- Accumulated impedence-matching bindings (reversed) + -> [b] -- Binders, bs + -> Expr b -- The resulting lambda + go _ binds [] = mkLets (reverse binds) body + + go unf_tvs binds (bndr:bndrs) + | Just ty <- tyVarUnfolding_maybe var - = Let (NonRec bndr (Type ty)) $ - go bndrs + = go (unf_tvs `extendVarSet` var) (NonRec bndr (Type ty) : binds) bndrs + + | isTyVar var, change_ty + , let binds' | isDeadBinder var = binds + | otherwise = NonRec bndr (Type (mkTyVarTy var1)) : binds + = Lam (setter var1 bndr) (go unf_tvs binds' bndrs) + + | isId var, change_ty || change_unf + , let binds' | isDeadBinder var = binds + | otherwise = NonRec bndr (Var id2) : binds + = Lam (setter id2 bndr) (go unf_tvs binds' bndrs) + | otherwise - = Lam bndr' (go bndrs) + = Lam bndr (go unf_tvs binds bndrs) where - var = get bndr - -- zap: We are going to lambda-abstract, so nuke any IdInfo - bndr' | isId var = set (setIdInfo var vanillaIdInfo) bndr - | otherwise = bndr + var = getter bndr + var_ty = varType var + + (change_ty, var1) = update_type var + (change_unf, id2) = zap_unfolding var1 -- Only used for Ids + + -- zap_unfolding: We are going to lambda-abstract, so nuke any IdInfo + zap_unfolding var | isId var, hasSomeUnfolding (idUnfolding var) + = (True, setIdInfo var vanillaIdInfo) + | otherwise + = (False, var) + + -- update_type: expand unfoldings of any tyvars in `unf_tvs` + update_type var | not (isEmptyVarSet unf_tvs) + , anyFreeVarsOfType (`elemVarSet` unf_tvs) var_ty + = (True, setVarType var (expandTyVarUnfoldings unf_tvs var_ty)) + | otherwise + = (False, var) mkCoreAbsLams :: AbsVars -> CoreExpr -> CoreExpr -- Specialise for CoreExpr ===================================== compiler/GHC/Types/Basic.hs ===================================== @@ -73,7 +73,7 @@ module GHC.Types.Basic ( isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isManyOccs, isNoOccInfo, strongLoopBreaker, weakLoopBreaker, - TyCoOccInfo(..), plusTyCoOccInfo, isOneTyCoOcc, + TyCoOccInfo(..), plusTyCoOccInfo, isOneTyCoOcc, isDeadTyCoOcc, InsideLam(..), BranchCount, oneBranch, @@ -1395,6 +1395,10 @@ isOneTyCoOcc :: TyCoOccInfo -> Bool isOneTyCoOcc TyCoOne = True isOneTyCoOcc _ = False +isDeadTyCoOcc :: TyCoOccInfo -> Bool +isDeadTyCoOcc TyCoDead = True +isDeadTyCoOcc _ = False + plusTyCoOccInfo :: TyCoOccInfo -> TyCoOccInfo -> TyCoOccInfo plusTyCoOccInfo TyCoDead occ = occ plusTyCoOccInfo occ TyCoDead = occ ===================================== compiler/GHC/Types/Id.hs ===================================== @@ -133,12 +133,7 @@ import GHC.Types.Id.Info import GHC.Types.Basic -- Imported and re-exported -import GHC.Types.Var( Id, CoVar, JoinId, - InId, InVar, - OutId, OutVar, - idInfo, idDetails, setIdDetails, globaliseId, idMult, - isId, isLocalId, isGlobalId, isExportedId, - setIdMult, updateIdTypeAndMult, updateIdTypeButNotMult, updateIdTypeAndMultM) +import GHC.Types.Var import qualified GHC.Types.Var as Var import GHC.Core ( CoreExpr, CoreRule, Unfolding(..), IdUnfoldingFun @@ -233,12 +228,6 @@ setIdUnique = Var.setVarUnique setIdType :: Id -> Type -> Id setIdType id ty = seqType ty `seq` Var.setVarType id ty -setIdExported :: Id -> Id -setIdExported = Var.setIdExported - -setIdNotExported :: Id -> Id -setIdNotExported = Var.setIdNotExported - localiseId :: Id -> Id -- Make an Id with the same unique and type as the -- incoming Id, but with an *Internal* Name and *LocalId* flavour @@ -250,9 +239,6 @@ localiseId id where name = idName id -lazySetIdInfo :: Id -> IdInfo -> Id -lazySetIdInfo = Var.lazySetIdInfo - setIdInfo :: Id -> IdInfo -> Id setIdInfo id info = info `seq` (lazySetIdInfo id info) -- Try to avoid space leaks by seq'ing @@ -624,9 +610,12 @@ isImplicitId id idIsFrom :: Module -> Id -> Bool idIsFrom mod id = nameIsLocalOrFrom mod (idName id) -isDeadBinder :: Id -> Bool -isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) - | otherwise = False -- TyVars count as not dead +isDeadBinder :: Var -> Bool +-- This predicate works on any Var, not just Ids +-- So this module isn't the ideal place for it; but moving it +-- elsewhere just gives silly module loops +isDeadBinder bndr | isId bndr = isDeadOcc (idOccInfo bndr) + | otherwise = isDeadTyCoOcc (tyVarOccInfo bndr) {- ************************************************************************ View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d03142f5aa758ee1298296d3e5c93841... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d03142f5aa758ee1298296d3e5c93841... You're receiving this email because of your account on gitlab.haskell.org.