[Git][ghc/ghc][wip/romes/linear-core] Fix IdBindings of multiple top-level let bindings
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Wed May 24 21:16:18 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/linear-core at Glasgow Haskell Compiler / GHC
Commits:
6d180bbb by Rodrigo Mesquita at 2023-05-24T22:16:02+01:00
Fix IdBindings of multiple top-level let bindings
- - - - -
22 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Map/Type.hs
- compiler/GHC/Core/Opt/OccurAnal.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/UsageEnv.hs-boot
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Hs/Utils.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Binds.hs-boot
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Expr.hs-boot
- compiler/GHC/HsToCore/GuardedRHSs.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match.hs-boot
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Tc/Gen/Sig.hs
- compiler/GHC/Tc/Instance/Typeable.hs
- compiler/GHC/Tc/Types/Evidence.hs
- compiler/GHC/Types/Var.hs
- compiler/Language/Haskell/Syntax/Binds.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -253,7 +253,7 @@ data Expr b
| Lit Literal
| App (Expr b) (Arg b)
| HasCallStack => Lam b (Expr b)
- | Let (Bind b) (Expr b)
+ | HasCallStack => Let (Bind b) (Expr b)
| 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
@@ -313,9 +313,10 @@ instance Ord AltCon where
-- If you edit this type, you may need to update the GHC formalism
-- See Note [GHC Formalism] in GHC.Core.Lint
-data Bind b = NonRec b (Expr b)
- | Rec [(b, (Expr b))]
- deriving Data
+data Bind b = HasCallStack => NonRec b (Expr b)
+ | HasCallStack => Rec [(b, (Expr b))]
+
+deriving instance Data b => Data (Bind b)
{-
Note [Shadowing]
@@ -1928,23 +1929,23 @@ mkDoubleLitDouble d = Lit (mkLitDouble (toRational d))
-- | Bind all supplied binding groups over an expression in a nested let expression. Assumes
-- that the rhs satisfies the let-can-float invariant. Prefer to use
-- 'GHC.Core.Make.mkCoreLets' if possible, which does guarantee the invariant
-mkLets :: Typeable b => [Bind b] -> Expr b -> Expr b
+mkLets :: HasCallStack => Typeable b => [Bind b] -> Expr b -> Expr b
-- | Bind all supplied binders over an expression in a nested lambda expression. Prefer to
-- 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 -> assertPpr (all isLambdaBinding binders) (text "mkLams: A let-bound var [" <+> hsep (map pprIdWithBinding binders) <+> text "] was used to construct a lambda binder!") $ foldr Lam body binders
+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
Nothing -> foldr Lam body binders
mkLets binds body = foldr mkLet body binds
-- ROMES:TODO: temporary assertions, this is validated in the linter...
-mkLet :: forall b. Typeable b
+mkLet :: forall b. HasCallStack => Typeable b
=> Bind b -> Expr b -> Expr b
-- The desugarer sometimes generates an empty Rec group
-- which Lint rejects, so we kill it off right away
mkLet (Rec []) body = body
-mkLet bind body = case (eqT @b @Id) of Just Refl -> assertPpr (isLetBinder bind) (text "mkLet: A lambda-bound var [" <+> pprLetBinderId bind <+> text "] was used to construct a let binder!") $ Let bind body
+mkLet bind body = case (eqT @b @Id) of Just Refl -> if not (isLetBinder bind) then pprPanic "mkLet" (text "A lambda-bound var [" <+> pprLetBinderId bind <+> text "] was used to construct a let binder!") else Let bind body
Nothing -> Let bind body
where
isLetBinder (NonRec b _) = isLetBinding b
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -112,7 +112,7 @@ sortQuantVars vs = sorted_tcvs ++ ids
-- | Bind a binding group over an expression, using a @let@ or @case@ as
-- appropriate (see "GHC.Core#let_can_float_invariant")
-mkCoreLet :: CoreBind -> CoreExpr -> CoreExpr
+mkCoreLet :: HasCallStack => CoreBind -> CoreExpr -> CoreExpr
mkCoreLet (NonRec bndr rhs) body -- See Note [Core let-can-float invariant]
= bindNonRec bndr rhs body
mkCoreLet bind body
=====================================
compiler/GHC/Core/Map/Type.hs
=====================================
@@ -549,6 +549,7 @@ instance Eq (DeBruijn a) => Eq (DeBruijn (Maybe a)) where
-- only exist for Ids, not TyVars and such
-- The impl for varMultMaybe will surely chnge
data BndrMap a = BndrMap (TypeMapG (MaybeMap TypeMapG a))
+-- ROMES:TODO: AGAIN; FIX THIS.
-- TODO(22292): derive
instance Functor BndrMap where
=====================================
compiler/GHC/Core/Opt/OccurAnal.hs
=====================================
@@ -2360,6 +2360,10 @@ occAnal env (Case scrut bndr ty alts)
(alt_usg, Alt con tagged_bndrs rhs1)
occAnal env (Let bind body)
+ | NonRec b _ <- bind
+ , isLambdaBinding b
+ = pprPanic "occAnal" (pprIdWithBinding b)
+ | otherwise
= let
body_env = env { occ_encl = OccVanilla } `addInScope` bindersOf bind
(WithUsageDetails body_usage body') = occAnal body_env body
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -602,10 +602,11 @@ lvlNonTailMFE :: LevelEnv -- Level of in-scope names/tyvars
lvlNonTailMFE env strict_ctxt ann_expr
= lvlMFE (placeJoinCeiling env) strict_ctxt ann_expr
-lvlMFE :: LevelEnv -- Level of in-scope names/tyvars
- -> Bool -- True <=> strict context [body of case or let]
- -> CoreExprWithFVs -- input expression
- -> LvlM LevelledExpr -- Result expression
+lvlMFE :: HasCallStack
+ => LevelEnv -- Level of in-scope names/tyvars
+ -> Bool -- True <=> strict context [body of case or let]
+ -> CoreExprWithFVs -- input expression
+ -> LvlM LevelledExpr -- Result expression
-- lvlMFE is just like lvlExpr, except that it might let-bind
-- the expression, so that it can itself be floated.
@@ -1274,7 +1275,7 @@ lvlRhs env rec_flag is_bot mb_join_arity expr
= lvlFloatRhs [] (le_ctxt_lvl env) env
rec_flag is_bot mb_join_arity expr
--- ROMES:TODO: Document this function, what does it do?
+-- ROMES:TODO: Document this function, what does it do? With some examples.
lvlFloatRhs :: HasCallStack => [OutVar] -> Level -> LevelEnv -> RecFlag
-> Bool -- Binding is for a bottoming function
-> Maybe JoinArity
@@ -1293,7 +1294,7 @@ lvlFloatRhs abs_vars dest_lvl env rec is_bot mb_join_arity rhs
| otherwise
= collectAnnBndrs rhs
(env1, bndrs1) = substBndrsSL NonRecursive env bndrs
- all_bndrs = pprTrace "lvlFloatRhs" (text "abs_vars:" <+> ppr abs_vars $$ text "bndrs1:" <+> ppr bndrs1) $ abs_vars ++ bndrs1
+ all_bndrs = abs_vars ++ bndrs1
(body_env, bndrs') | Just _ <- mb_join_arity
= lvlJoinBndrs env1 dest_lvl rec all_bndrs
| otherwise
=====================================
compiler/GHC/Core/UsageEnv.hs-boot
=====================================
@@ -6,6 +6,7 @@ import {-# SOURCE #-} GHC.Core.TyCo.Rep (Mult)
data Usage -- = Zero | Bottom | MUsage Mult
data UsageEnv -- = UsageEnv !(NameEnv Mult) Bool
+zeroUE :: UsageEnv
nonDetMults :: UsageEnv -> [Mult]
mapUE :: (Mult -> Mult) -> UsageEnv -> UsageEnv
mapUEM :: Applicative m => (Mult -> m Mult) -> UsageEnv -> m UsageEnv
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -113,6 +113,7 @@ import Data.List ( sort, sortBy, partition, zipWith4, mapAccumL )
import Data.Ord ( comparing )
import qualified Data.Set as Set
import GHC.Types.RepType (isZeroBitTy)
+import GHC.Core.UsageEnv (zeroUE)
{-
************************************************************************
@@ -492,7 +493,7 @@ stripTicksT p expr = fromOL $ go expr
************************************************************************
-}
-bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
+bindNonRec :: HasCallStack => HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
-- ^ @bindNonRec x r b@ produces either:
--
-- > let x = r in b
@@ -519,8 +520,10 @@ bindNonRec bndr rhs body
| needsCaseBinding (idType bndr) rhs = pprTrace "bindNonRec:needsCaseBinding:" (ppr bndr <+> ppr (idBinding bndr)) case_bind
| otherwise = let_bind
where
- case_bind = mkDefaultCase rhs (setIdBinding bndr (maybe (LambdaBound ManyTy) LambdaBound (varMultMaybe bndr))) body -- ROMES:TODO: Explain
- let_bind = Let (NonRec 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
-- | 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"
=====================================
compiler/GHC/Hs/Utils.hs
=====================================
@@ -786,7 +786,7 @@ mkHsWrapPatCo :: TcCoercionN -> Pat GhcTc -> Type -> Pat GhcTc
mkHsWrapPatCo co pat ty | isReflCo co = pat
| otherwise = XPat $ CoPat (mkWpCastN co) pat ty
-mkHsDictLet :: TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
+mkHsDictLet :: HasCallStack => TcEvBinds -> LHsExpr GhcTc -> LHsExpr GhcTc
mkHsDictLet ev_binds expr = mkLHsWrap (mkWpLet ev_binds) expr
{-
@@ -816,10 +816,10 @@ mkTopFunBind origin fn ms = FunBind { fun_id = fn
-- binding
}
-mkHsVarBind :: SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
+mkHsVarBind :: HasCallStack => SrcSpan -> RdrName -> LHsExpr GhcPs -> LHsBind GhcPs
mkHsVarBind loc var rhs = mkSimpleGeneratedFunBind loc var [] rhs
-mkVarBind :: IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
+mkVarBind :: HasCallStack => IdP (GhcPass p) -> LHsExpr (GhcPass p) -> LHsBind (GhcPass p)
mkVarBind var rhs = L (getLoc rhs) $
VarBind { var_ext = noExtField,
var_id = var, var_rhs = rhs }
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -109,7 +109,7 @@ import Data.Traversable (for)
-}
-- | Main entry point to the desugarer.
-deSugar :: HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts)
+deSugar :: HasCallStack => HscEnv -> ModLocation -> TcGblEnv -> IO (Messages DsMessage, Maybe ModGuts)
-- Can modify PCS by faulting in more declarations
deSugar hsc_env
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -66,7 +66,7 @@ import GHC.Types.Id.Make ( nospecId )
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Types.Var( EvVar )
+import GHC.Types.Var( EvVar, isLetBinding )
import GHC.Types.SrcLoc
import GHC.Types.Basic
import GHC.Types.Unique.Set( nonDetEltsUniqSet )
@@ -94,7 +94,8 @@ import Control.Monad
-- | Desugar top level binds, strict binds are treated like normal
-- binds since there is no good time to force before first usage.
-dsTopLHsBinds :: LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
+dsTopLHsBinds :: HasCallStack
+ => LHsBinds GhcTc -> DsM (OrdList (Id,CoreExpr))
dsTopLHsBinds binds
-- see Note [Strict binds checks]
| not (isEmptyBag unlifted_binds) || not (isEmptyBag bang_binds)
@@ -122,20 +123,23 @@ dsTopLHsBinds binds
-- | Desugar all other kind of bindings, Ids of strict binds are returned to
-- later be forced in the binding group body, see Note [Desugar Strict binds]
-dsLHsBinds :: LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
+dsLHsBinds :: HasCallStack
+ => LHsBinds GhcTc -> DsM ([Id], [(Id,CoreExpr)])
dsLHsBinds binds
= do { ds_bs <- mapBagM dsLHsBind binds
; return (foldBag (\(a, a') (b, b') -> (a ++ b, a' ++ b'))
id ([], []) ds_bs) }
------------------------
-dsLHsBind :: LHsBind GhcTc
+dsLHsBind :: HasCallStack
+ => LHsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
dsLHsBind (L loc bind) = do dflags <- getDynFlags
putSrcSpanDs (locA loc) $ dsHsBind dflags bind
-- | Desugar a single binding (or group of recursive binds).
-dsHsBind :: DynFlags
+dsHsBind :: HasCallStack
+ => DynFlags
-> HsBind GhcTc
-> DsM ([Id], [(Id,CoreExpr)])
-- ^ The Ids of strict binds, to be forced in the body of the
@@ -144,6 +148,9 @@ dsHsBind :: DynFlags
dsHsBind dflags (VarBind { var_id = var
, var_rhs = expr })
+ | not (isLetBinding var)
+ = pprPanic "dsHsBind:VarBind" (ppr var <+> text " should be let bound!")
+ | otherwise
= do { core_expr <- dsLExpr expr
-- Dictionary bindings are always VarBinds,
-- so we only need do this here
@@ -157,6 +164,9 @@ dsHsBind dflags b@(FunBind { fun_id = L loc fun
, fun_matches = matches
, fun_ext = (co_fn, tick)
})
+ | not (isLetBinding fun)
+ = pprPanic "dsHsBind:FunBind" (ppr fun <+> text " should be let bound!")
+ | otherwise
= do { dsHsWrapper co_fn $ \core_wrap -> do
{ (args, body) <- addTyCs FromSource (hsWrapDictBinders co_fn) $
-- FromSource might not be accurate (we don't have any
@@ -1183,7 +1193,7 @@ dsl_coherence field of DsM's local environment.
-}
-dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
+dsHsWrapper :: HasCallStack => HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
dsHsWrapper WpHole k = k $ \e -> e
dsHsWrapper (WpTyApp ty) k = k $ \e -> App e (Type ty)
dsHsWrapper (WpEvLam ev) k = k $ Lam ev
@@ -1223,20 +1233,25 @@ dsHsWrappers (wp:wps) k = dsHsWrapper wp $ \wrap -> dsHsWrappers wps $ \wraps ->
dsHsWrappers [] k = k []
--------------------------------------
-dsTcEvBinds_s :: [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
+dsTcEvBinds_s :: HasCallStack => [TcEvBinds] -> ([CoreBind] -> DsM a) -> DsM a
dsTcEvBinds_s [] k = k []
dsTcEvBinds_s (b:rest) k = assert (null rest) $ -- Zonker ensures null
dsTcEvBinds b k
-dsTcEvBinds :: TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
-dsTcEvBinds (TcEvBinds {}) = panic "dsEvBinds" -- Zonker has got rid of this
-dsTcEvBinds (EvBinds bs) = dsEvBinds bs
+dsTcEvBinds :: HasCallStack => TcEvBinds -> ([CoreBind] -> DsM a) -> DsM a
+dsTcEvBinds (TcEvBinds {}) _ = panic "dsEvBinds" -- Zonker has got rid of this
+dsTcEvBinds (EvBinds bs) f = do
+ -- ROMES:TODO:
+ -- mapBagM (\b -> if not (isLetBinding (evBindVar b)) then pprPanic "dsTcEvBinds" (ppr $ evBindVar b) else pure ()) bs
+ dsEvBinds bs f
-- * Desugars the ev_binds, sorts them into dependency order, and
-- passes the resulting [CoreBind] to thing_inside
-- * Extends the DsM (dsl_coherence field) with coherence information
-- for each binder in ev_binds, before invoking thing_inside
-dsEvBinds :: Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
+--
+-- ROMES:TODO: Does this always result in let bindings?
+dsEvBinds :: HasCallStack => Bag EvBind -> ([CoreBind] -> DsM a) -> DsM a
dsEvBinds ev_binds thing_inside
= do { ds_binds <- mapBagM dsEvBind ev_binds
; let comps = sort_ev_binds ds_binds
=====================================
compiler/GHC/HsToCore/Binds.hs-boot
=====================================
@@ -2,5 +2,6 @@ module GHC.HsToCore.Binds where
import GHC.HsToCore.Monad ( DsM )
import GHC.Core ( CoreExpr )
import GHC.Tc.Types.Evidence (HsWrapper)
+import GHC.Stack (HasCallStack)
-dsHsWrapper :: HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
+dsHsWrapper :: HasCallStack => HsWrapper -> ((CoreExpr -> CoreExpr) -> DsM a) -> DsM a
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -76,7 +76,7 @@ import Control.Monad
************************************************************************
-}
-dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsLocalBinds :: HasCallStack => HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsLocalBinds (EmptyLocalBinds _) body = return body
dsLocalBinds b@(HsValBinds _ binds) body = putSrcSpanDs (spanHsLocaLBinds b) $
dsValBinds binds body
@@ -84,7 +84,7 @@ dsLocalBinds (HsIPBinds _ binds) body = dsIPBinds binds body
-------------------------
-- caller sets location
-dsValBinds :: HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsValBinds :: HasCallStack => HsValBinds GhcTc -> CoreExpr -> DsM CoreExpr
dsValBinds (XValBindsLR (NValBinds binds _)) body
= foldrM ds_val_bind body binds
dsValBinds (ValBinds {}) _ = panic "dsValBinds ValBindsIn"
@@ -105,7 +105,7 @@ dsIPBinds (IPBinds ev_binds ip_binds) body
-------------------------
-- caller sets location
-ds_val_bind :: (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
+ds_val_bind :: HasCallStack => (RecFlag, LHsBinds GhcTc) -> CoreExpr -> DsM CoreExpr
-- Special case for bindings which bind unlifted variables
-- We need to do a case right away, rather than building
-- a tuple and doing selections.
=====================================
compiler/GHC/HsToCore/Expr.hs-boot
=====================================
@@ -3,8 +3,9 @@ import GHC.Hs ( HsExpr, LHsExpr, HsLocalBinds, SyntaxExpr )
import GHC.HsToCore.Monad ( DsM )
import GHC.Core ( CoreExpr )
import GHC.Hs.Extension ( GhcTc)
+import GHC.Stack ( HasCallStack )
dsExpr :: HsExpr GhcTc -> DsM CoreExpr
dsLExpr :: LHsExpr GhcTc -> DsM CoreExpr
dsSyntaxExpr :: SyntaxExpr GhcTc -> [CoreExpr] -> DsM CoreExpr
-dsLocalBinds :: HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
+dsLocalBinds :: HasCallStack => HsLocalBinds GhcTc -> CoreExpr -> DsM CoreExpr
=====================================
compiler/GHC/HsToCore/GuardedRHSs.hs
=====================================
@@ -55,7 +55,7 @@ dsGuarded grhss rhs_ty rhss_nablas = do
-- In contrast, @dsGRHSs@ produces a @MatchResult CoreExpr at .
-dsGRHSs :: HsMatchContext GhcRn
+dsGRHSs :: HasCallStack => HsMatchContext GhcRn
-> GRHSs GhcTc (LHsExpr GhcTc) -- ^ Guarded RHSs
-> Type -- ^ Type of RHS
-> NonEmpty Nablas -- ^ Refined pattern match checking
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -738,7 +738,8 @@ Call @match@ with all of this information!
-- p2 q2 -> ...
matchWrapper
- :: HsMatchContext GhcRn -- ^ For shadowing warning messages
+ :: HasCallStack
+ => HsMatchContext GhcRn -- ^ For shadowing warning messages
-> Maybe [LHsExpr GhcTc] -- ^ Scrutinee(s)
-- see Note [matchWrapper scrutinees]
-> MatchGroup GhcTc (LHsExpr GhcTc) -- ^ Matches being desugared
=====================================
compiler/GHC/HsToCore/Match.hs-boot
=====================================
@@ -16,7 +16,8 @@ match :: HasCallStack => [Id]
-> DsM (MatchResult CoreExpr)
matchWrapper
- :: HsMatchContext GhcRn
+ :: HasCallStack
+ => HsMatchContext GhcRn
-> Maybe [LHsExpr GhcTc]
-> MatchGroup GhcTc (LHsExpr GhcTc)
-> DsM ([Id], CoreExpr)
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -92,6 +92,8 @@ import Data.List.NonEmpty (NonEmpty(..))
import Data.Maybe (maybeToList)
import qualified Data.List.NonEmpty as NEL
+import GHC.Core.UsageEnv (zeroUE)
+
{-
************************************************************************
* *
@@ -378,7 +380,7 @@ mkDataConCase var ty alts@(alt1 :| _)
, alt_result = match_result } =
flip adjustMatchResultDs match_result $ \body -> do
case dataConBoxer con of
- Nothing -> pprTrace "mk_alt" (ppr (map (\x -> (idBinding x, x)) args)) $ return (Alt (DataAlt con) args body)
+ Nothing -> pprTrace "mk_alt" (hsep (map pprIdWithBinding args)) $ return (Alt (DataAlt con) args body)
Just (DCB boxer) -> do
us <- newUniqueSupply
let (rep_ids, binds) = initUs_ us (boxer ty_args args)
@@ -923,7 +925,7 @@ mkFailurePair :: CoreExpr -- Result type of the whole case expression
CoreExpr) -- Fail variable applied to realWorld#
-- See Note [Failure thunks and CPR]
mkFailurePair expr
- = do { fail_fun_var <- newFailLocalDs (LambdaBound ManyTy) (unboxedUnitTy `mkVisFunTyMany` ty) -- ROMES:TODO: Failure pair LambdaBound?
+ = do { fail_fun_var <- newFailLocalDs (LetBound zeroUE) (unboxedUnitTy `mkVisFunTyMany` ty)
; fail_fun_arg <- newSysLocalDs (LambdaBound ManyTy) unboxedUnitTy
; let real_arg = setOneShotLambda fail_fun_arg
; return (NonRec fail_fun_var (Lam real_arg expr),
=====================================
compiler/GHC/Tc/Gen/Sig.hs
=====================================
@@ -75,6 +75,7 @@ import GHC.Data.Maybe( orElse, whenIsJust )
import Data.Maybe( mapMaybe )
import qualified Data.List.NonEmpty as NE
import Control.Monad( unless )
+import GHC.Core.UsageEnv (zeroUE)
{- -------------------------------------------------------------
@@ -231,7 +232,10 @@ tcUserTypeSig loc hs_sig_ty mb_name
= do { sigma_ty <- tcHsSigWcType ctxt_no_rrc hs_sig_ty
; traceTc "tcuser" (ppr sigma_ty)
; return $
- CompleteSig { sig_bndr = mkLocalId name (LambdaBound ManyTy) sigma_ty -- ROMES:TODO: LambdaBound?
+ -- Romes: If this identifier gets bound, it is a
+ -- top-level let binder with a closed usage
+ -- env.
+ CompleteSig { sig_bndr = mkLocalId name (LetBound zeroUE) sigma_ty
-- We use `Many' as the multiplicity here,
-- as if this identifier corresponds to
-- anything, it is a top-level
=====================================
compiler/GHC/Tc/Instance/Typeable.hs
=====================================
@@ -37,7 +37,7 @@ import GHC.Unit.Module
import GHC.Hs
import GHC.Driver.Session
import GHC.Data.Bag
-import GHC.Types.Var ( VarBndr(..) )
+import GHC.Types.Var ( VarBndr(..), pprIdWithBinding )
import GHC.Core.Map.Type
import GHC.Settings.Constants
import GHC.Utils.Fingerprint(Fingerprint(..), fingerprintString, fingerprintFingerprints)
@@ -49,6 +49,9 @@ import Control.Monad.Trans.State.Strict
import Control.Monad.Trans.Class (lift)
import Data.Maybe ( isJust )
+import GHC.Core.UsageEnv (zeroUE)
+import GHC.Stack ( HasCallStack )
+
{- Note [Grand plan for Typeable]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The overall plan is this:
@@ -273,7 +276,7 @@ todoForExportedKindReps kinds = do
return $ ExportedKindRepsTodo $ map mkId kinds
-- | Generate TyCon bindings for a set of type constructors
-mkTypeRepTodoBinds :: [TypeRepTodo] -> TcM TcGblEnv
+mkTypeRepTodoBinds :: HasCallStack => [TypeRepTodo] -> TcM TcGblEnv
mkTypeRepTodoBinds [] = getGblEnv
mkTypeRepTodoBinds todos
= do { stuff <- collect_stuff
@@ -417,7 +420,7 @@ mkTrNameLit = do
return trNameLit
-- | Make Typeable bindings for the given 'TyCon'.
-mkTyConRepBinds :: TypeableStuff -> TypeRepTodo
+mkTyConRepBinds :: HasCallStack => TypeableStuff -> TypeRepTodo
-> TypeableTyCon -> KindRepM (LHsBinds GhcTc)
mkTyConRepBinds stuff todo (TypeableTyCon {..})
= do -- Make a KindRep
@@ -523,7 +526,7 @@ addKindRepBind in_scope k bndr rhs =
-- | Run a 'KindRepM' and add the produced 'KindRep's to the typechecking
-- environment.
-runKindRepM :: KindRepM a -> TcRn (TcGblEnv, a)
+runKindRepM :: HasCallStack => KindRepM a -> TcRn (TcGblEnv, a)
runKindRepM (KindRepM action) = do
kindRepEnv <- initialKindRepEnv
(res, reps_env) <- runStateT action kindRepEnv
@@ -552,11 +555,13 @@ getKindRep stuff@(Stuff {..}) in_scope = go
= return (nlHsVar id, env)
-- We need to construct a new KindRep binding
+ -- (Romes: This will be a top level binding, so the binding is
+ -- let-bound with a closed usage env)
| otherwise
= do -- Place a NOINLINE pragma on KindReps since they tend to be quite
-- large and bloat interface files.
rep_bndr <- (`setInlinePragma` neverInlinePragma)
- <$> newSysLocalId (fsLit "$krep") (LambdaBound ManyTy) (mkTyConTy kindRepTyCon) -- ROMES:TODO: Are these type variables? What provenance should we give them
+ <$> newSysLocalId (fsLit "$krep") (LetBound zeroUE) (mkTyConTy kindRepTyCon)
-- do we need to tie a knot here?
flip runStateT env $ unKindRepM $ do
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -2,6 +2,8 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE StandaloneDeriving #-}
module GHC.Tc.Types.Evidence (
@@ -169,13 +171,13 @@ data HsWrapper
| WpTyApp KindOrType -- [] t the 't' is a type (not coercion)
- | WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
+ | HasCallStack => WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
-- so that the identity coercion is always exactly WpHole
| WpMultCoercion Coercion -- Require that a Coercion be reflexive; otherwise,
-- error in the desugarer. See GHC.Tc.Utils.Unify
-- Note [Wrapper returned from tcSubMult]
- deriving Data.Data
+deriving instance Data.Data HsWrapper
-- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data
-- constructor, is "syntactic" and not associative. Concretely, if @a@, @b@,
@@ -261,10 +263,15 @@ mkWpTyLams ids = mk_co_lam_fn WpTyLam ids
mkWpEvLams :: [Var] -> HsWrapper
mkWpEvLams ids = mk_co_lam_fn WpEvLam ids
-mkWpLet :: TcEvBinds -> HsWrapper
+mkWpLet :: HasCallStack => TcEvBinds -> HsWrapper
-- This no-op is a quite a common case
mkWpLet (EvBinds b) | isEmptyBag b = WpHole
-mkWpLet ev_binds = WpLet ev_binds
+mkWpLet ev_binds
+ | EvBinds bs <- ev_binds
+ , anyBag (isLambdaBinding . evBindVar) bs
+ = pprPanic "mkWpEvLams" (ppr $ mapBag (pprIdWithBinding . evBindVar) bs)
+ | otherwise
+ = WpLet ev_binds
mk_co_lam_fn :: (a -> HsWrapper) -> [a] -> HsWrapper
mk_co_lam_fn f as = foldr (\x wrap -> f x <.> wrap) WpHole as
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -6,7 +6,7 @@
-}
{-# LANGUAGE FlexibleContexts, MultiWayIf, FlexibleInstances, DeriveDataTypeable,
- PatternSynonyms, BangPatterns, GADTs #-}
+ PatternSynonyms, BangPatterns, GADTs, RankNTypes #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
-- |
@@ -130,6 +130,8 @@ import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
+import {-# SOURCE #-} GHC.Core.UsageEnv (zeroUE)
+
import Data.Data
{-
@@ -273,7 +275,7 @@ data Var
realUnique :: {-# UNPACK #-} !Int,
varType :: Type,
-- ROMES:TODO: merge binding and scope?
- idBinding :: IdBinding, -- See Note [Multiplicity of let binders]
+ idBinding :: HasCallStack => IdBinding, -- See Note [Multiplicity of let binders]
idScope :: IdScope,
id_details :: IdDetails, -- Stable, doesn't change
id_info :: IdInfo } -- Unstable, updated by simplifier
@@ -286,17 +288,29 @@ data IdBinding where
-- Might no longer make sense to merge with IdScope at all
pprIdWithBinding :: Id -> SDoc
-pprIdWithBinding x = ppr x <> text "[" <> ppr (idBinding x) <> text "]"
+pprIdWithBinding x
+ | isId x
+ = ppr x <> text "[" <> ppr (idBinding x) <> text "]"
+ | otherwise
+ = ppr x <+> text "is not an Id"
isLetBinding :: Id -> Bool
-isLetBinding x = case idBinding x of
+isLetBinding x
+ | isId x
+ = case idBinding x of
LetBound _ -> True
LambdaBound _ -> False
+ | otherwise
+ = True -- ROMES:TODO: ouch
isLambdaBinding :: Id -> Bool
-isLambdaBinding x = case idBinding x of
+isLambdaBinding x
+ | isId x
+ = case idBinding x of
LetBound _ -> False
LambdaBound _ -> True
+ | otherwise
+ = True -- ROMES:TODO: ouch
{-
Note the binding sites considered in Core (see lintCoreExpr, lintIdBinder)
@@ -1177,8 +1191,8 @@ idDetails other = pprPanic "idDetails" (ppr other)
-- Ids, because "GHC.Types.Id" uses 'mkGlobalId' etc with different types
mkGlobalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalVar details name ty info
- -- ROMES: This doesn't really classify as LambdaBound, but has the semantics we want...
- = mk_id name (LambdaBound manyDataConTy) ty GlobalId details info
+ -- ROMES: A global variable is let-bound with a closed linear environment
+ = mk_id name (LetBound zeroUE) ty GlobalId details info
-- There is no support for linear global variables yet. They would require
-- being checked at link-time, which can be useful, but is not a priority.
@@ -1194,8 +1208,8 @@ mkCoVar name ty = mk_id name (LambdaBound manyDataConTy) ty (LocalId NotExported
-- | Exported 'Var's will not be removed as dead code
mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
mkExportedLocalVar details name ty info
- -- ROMES:TODO: As in mkGlobalVar, this isn't really LambdaBound I figure
- = mk_id name (LambdaBound manyDataConTy) ty (LocalId Exported) details info
+ -- ROMES: Exported variables are as global bound, let-bound with a closed usage env
+ = mk_id name (LetBound zeroUE) ty (LocalId Exported) details info
-- There is no support for exporting linear variables. See also [mkGlobalVar]
mk_id :: Name -> IdBinding -> Type -> IdScope -> IdDetails -> IdInfo -> Id
=====================================
compiler/Language/Haskell/Syntax/Binds.hs
=====================================
@@ -2,6 +2,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE RankNTypes, ExistentialQuantification #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow]
@@ -42,6 +43,8 @@ import Data.Void
import Data.Bool
import Data.Maybe
+import GHC.Stack (HasCallStack)
+
{-
************************************************************************
* *
@@ -193,11 +196,11 @@ data HsBindLR idL idR
-- 'GHC.Parser.Annotation.AnnOpen','GHC.Parser.Annotation.AnnClose',
-- For details on above see Note [exact print annotations] in GHC.Parser.Annotation
- FunBind {
+ HasCallStack => FunBind {
fun_ext :: XFunBind idL idR,
- fun_id :: LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr
+ fun_id :: HasCallStack => LIdP idL, -- Note [fun_id in Match] in GHC.Hs.Expr ROMES:TODO: Revive note
fun_matches :: MatchGroup idR (LHsExpr idR) -- ^ The payload
@@ -226,9 +229,9 @@ data HsBindLR idL idR
--
-- Dictionary binding and suchlike.
-- All VarBinds are introduced by the type checker
- | VarBind {
+ | HasCallStack => VarBind {
var_ext :: XVarBind idL idR,
- var_id :: IdP idL,
+ var_id :: HasCallStack => IdP idL,
var_rhs :: LHsExpr idR -- ^ Located only for consistency
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d180bbb41c0df7f0bdc2596ede7ea28d46b8307
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6d180bbb41c0df7f0bdc2596ede7ea28d46b8307
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/20230524/43999040/attachment-0001.html>
More information about the ghc-commits
mailing list