[Git][ghc/ghc][wip/T20264] Wibbles
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Fri Oct 25 16:36:04 UTC 2024
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
d0f30cc2 by Simon Peyton Jones at 2024-10-25T17:35:48+01:00
Wibbles
- - - - -
2 changed files:
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Types/Id.hs
Changes:
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -208,7 +208,7 @@ in GHC.Core.Opt.WorkWrap.Utils. (Maybe there are other "clients" of this featur
returns a substituted type.
* When we encounter a binder (like x::a) we must apply the substitution
- to the type of the binding variable. lintBinders does this.
+ to the type of the binding variable. lintLocalBinders does this.
* Clearly we need to clone tyvar binders as we go.
@@ -554,7 +554,7 @@ Check a core binding, returning the list of variables bound.
lintRecBindings :: TopLevelFlag -> [(Id, CoreExpr)]
-> ([LintedId] -> LintM a) -> LintM (a, [UsageEnv])
lintRecBindings top_lvl pairs thing_inside
- = lintIdBndrs top_lvl bndrs $ \ bndrs' ->
+ = lintBinders top_lvl LetBind bndrs $ \ bndrs' ->
do { ues <- zipWithM lint_pair bndrs' rhss
; a <- thing_inside bndrs'
; return (a, ues) }
@@ -572,11 +572,16 @@ lintLetBody loc bndrs body
; mapM_ (lintJoinBndrType body_ty) bndrs
; return (body_ty, body_ue) }
-lintLetBind :: TopLevelFlag -> RecFlag -> LintedId
- -> CoreExpr -> LintedType -> LintM ()
+lintLetBind :: TopLevelFlag -> RecFlag -> Var
+ -> CoreExpr -> LintedType -> LintM ()
-- Binder's type, and the RHS, have already been linted
-- This function checks other invariants
lintLetBind top_lvl rec_flag binder rhs rhs_ty
+ | isTyVar binder
+ = pprTrace "lintLetBind: fill in" (ppr binder) $
+ return () -- Fill in!
+
+ | otherwise
= do { let binder_ty = idType binder
; ensureEqTys binder_ty rhs_ty (mkRhsMsg binder (text "RHS") rhs_ty)
@@ -668,10 +673,14 @@ lintRhs :: Id -> CoreExpr -> LintM (LintedType, UsageEnv)
-- NB: the Id can be Linted or not -- it's only used for
-- its OccInfo and join-pointer-hood
lintRhs bndr rhs
- | JoinPoint arity <- idJoinPointHood bndr
- = lintJoinLams arity (Just bndr) rhs
- | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
- = lintJoinLams arity Nothing rhs
+ | isTyVar bndr
+ = pprTrace "lintRhs:fill in" (ppr bndr) $
+ return (varType bndr, zeroUE) -- ToDo: fill in
+
+ | JoinPoint arity <- idJoinPointHood bndr
+ = lintJoinLams arity (Just bndr) rhs
+ | AlwaysTailCalled arity <- tailCallInfo (idOccInfo bndr)
+ = lintJoinLams arity Nothing rhs
-- Allow applications of the data constructor @StaticPtr@ at the top
-- but produce errors otherwise.
@@ -937,7 +946,7 @@ lintCoreExpr (Let (NonRec bndr rhs) body)
-- See Note [Multiplicity of let binders] in Var
-- Now lint the binder
- ; lintBinder LetBind bndr $ \bndr' ->
+ ; lintLocalBinder LetBind bndr $ \bndr' ->
do { lintLetBind NotTopLevel NonRecursive bndr' rhs rhs_ty
; addAliasUE bndr let_ue (lintLetBody (BodyOfLet bndr') [bndr'] body) } }
@@ -1090,7 +1099,7 @@ lintCoreFun expr nargs
lintLambda :: Var -> LintM (Type, UsageEnv) -> LintM (Type, UsageEnv)
lintLambda var lintBody =
addLoc (LambdaBodyOf var) $
- lintBinder LambdaBind var $ \ var' ->
+ lintLocalBinder LambdaBind var $ \ var' ->
do { (body_ty, ue) <- lintBody
; ue' <- checkLinearity ue var'
; return (mkLamType var' body_ty, ue') }
@@ -1664,7 +1673,7 @@ lintCaseExpr scrut var alt_ty alts =
; ensureEqTys var_ty scrut_ty (mkScrutMsg var var_ty scrut_ty subst)
-- See GHC.Core Note [Case expression invariants] item (7)
- ; lintBinder CaseBind var $ \_ ->
+ ; lintLocalBinder CaseBind var $ \_ ->
do { -- Check the alternatives
; alt_ues <- mapM (lintCoreAlt var scrut_ty scrut_mult alt_ty) alts
; let case_ue = (scaleUE scrut_mult scrut_ue) `addUE` supUEs alt_ues
@@ -1764,7 +1773,7 @@ lintCoreAlt case_bndr scrut_ty _scrut_mult alt_ty alt@(Alt (DataAlt con) args rh
; multiplicities = map binderMult $ fst $ splitPiTys con_payload_ty }
-- And now bring the new binders into scope
- ; lintBinders CasePatBind args $ \ args' -> do
+ ; lintLocalBinders CasePatBind args $ \ args' -> do
{
rhs_ue <- lintAltExpr rhs alt_ty
; rhs_ue' <- addLoc (CasePat alt) (lintAltBinders rhs_ue case_bndr scrut_ty con_payload_ty (zipEqual "lintCoreAlt" multiplicities args'))
@@ -1808,22 +1817,32 @@ lintLinearBinder doc actual_usage described_usage
************************************************************************
-}
+lintLocalBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
+lintLocalBinders = lintBinders NotTopLevel
+
+lintLocalBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
+lintLocalBinder = lintBinder NotTopLevel
+
+lintBinders :: TopLevelFlag -> BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
-- When we lint binders, we (one at a time and in order):
-- 1. Lint var types or kinds (possibly substituting)
-- 2. Add the binder to the in scope set, and if its a coercion var,
-- we may extend the substitution to reflect its (possibly) new kind
-lintBinders :: BindingSite -> [Var] -> ([Var] -> LintM a) -> LintM a
-lintBinders _ [] linterF = linterF []
-lintBinders site (var:vars) linterF = lintBinder site var $ \var' ->
- lintBinders site vars $ \ vars' ->
- linterF (var':vars')
+lintBinders top_lvl site vars thing_inside
+ = go vars thing_inside
+ where
+ go :: [Var] -> ([Var] -> LintM a) -> LintM a
+ go [] thing_inside = thing_inside []
+ go (var:vars) thing_inside = lintBinder top_lvl site var $ \var' ->
+ go vars $ \vars' ->
+ thing_inside (var' : vars')
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism]
-lintBinder :: BindingSite -> Var -> (Var -> LintM a) -> LintM a
-lintBinder site var linterF
+lintBinder :: TopLevelFlag -> BindingSite -> Var -> (Var -> LintM a) -> LintM a
+lintBinder top_lvl site var linterF
| isTyCoVar var = lintTyCoBndr var linterF
- | otherwise = lintIdBndr NotTopLevel site var linterF
+ | otherwise = lintIdBndr top_lvl site var linterF
lintTyBndr :: TyVar -> (LintedTyCoVar -> LintM a) -> LintM a
lintTyBndr = lintTyCoBndr -- We could specialise it, I guess
@@ -1849,16 +1868,6 @@ lintTyCoBndr tcv thing_inside
; updateSubst subst' (thing_inside tcv') }
-lintIdBndrs :: forall a. TopLevelFlag -> [Id] -> ([LintedId] -> LintM a) -> LintM a
-lintIdBndrs top_lvl ids thing_inside
- = go ids thing_inside
- where
- go :: [Id] -> ([Id] -> LintM a) -> LintM a
- go [] thing_inside = thing_inside []
- go (id:ids) thing_inside = lintIdBndr top_lvl LetBind id $ \id' ->
- go ids $ \ids' ->
- thing_inside (id' : ids')
-
lintIdBndr :: TopLevelFlag -> BindingSite
-> InVar -> (OutVar -> LintM a) -> LintM a
-- Do substitution on the type of a binder and add the var with this
@@ -2203,7 +2212,7 @@ lintCoreRule _ _ (BuiltinRule {})
lintCoreRule fun fun_ty rule@(Rule { ru_name = name, ru_bndrs = bndrs
, ru_args = args, ru_rhs = rhs })
- = lintBinders LambdaBind bndrs $ \ _ ->
+ = lintLocalBinders LambdaBind bndrs $ \ _ ->
do { (lhs_ty, _) <- lintCoreArgs (fun_ty, zeroUE) args
; (rhs_ty, _) <- case idJoinPointHood fun of
JoinPoint join_arity
@@ -2849,7 +2858,7 @@ lint_axiom ax@(CoAxiom { co_ax_tc = tc, co_ax_branches = branches
lint_branch :: TyCon -> CoAxBranch -> LintM ()
lint_branch ax_tc (CoAxBranch { cab_tvs = tvs, cab_cvs = cvs
, cab_lhs = lhs_args, cab_rhs = rhs })
- = lintBinders LambdaBind (tvs ++ cvs) $ \_ ->
+ = lintLocalBinders LambdaBind (tvs ++ cvs) $ \_ ->
do { let lhs = mkTyConApp ax_tc lhs_args
; lhs' <- lintType lhs
; rhs' <- lintType rhs
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -921,7 +921,7 @@ setIdLFInfo id lf = modifyIdInfo (`setLFInfo` lf) id
---------------------------------
-- Occurrence INFO
-idOccInfo :: Id -> OccInfo
+idOccInfo :: HasDebugCallStack => Id -> OccInfo
idOccInfo id = occInfo (idInfo id)
setIdOccInfo :: Id -> OccInfo -> Id
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d0f30cc2d11b7532adfd8436a0903ca5a591e324
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/d0f30cc2d11b7532adfd8436a0903ca5a591e324
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20241025/6276d49f/attachment-0001.html>
More information about the ghc-commits
mailing list