[Git][ghc/ghc][wip/romes/linear-core] Some progress
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu May 25 14:37:24 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/linear-core at Glasgow Haskell Compiler / GHC
Commits:
c834d7ad by Rodrigo Mesquita at 2023-05-25T15:37:10+01:00
Some progress
- - - - -
23 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Monad.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/Hs/Binds.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/TcMType.hs
- compiler/GHC/Types/Var.hs
- compiler/Language/Haskell/Syntax/Expr.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -40,7 +40,7 @@ module GHC.Core (
isId, cmpAltCon, cmpAlt, ltAlt,
-- ** Simple 'Expr' access functions and predicates
- bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts,
+ bindersOf, bindersOfBinds, rhssOfBind, bindersOfAlts, rhssOfAlts,
foldBindersOfBindStrict, foldBindersOfBindsStrict,
collectBinders, collectTyBinders, collectTyAndValBinders,
collectNBinders, collectNValBinders_maybe,
@@ -254,7 +254,7 @@ data Expr b
| App (Expr b) (Arg b)
| HasCallStack => Lam b (Expr b)
| HasCallStack => Let (Bind b) (Expr b)
- | Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants]
+ | HasCallStack => Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants]
-- and Note [Why does Case have a 'Type' field?]
| Cast (Expr b) CoercionR -- The Coercion has Representational role
| Tick CoreTickish (Expr b)
@@ -1934,7 +1934,7 @@ mkLets :: HasCallStack => Typeable b => [Bind b] -> Expr b -> Expr b
-- use 'GHC.Core.Make.mkCoreLams' if possible
mkLams :: forall b. HasCallStack => Typeable b => [b] -> Expr b -> Expr b
-mkLams binders body = case eqT @b @Id of Just Refl -> if not (all isLambdaBinding binders) then pprPanic "mkLams" (text "A let-bound var [" <+> hsep (map pprIdWithBinding binders) <+> text "] was used to construct a lambda binder!") else foldr Lam body binders
+mkLams binders body = case eqT @b @Id of Just Refl -> if any (not . isLambdaBinding) binders then pprPanic "mkLams" (text "A let-bound var [" <+> hsep (map pprIdWithBinding binders) <+> text "] was used to construct a lambda binder!") else foldr Lam body binders
Nothing -> foldr Lam body binders
mkLets binds body = foldr mkLet body binds
@@ -2039,6 +2039,10 @@ rhssOfBind :: Bind b -> [Expr b]
rhssOfBind (NonRec _ rhs) = [rhs]
rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
+-- | Concat together all the binders in each alternative
+bindersOfAlts :: [Alt b] -> [b]
+bindersOfAlts = concatMap (\(Alt _ ids _) -> ids)
+
rhssOfAlts :: [Alt b] -> [Expr b]
rhssOfAlts alts = [e | Alt _ _ e <- alts]
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -2342,6 +2342,9 @@ occAnal env expr@(Lam {})
= adjustNonRecRhs Nothing $ occAnalLamTail env expr -- mb_join_arity == Nothing <=> markAllManyNonTail
occAnal env (Case scrut bndr ty alts)
+ | isLetBinding bndr || any isLetBinding (bindersOfAlts alts)
+ = pprPanic "simplExprF1:ouch!" (pprIdWithBinding bndr <+> ppr alts)
+ | otherwise
= let
(WithUsageDetails scrut_usage scrut') = occAnal (scrutCtxt env alts) scrut
alt_env = addBndrSwap scrut' bndr $ env { occ_encl = OccVanilla } `addOneInScope` bndr
@@ -2361,8 +2364,12 @@ occAnal env (Case scrut bndr ty alts)
occAnal env (Let bind body)
| NonRec b _ <- bind
- , isLambdaBinding b
- = pprPanic "occAnal" (pprIdWithBinding b)
+ , not (isLetBinding b)
+ , isId b
+ = pprPanic "occAnal:NonRec" (pprIdWithBinding b)
+ | Rec bs <- bind
+ , any (\x -> isId (fst x) && (not . isLetBinding . fst) x) bs
+ = pprPanic "occAnal:Rec" (ppr bs)
| otherwise
= let
body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -60,7 +60,7 @@ import GHC.Types.Demand
import GHC.Types.Unique ( hasKey )
import GHC.Types.Basic
import GHC.Types.Tickish
-import GHC.Types.Var ( isTyCoVar )
+import GHC.Types.Var ( isTyCoVar, pprIdWithBinding, isLetBinding, isLambdaBinding )
import GHC.Builtin.PrimOps ( PrimOp (SeqOp) )
import GHC.Builtin.Types.Prim( realWorldStatePrimTy )
import GHC.Builtin.Names( runRWKey )
@@ -587,7 +587,7 @@ unless the kind of the type of rhs is concrete, in the sense of
Note [Concrete types] in GHC.Tc.Utils.Concrete.
-}
-tryCastWorkerWrapper :: SimplEnv -> BindContext
+tryCastWorkerWrapper :: HasCallStack => SimplEnv -> BindContext
-> InId -> OccInfo
-> OutId -> OutExpr
-> SimplM (SimplFloats, SimplEnv)
@@ -918,7 +918,7 @@ It does *not* attempt to do let-to-case. Why? Because it is used for
Nor does it do the atomic-argument thing
-}
-completeBind :: SimplEnv
+completeBind :: HasCallStack => SimplEnv
-> BindContext
-> InId -- Old binder
-> OutId -- New binder; can be a JoinId
@@ -973,6 +973,7 @@ completeBind env bind_cxt old_bndr new_bndr new_rhs
addLetBndrInfo :: OutId -> ArityType -> Unfolding -> OutId
addLetBndrInfo new_bndr new_arity_type new_unf
= new_bndr `setIdInfo` info5
+ `setIdBinding` LetBound zeroUE -- See Note [Keeping the IdBinding up to date]
where
new_arity = arityTypeArity new_arity_type
info1 = idInfo new_bndr `setArityInfo` new_arity
@@ -1213,6 +1214,9 @@ simplExprF1 env expr@(Lam {}) cont
-- and likewise drop counts all binders (incl type lambdas)
simplExprF1 env (Case scrut bndr _ alts) cont
+ | isLetBinding bndr || any isLetBinding (bindersOfAlts alts)
+ = pprPanic "simplExprF1:ouch!" (pprIdWithBinding bndr <+> ppr alts)
+ | otherwise
= {-#SCC "simplExprF1-Case" #-}
pprTrace "simplExprF1:Case:" (ppr bndr <+> ppr (idBinding bndr)) $
simplExprF env scrut (Select { sc_dup = NoDup, sc_bndr = bndr
@@ -2933,6 +2937,9 @@ rebuildCase, reallyRebuildCase
--------------------------------------------------
rebuildCase env scrut case_bndr alts cont
+ | isLetBinding case_bndr || any isLetBinding (bindersOfAlts alts)
+ = pprPanic "reallyRebuildCase:ouch!" (pprIdWithBinding case_bndr <+> ppr alts)
+
| Lit lit <- scrut -- No need for same treatment as constructors
-- because literals are inlined more vigorously
, not (litIsLifted lit)
@@ -3831,6 +3838,8 @@ mkDupableAlt :: HasCallStack => Platform -> OutId
-> JoinFloats -> OutAlt
-> SimplM (JoinFloats, OutAlt)
mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)
+ | any (not . isLambdaBinding) alt_bndrs
+ = pprPanic "mkDupableAlt: Alt has let binders" (ppr $ map pprIdWithBinding alt_bndrs)
| exprIsTrivial alt_rhs_in -- See point (2) of Note [Duplicating join points]
= return (jfloats, Alt con alt_bndrs alt_rhs_in)
@@ -3879,7 +3888,8 @@ mkDupableAlt _platform case_bndr jfloats (Alt con alt_bndrs alt_rhs_in)
-- so we must zap them here.
join_rhs = mkLams (map zapIdUnfolding final_bndrs) rhs_with_seqs
- ; pprTraceM "mkDupableAlt:filtered_binders" (ppr $ map (\x -> ppr x <+> ppr (idBinding x)) filtered_binders)
+ ; pprTraceM "mkDupableAlt:final_bndrs" (ppr $ map pprIdWithBinding final_bndrs)
+ ; pprTraceM "mkDupableAlt:filtered_binders" (ppr $ map pprIdWithBinding filtered_binders)
; join_bndr <- newJoinId filtered_binders rhs_ty'
; let join_call = mkApps (Var join_bndr) final_args
=====================================
compiler/GHC/Core/Opt/Simplify/Monad.hs
=====================================
@@ -221,7 +221,7 @@ newJoinId bndrs body_ty
id_info = vanillaIdInfo `setArityInfo` arity
-- `setOccInfo` strongLoopBreaker
- ; return (mkLocalVar details name (LetBound zeroUE) join_id_ty id_info) } -- ROMES:TODO: What are the IdBindings of JoinPoints? Should we consider them explicitly for join points or treat as lets?
+ ; return (mkLocalVar details name (LetBound zeroUE) join_id_ty id_info) }
{-
************************************************************************
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -4,7 +4,7 @@
The simplifier utilities
-}
-
+{-# LANGUAGE ExistentialQuantification #-}
module GHC.Core.Opt.Simplify.Utils (
-- Rebuilding
@@ -50,6 +50,7 @@ import GHC.Types.Literal ( isLitRubbish )
import GHC.Core.Opt.Simplify.Env
import GHC.Core.Opt.Simplify.Inline
import GHC.Core.Opt.Stats ( Tick(..) )
+import GHC.Core.UsageEnv (zeroUE)
import qualified GHC.Core.Subst
import GHC.Core.Ppr
import GHC.Core.TyCo.Ppr ( pprParendType )
@@ -179,7 +180,7 @@ data SimplCont
-- See Note [The hole type in ApplyToTy]
, sc_cont :: SimplCont }
- | Select -- (Select alts K)[e] = K[ case e of alts ]
+ | HasCallStack => Select -- (Select alts K)[e] = K[ case e of alts ]
{ sc_dup :: DupFlag -- See Note [DupFlag invariants]
, sc_bndr :: InId -- case binder
, sc_alts :: [InAlt] -- Alternatives
@@ -2289,7 +2290,7 @@ OutId. Test simplCore/should_compile/simpl013 apparently shows this
up, although I'm not sure exactly how..
-}
-prepareAlts :: OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
+prepareAlts :: HasCallStack => OutExpr -> InId -> [InAlt] -> SimplM ([AltCon], [InAlt])
-- The returned alternatives can be empty, none are possible
--
-- Note that case_bndr is an InId; see Note [Shadowing in prepareAlts]
@@ -2538,7 +2539,9 @@ mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)
(Alt con args (wrap_rhs rhs))
-- Simplifier's no-shadowing invariant should ensure
-- that outer_bndr is not shadowed by the inner patterns
- wrap_rhs rhs = Let (NonRec inner_bndr (Var outer_bndr)) rhs
+ wrap_rhs rhs = Let (NonRec (inner_bndr `setIdBinding` LetBound zeroUE) (Var outer_bndr)) rhs
+ -- IdBinding: See Note [Keeping the IdBinding up to date]
+ --
-- The let is OK even for unboxed binders,
wrapped_alts | isDeadBinder inner_bndr = inner_alts
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -37,6 +37,7 @@ import GHC.Core.TyCon.RecWalk
import GHC.Core.SimpleOpt( SimpleOpts )
import GHC.Types.Id
+import GHC.Types.Var (pprIdWithBinding, isLambdaBinding)
import GHC.Types.Id.Info
import GHC.Types.Demand
import GHC.Types.Cpr
@@ -277,7 +278,11 @@ mkWwBodies opts fun_id arg_vars res_ty demands res_cpr
mkAppsBeta :: CoreExpr -> [CoreArg] -> CoreExpr
-- The precondition holds for our call site in mkWwBodies, because all the FVs
-- of as are either cloned_arg_vars (and thus fresh) or fresh worker args.
-mkAppsBeta (Lam b body) (a:as) = bindNonRec b a $! mkAppsBeta body as
+mkAppsBeta (Lam b body) (a:as)
+ | not (isLambdaBinding b)
+ = pprPanic "mkAppsBeta" (pprIdWithBinding b)
+ | otherwise
+ = bindNonRec b a $! mkAppsBeta body as
mkAppsBeta f as = mkApps f as
-- See Note [Limit w/w arity]
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -35,6 +35,7 @@ import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, Id
import GHC.Types.Var ( isNonCoVarId )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
+import GHC.Core.UsageEnv
import GHC.Core.DataCon
import GHC.Types.Demand( etaConvertDmdSig, topSubDmd )
import GHC.Types.Tickish
@@ -768,9 +769,11 @@ add_info env old_bndr top_level new_rhs new_bndr
False -- may be bottom or not
new_rhs Nothing
-wrapLet :: Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
+wrapLet :: HasCallStack => Maybe (Id,CoreExpr) -> CoreExpr -> CoreExpr
wrapLet Nothing body = body
-wrapLet (Just (b,r)) body = Let (NonRec b r) body
+wrapLet (Just (b,r)) body = Let (NonRec (b `setIdBinding` LetBound zeroUE) r) body
+ -- See Note [Keeping the IdBinding up to date]
+ -- wrapLet is called always on binders lambda bound
{-
Note [Inline prag in simplOpt]
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -523,7 +523,11 @@ bindNonRec bndr rhs body
lambda_bndr = setIdBinding bndr (maybe (LambdaBound ManyTy) LambdaBound (varMultMaybe bndr)) -- ROMES:TODO: Explain, is this the best place to do this?
case_bind = mkDefaultCase rhs lambda_bndr body
-- ROMES:TODO: I couldn't find the root cause, for now we simply override the idBinding here
- let_bind = Let (NonRec (bndr `setIdBinding` LetBound zeroUE) rhs) body
+ let_bind
+ | isId bndr
+ = Let (NonRec (bndr `setIdBinding` LetBound zeroUE) rhs) body
+ | otherwise
+ = Let (NonRec bndr rhs) body
-- | Tests whether we have to use a @case@ rather than @let@ binding for this
-- expression as per the invariants of 'CoreExpr': see "GHC.Core#let_can_float_invariant"
@@ -547,7 +551,7 @@ mkAltExpr (LitAlt lit) [] []
mkAltExpr (LitAlt _) _ _ = panic "mkAltExpr LitAlt"
mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
-mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr
+mkDefaultCase :: HasCallStack => CoreExpr -> Id -> CoreExpr -> CoreExpr
-- Make (case x of y { DEFAULT -> e }
mkDefaultCase scrut case_bndr body
= assertPpr (isJust (varMultMaybe case_bndr)) (text "mkDefaultCase:Case binder is marked LetBound!") $
@@ -606,7 +610,7 @@ findDefault :: [Alt b] -> ([Alt b], Maybe (Expr b))
findDefault (Alt DEFAULT args rhs : alts) = assert (null args) (alts, Just rhs)
findDefault alts = (alts, Nothing)
-addDefault :: [Alt b] -> Maybe (Expr b) -> [Alt b]
+addDefault :: HasCallStack => [Alt b] -> Maybe (Expr b) -> [Alt b]
addDefault alts Nothing = alts
addDefault alts (Just rhs) = Alt DEFAULT [] rhs : alts
@@ -688,7 +692,8 @@ trimConArgs DEFAULT args = assert (null args) []
trimConArgs (LitAlt _) args = assert (null args) []
trimConArgs (DataAlt dc) args = dropList (dataConUnivTyVars dc) args
-filterAlts :: TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities)
+filterAlts :: HasCallStack
+ => TyCon -- ^ Type constructor of scrutinee's type (used to prune possibilities)
-> [Type] -- ^ And its type arguments
-> [AltCon] -- ^ 'imposs_cons': constructors known to be impossible due to the form of the scrutinee
-> [Alt b] -- ^ Alternatives
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE ExistentialQuantification #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -74,6 +75,8 @@ import Data.List ( unfoldr )
import Data.Functor.Identity
import Control.Monad
+import GHC.Core.UsageEnv (zeroUE)
+
{-
Note [CorePrep Overview]
~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1722,7 +1725,7 @@ data FloatingBind
-- They are always of lifted type;
-- unlifted ones are done with FloatCase
- | FloatCase
+ | HasCallStack => FloatCase
CpeBody -- Always ok-for-speculation
Id -- Case binder
AltCon [Var] -- Single alternative
@@ -1761,14 +1764,15 @@ data OkToSpec
-- ok-to-speculate unlifted bindings
| NotOkToSpec -- Some not-ok-to-speculate unlifted bindings
-mkFloat :: CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
+mkFloat :: HasCallStack => CorePrepEnv -> Demand -> Bool -> Id -> CpeRhs -> FloatingBind
+-- romes:TODO: See Note [Keeping the IdBinding up to date]
mkFloat env dmd is_unlifted bndr rhs
| is_strict || ok_for_spec -- See Note [Speculative evaluation]
- , not is_hnf = FloatCase rhs bndr DEFAULT [] ok_for_spec
+ , not is_hnf = FloatCase rhs (bndr `setIdBinding` LambdaBound ManyTy) DEFAULT [] ok_for_spec
-- Don't make a case for a HNF binding, even if it's strict
-- Otherwise we get case (\x -> e) of ...!
- | is_unlifted = FloatCase rhs bndr DEFAULT [] True
+ | is_unlifted = FloatCase rhs (bndr `setIdBinding` LambdaBound ManyTy) DEFAULT [] True
-- we used to assertPpr ok_for_spec (ppr rhs) here, but it is now disabled
-- because exprOkForSpeculation isn't stable under ANF-ing. See for
-- example #19489 where the following unlifted expression:
@@ -2223,7 +2227,7 @@ fiddleCCall id
newVar :: Type -> UniqSM Id
newVar ty
- = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") (LambdaBound ManyTy) ty -- ROMES:TODO: What kind of binders?! I guess up until now it didn't really matter, but now it does
+ = seqType ty `seq` mkSysLocalOrCoVarM (fsLit "sat") (LetBound zeroUE) ty
------------------------------------------------------------------------------
=====================================
compiler/GHC/Hs/Binds.hs
=====================================
@@ -9,6 +9,8 @@
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
-- in module Language.Haskell.Syntax.Extension
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE StandaloneDeriving #-}
{-# OPTIONS_GHC -Wno-orphans #-} -- Outputable
@@ -49,6 +51,7 @@ import GHC.Data.Bag
import GHC.Data.BooleanFormula (LBooleanFormula)
import GHC.Types.Name.Reader
import GHC.Types.Name
+import GHC.Stack
import GHC.Utils.Outputable
import GHC.Utils.Panic
@@ -692,8 +695,8 @@ type instance XXFixitySig (GhcPass p) = DataConCantHappen
-- generated for record selectors. We simply record the desired Id
-- itself, replete with its name, type and IdDetails. Otherwise it's
-- just like a type signature: there should be an accompanying binding
-newtype IdSig = IdSig { unIdSig :: Id }
- deriving Data
+data IdSig = HasCallStack => IdSig { unIdSig :: Id }
+deriving instance Data IdSig
data AnnSig
= AnnSig {
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -321,7 +321,7 @@ dsAbsBinds dflags tyvars dicts exports
, abe_poly = global
, abe_mono = local, abe_prags = spec_prags })
-- See Note [ABExport wrapper] in "GHC.Hs.Binds"
- = do { tup_id <- newSysLocalDs (LambdaBound ManyTy) tup_ty -- ROMES:TODO?
+ = do { tup_id <- newSysLocalDs (LetBound zeroUE) tup_ty -- ROMES:TODO?
; dsHsWrapper wrap $ \core_wrap -> do
{ let rhs = core_wrap $ mkLams tyvars $ mkLams dicts $
mkBigTupleSelector all_locals local tup_id $
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -51,6 +51,7 @@ import GHC.Core.Make
import GHC.Driver.Session
import GHC.Types.CostCentre
import GHC.Types.Id
+import GHC.Types.Var (pprIdWithBinding)
import GHC.Types.Id.Make
import GHC.Unit.Module
import GHC.Core.ConLike
@@ -155,6 +156,8 @@ ds_val_bind (is_rec, binds) body
-- we should never produce a non-recursive list of multiple binds
; (force_vars,prs) <- dsLHsBinds binds
+ ; pprTraceM "ds_val_bind:binds" (ppr binds)
+ ; pprTraceM "ds_val_bind:prs" (ppr $ map (pprIdWithBinding . fst) prs)
; let body' = foldr seqVar body force_vars
; assertPpr (not (any (isUnliftedType . idType . fst) prs)) (ppr is_rec $$ ppr binds) $
-- NB: bindings have a fixed RuntimeRep, so it's OK to call isUnliftedType
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -28,6 +28,7 @@ import Language.Haskell.Syntax.Basic (Boxity(..))
import {-#SOURCE#-} GHC.HsToCore.Expr (dsExpr)
+import GHC.Core.UsageEnv (zeroUE)
import GHC.Types.Basic ( Origin(..), isGenerated )
import GHC.Types.SourceText
import GHC.Driver.Session
@@ -371,7 +372,6 @@ Among other things in the resulting Pattern:
The bindings created by the above patterns are put into the returned wrapper
instead.
--- ROMES:TODO: Do something about this, lambda bound can become let bound for irrefutable patterns
This means a definition of the form:
f x = rhs
when called with v get's desugared to the equivalent of:
@@ -396,12 +396,14 @@ only these which can be assigned a PatternGroup (see patGroup).
-}
+-- | See 'Tidiying Patterns' above
+--
+-- Wraps a call to 'tidy1' which does the interesting stuff, looking at one
+-- pattern and fiddling the list of bindings
tidyEqnInfo :: Id -> EquationInfo
-> DsM (DsWrapper, EquationInfo)
-- DsM'd because of internal call to dsLHsBinds
-- and mkSelectorBinds.
- -- "tidy1" does the interesting stuff, looking at
- -- one pattern and fiddling the list of bindings.
--
-- POST CONDITION: head pattern in the EqnInfo is
-- one of these for which patGroup is defined.
@@ -413,12 +415,13 @@ tidyEqnInfo v eqn@(EqnInfo { eqn_pats = pat : pats, eqn_orig = orig })
= do { (wrap, pat') <- tidy1 v orig pat
; return (wrap, eqn { eqn_pats = pat' : pats }) }
+-- | See also 'Tidiying Patterns' above
tidy1 :: Id -- The Id being scrutinised
-> Origin -- Was this a pattern the user wrote?
-> Pat GhcTc -- The pattern against which it is to be matched
-> DsM (DsWrapper, -- Extra bindings to do before the match
Pat GhcTc) -- Equivalent pattern
-
+-- ^
-------------------------------------------------------
-- (pat', mr') = tidy1 v pat mr
-- tidies the *outer level only* of pat, giving pat'
@@ -433,13 +436,15 @@ tidy1 v o (BangPat _ (L l p)) = tidy_bang_pat v o l p
-- case v of { x -> mr[] }
-- = case v of { _ -> let x=v in mr[] }
tidy1 v _ (VarPat _ (L _ var))
- = return (wrapBind var v, WildPat (idType var))
+ = return (wrapBind (var `setIdBinding` LetBound zeroUE) v, WildPat (idType var))
+ -- See Note [Keeping the IdBinding up to date]
-- case v of { x at p -> mr[] }
-- = case v of { p -> let x=v in mr[] }
tidy1 v o (AsPat _ (L _ var) _ pat)
= do { (wrap, pat') <- tidy1 v o (unLoc pat)
- ; return (wrapBind var v . wrap, pat') }
+ ; return (wrapBind (var `setIdBinding` LetBound zeroUE) v . wrap, pat') }
+ -- See Note [Keeping the IdBinding up to date]
{- now, here we handle lazy patterns:
tidy1 v ~p bs = (v, v1 = case v of p -> v1 :
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -153,7 +153,8 @@ selectMatchVar _w (VarPat _ var) = pprTrace "selectMatchVar:VarPat" (pprIdWit
-- multiplicity stored within the variable
-- itself. It's easier to pull it from the
-- variable, so we ignore the multiplicity.
-selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return ((unLoc var) `setIdBinding` (LambdaBound ManyTy))) -- ROMES:TODO: Are match variables always put in cases? If yes, then this could be a way to guarantee match variables are lambda bound/case bound
+selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return ((unLoc var) `setIdBinding` (LambdaBound ManyTy)))
+ -- ROMES:TODO: Are match variables always put in cases? If yes, then this could be a way to guarantee match variables are lambda bound/case bound
-- selectMatchVar _w (AsPat _ var _ _) = assert (isManyTy _w ) (return (unLoc var))
selectMatchVar w other_pat = newSysLocalDs (LambdaBound w) (hsPatType other_pat) -- ROMES:TODO: Can match variables end up in lets and cases?, I think yes.
@@ -251,17 +252,22 @@ adjustMatchResultDs encl_fn = \case
MR_Fallible body_fn -> MR_Fallible $ \fail ->
encl_fn =<< body_fn fail
-wrapBinds :: [(Var,Var)] -> CoreExpr -> CoreExpr
+wrapBinds :: HasCallStack => [(Var,Var)] -> CoreExpr -> CoreExpr
wrapBinds [] e = e
wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
-wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
+wrapBind :: HasCallStack => Var -> Var -> CoreExpr -> CoreExpr
wrapBind new old body -- NB: this function must deal with term
| new==old = body -- variables, type variables or coercion variables
| otherwise = Let (NonRec new (varToCoreExpr old)) body
-seqVar :: Var -> CoreExpr -> CoreExpr
-seqVar var body = mkDefaultCase (Var var) var body
+-- | 'seqVar' produces a 'CoreExpr' in which the evaluation of 'Var' is forced
+-- by means of scrutinizing it in a case expression with a single DEFAULT alternative.
+seqVar :: HasCallStack => Var -> CoreExpr -> CoreExpr
+-- romes:TODO: it's not evident how to consider the case of a variable that was
+-- let bound being used for the case scrutinee. Now I'm making them ManyTy to
+-- move forward
+seqVar var body = mkDefaultCase (Var var) (var `setIdBinding` LambdaBound ManyTy) body
mkCoLetMatchResult :: CoreBind -> MatchResult CoreExpr -> MatchResult CoreExpr
mkCoLetMatchResult bind = fmap (mkCoreLet bind)
@@ -734,8 +740,8 @@ work out well:
; y = case v of K x y -> y }
which is better.
-}
--- Remark: pattern selectors only occur in unrestricted patterns so we are free
--- to select Many as the multiplicity of every let-expression introduced.
+
+-- | See Note [mkSelectorBinds]
mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
-> LPat GhcTc -- ^ The pattern
-> CoreExpr -- ^ Expression to which the pattern is bound
@@ -744,13 +750,17 @@ mkSelectorBinds :: [[CoreTickish]] -- ^ ticks to add, possibly
-- binds (see Note [Desugar Strict binds] in "GHC.HsToCore.Binds")
-- and all the desugared binds
+-- ROMES:TODO: Update remark, and what's a pattern selector?
+-- Remark: pattern selectors only occur in unrestricted patterns so we are free
+-- to select Many as the multiplicity of every let-expression introduced.
+-- See also Note [Keeping the IdBinding up to date]
mkSelectorBinds ticks pat val_expr
| L _ (VarPat _ (L _ v)) <- pat' -- Special case (A)
= return (v, [(v, val_expr)])
| is_flat_prod_lpat pat' -- Special case (B)
= do { let pat_ty = hsLPatType pat'
- ; val_var <- newSysLocalDs (LambdaBound ManyTy) pat_ty -- ROMES:TODO: selector binders are lambda bound?
+ ; val_var <- newSysLocalDs (LetBound zeroUE) pat_ty
; let mk_bind tick bndr_var
-- (mk_bind sv bv) generates bv = case sv of { pat -> bv }
@@ -768,7 +778,7 @@ mkSelectorBinds ticks pat val_expr
; return ( val_var, (val_var, val_expr) : binds) }
| otherwise -- General case (C)
- = do { tuple_var <- newSysLocalDs (LambdaBound ManyTy) tuple_ty -- ROMES:TODO: selector binders are lambda bound? yes since they're used ahead in mkBigTupleSelectorSolo?
+ = do { tuple_var <- newSysLocalDs (LetBound zeroUE) tuple_ty
; error_expr <- mkErrorAppDs pAT_ERROR_ID tuple_ty (ppr pat')
; tuple_expr <- matchSimply val_expr PatBindRhs pat
local_tuple error_expr
=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -1303,7 +1303,7 @@ checkFunBind strictness locF ann fun is_infix pats (L _ grhss)
| Infix <- is_infix = ParseContext (Just $ unLoc fun) NoIncompleteDoBlock
| otherwise = noParseContext
-makeFunBind :: LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
+makeFunBind :: HasCallStack => LocatedN RdrName -> LocatedL [LMatch GhcPs (LHsExpr GhcPs)]
-> HsBind GhcPs
-- Like GHC.Hs.Utils.mkFunBind, but we need to be able to set the fixity too
makeFunBind fn ms
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -555,7 +555,7 @@ recoveryCode binder_names sig_fn
, Just poly_id <- completeSigPolyId_maybe sig
= poly_id
| otherwise
- = mkLocalId name (LambdaBound ManyTy) forall_a_a -- ROMES:TODO: Does it matter?
+ = mkLocalId name (LetBound zeroUE) forall_a_a -- ROMES:TODO: Does it matter?
forall_a_a :: TcType
-- At one point I had (forall r (a :: TYPE r). a), but of course
@@ -609,11 +609,12 @@ tcPolyCheck :: TcPragEnv
-- it is a FunBind
-- it has a complete type signature,
tcPolyCheck prag_fn
- (CompleteSig { sig_bndr = poly_id
- , sig_ctxt = ctxt
- , sig_loc = sig_loc })
+ cs
(L bind_loc (FunBind { fun_id = L nm_loc name
, fun_matches = matches }))
+ | (CompleteSig { sig_bndr = poly_id
+ , sig_ctxt = ctxt
+ , sig_loc = sig_loc }) <- cs
= do { traceTc "tcPolyCheck" (ppr poly_id $$ ppr sig_loc)
; mono_name <- newNameAt (nameOccName name) (locA nm_loc)
@@ -965,7 +966,7 @@ mkInferredPolyId residual insoluble qtvs inferred_theta poly_name mb_sig_inst mo
-- (#14000) we may report an ambiguity error for a rather
-- bogus type.
- ; return (mkLocalId poly_name (LambdaBound ManyTy) inferred_poly_ty) } -- ROMES:TODO: Inferred poly id is prob forall bound, consider lambda bound (its lambda alright, a big one) ?
+ ; return (mkLocalId poly_name (LetBound zeroUE) inferred_poly_ty) } -- ROMES:TODO: Inferred poly id is prob forall bound, consider lambda bound (its lambda alright, a big one) ?
chooseInferredQuantifiers :: WantedConstraints -- residual constraints
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -76,6 +76,7 @@ import Data.Maybe( mapMaybe )
import qualified Data.List.NonEmpty as NE
import Control.Monad( unless )
import GHC.Core.UsageEnv (zeroUE)
+import GHC.Stack
{- -------------------------------------------------------------
@@ -280,7 +281,7 @@ lhsSigTypeContextSpan (L _ HsSig { sig_body = sig_ty }) = go sig_ty
go (L _ (HsParTy _ hs_ty)) = go hs_ty -- Look under parens
go _ = NoRRC -- Did not find it
-completeSigFromId :: UserTypeCtxt -> Id -> TcIdSigInfo
+completeSigFromId :: HasCallStack => UserTypeCtxt -> Id -> TcIdSigInfo
-- Used for instance methods and record selectors
completeSigFromId ctxt id
= CompleteSig { sig_bndr = id
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -45,7 +45,7 @@ import GHC.Tc.TyCl.Build( TcMethInfo )
import GHC.Core.Type ( extendTvSubstWithClone, piResultTys )
import GHC.Core.Predicate
-import GHC.Core.Multiplicity
+import GHC.Core.UsageEnv (zeroUE)
import GHC.Core.Class
import GHC.Core.Coercion ( pprCoAxiom )
import GHC.Core.FamInstEnv
@@ -295,7 +295,7 @@ tcDefMeth clas tyvars this_dict binds_in hs_sig_fn prag_fn
ctxt = FunSigCtxt sel_name warn_redundant
- ; let local_dm_id = mkLocalId local_dm_name (LambdaBound ManyTy) local_dm_ty -- ROMES:TODO:
+ ; let local_dm_id = mkLocalId local_dm_name (LetBound zeroUE) local_dm_ty
local_dm_sig = CompleteSig { sig_bndr = local_dm_id
, sig_ctxt = ctxt
, sig_loc = getLocA hs_ty }
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -59,6 +59,7 @@ import GHC.Core.Type
import GHC.Core.SimpleOpt
import GHC.Core.Predicate( classMethodInstTy )
import GHC.Tc.Types.Evidence
+import GHC.Core.UsageEnv (zeroUE)
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
import GHC.Core.DataCon
@@ -2016,7 +2017,7 @@ tcMethodBody skol_info clas tyvars dfun_ev_vars inst_tys
| is_derived = addLandmarkErrCtxt (derivBindCtxt sel_id clas inst_tys) thing
| otherwise = thing
-tcMethodBodyHelp :: HsSigFun -> Id -> TcId
+tcMethodBodyHelp :: HasCallStack => HsSigFun -> Id -> TcId
-> LHsBind GhcRn -> TcM (LHsBinds GhcTc)
tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
| Just hs_sig_ty <- hs_sig_fn sel_name
@@ -2082,6 +2083,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
-- they are all for meth_id
------------------------
+-- | Romes:TODO: What is a MethId?
mkMethIds :: Class -> [TcTyVar] -> [EvVar]
-> [TcType] -> Id -> TcM (TcId, TcId)
-- returns (poly_id, local_id), but ignoring any instance signature
@@ -2091,8 +2093,8 @@ mkMethIds clas tyvars dfun_ev_vars inst_tys sel_id
; local_meth_name <- newName sel_occ
-- Base the local_meth_name on the selector name, because
-- type errors from tcMethodBody come from here
- ; let poly_meth_id = mkLocalId poly_meth_name (LambdaBound ManyTy) poly_meth_ty -- ROMES:TODO:
- local_meth_id = mkLocalId local_meth_name (LambdaBound ManyTy) local_meth_ty -- ROMES:TODO:
+ ; let poly_meth_id = mkLocalId poly_meth_name (LetBound zeroUE) poly_meth_ty -- ROMES:TODO: methIds
+ local_meth_id = mkLocalId local_meth_name (LetBound zeroUE) local_meth_ty -- ROMES:TODO:
; return (poly_meth_id, local_meth_id) }
where
=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -1445,7 +1445,7 @@ data TcSigInfo = TcIdSig TcIdSigInfo
| TcPatSynSig TcPatSynInfo
data TcIdSigInfo -- See Note [Complete and partial type signatures]
- = CompleteSig -- A complete signature with no wildcards,
+ = HasCallStack => CompleteSig -- A complete signature with no wildcards,
-- so the complete polymorphic type is known.
{ sig_bndr :: TcId -- The polymorphic Id with that type
=====================================
compiler/GHC/Tc/Utils/TcMType.hs
=====================================
@@ -156,6 +156,7 @@ import Control.Monad
import GHC.Data.Maybe
import qualified Data.Semigroup as Semi
import GHC.Types.Name.Reader
+import GHC.Core.UsageEnv (zeroUE)
{-
************************************************************************
@@ -322,7 +323,7 @@ emitNewExprHole occ ty
newDict :: Class -> [TcType] -> TcM DictId
newDict cls tys
= do { name <- newSysName (mkDictOcc (getOccName cls))
- ; return (mkLocalId name (LambdaBound ManyTy) (mkClassPred cls tys)) } -- Dicts are lambda bound with Many
+ ; return (mkLocalId name (LetBound zeroUE) (mkClassPred cls tys)) }
predTypeOccName :: PredType -> OccName
predTypeOccName ty = case classifyPredType ty of
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -1343,7 +1343,7 @@ updateIdTypeAndMultsM f id@(Id { varType = ty
; return (id { varType = ty', idBinding = binding' }) }
updateIdTypeAndMultsM _ other = pprPanic "updateIdTypeAndMultM" (ppr other)
-setIdBinding :: Id -> IdBinding -> Id
+setIdBinding :: HasCallStack => Id -> IdBinding -> Id
setIdBinding id !r | isId id = id { idBinding = r }
| otherwise = pprPanic "setIdBinding" (ppr id <+> ppr r)
=====================================
compiler/Language/Haskell/Syntax/Expr.hs
=====================================
@@ -45,6 +45,8 @@ import Data.Maybe
import Data.List.NonEmpty ( NonEmpty )
import GHC.Types.Name.Reader
+import GHC.Stack (HasCallStack)
+
{- Note [RecordDotSyntax field updates]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The extensions @OverloadedRecordDot@ @OverloadedRecordUpdate@ together
@@ -427,7 +429,7 @@ data HsExpr p
-- 'GHC.Parser.Annotation.AnnClose' @'}'@,'GHC.Parser.Annotation.AnnIn'
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
- | HsLet (XLet p)
+ | HasCallStack => HsLet (XLet p)
!(LHsToken "let" p)
(HsLocalBinds p)
!(LHsToken "in" p)
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c834d7adef595dab79b8dfc3b2e1e4c43c57a9c8
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/c834d7adef595dab79b8dfc3b2e1e4c43c57a9c8
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/20230525/659501e4/attachment-0001.html>
More information about the ghc-commits
mailing list