[Git][ghc/ghc][wip/romes/linear-core] ROMES: WIP improvements
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Tue May 9 23:30:34 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/linear-core at Glasgow Haskell Compiler / GHC
Commits:
070f7fc1 by Rodrigo Mesquita at 2023-05-10T00:29:24+01:00
ROMES: WIP improvements
In particular, we note that in dsUnliftedBind we pass to matchEquations
variables which were let bound, which get further down the line used in
matchOneConLike (and in bindNonRec too) as case-pattern bound variables!
In this situation, where we use originally let-bound variables as case
bound variables, we must ensure the case bound variables are set to be
`LambdaBound` with the correct multiplicity (which should be some mix of
scaling with the constructor annotated multiplicities)
TODO: The multiplicity corresponding to the constructor multiplicity
scaled by ...
This broke through one more wall in the compilation of stage1 caused by
incorrect provenences (well, really, by variables being moved around
binding types while the provenence isn't updated)
- - - - -
19 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Tidy.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match.hs-boot
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/HsToCore/Utils.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Gen/Match.hs-boot
- compiler/GHC/Tc/Gen/Pat.hs
- compiler/GHC/Tc/Solver.hs
- compiler/GHC/Types/Id.hs
- compiler/GHC/Types/Var.hs
- compiler/GHC/Utils/Outputable.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -6,6 +6,7 @@
{-# LANGUAGE DeriveDataTypeable, FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE BangPatterns #-}
+{-# LANGUAGE GADTs, StandaloneDeriving #-}
-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection
module GHC.Core (
@@ -270,9 +271,12 @@ type Arg b = Expr b
-- If you edit this type, you may need to update the GHC formalism
-- See Note [GHC Formalism] in GHC.Core.Lint
-data Alt b
- = Alt AltCon [b] (Expr b)
- deriving (Data)
+-- data Alt b
+-- = Alt AltCon [b] (Expr b)
+-- deriving (Data)
+data Alt b where
+ Alt :: HasCallStack => AltCon -> [b] -> (Expr b) -> Alt b
+deriving instance Data b => Data (Alt b)
-- | A case alternative constructor (i.e. pattern match)
@@ -2204,7 +2208,7 @@ data AnnExpr' bndr annot
| AnnCoercion Coercion
-- | A clone of the 'Alt' type but allowing annotation at every tree node
-data AnnAlt bndr annot = AnnAlt AltCon [bndr] (AnnExpr bndr annot)
+data AnnAlt bndr annot = HasCallStack => AnnAlt AltCon [bndr] (AnnExpr bndr annot)
-- | A clone of the 'Bind' type but allowing annotation at every tree node
data AnnBind bndr annot
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -1693,7 +1693,7 @@ lintIdBndr top_lvl bind_site id thing_inside
-- Check that the binding site matches the binding provenance of the id
-- (we do this regardless of -dlinear-core-lint as it should always be true?)
; checkL (matchesBindingSite (idBinding id) bind_site)
- (text "Core Id binding doesn't match binding site" <+> ppr (idBinding id) <+> ppr bind_site)
+ (text "Core Id binding doesn't match binding site" <+> ppr (idBinding id) <+> text (show bind_site))
-- Check that if the binder is nested, it is not marked as exported
; checkL (not (isExportedId id) || is_top_lvl)
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -1,5 +1,7 @@
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
+{-# LANGUAGE GADTs #-}
+
-- | Handy functions for creating much Core syntax
module GHC.Core.Make (
-- * Constructing normal syntax
@@ -732,7 +734,7 @@ mkSmallTupleCase vars body scrut_var scrut
data FloatBind
= FloatLet CoreBind
- | FloatCase CoreExpr Id AltCon [Var]
+ | HasCallStack => FloatCase CoreExpr Id AltCon [Var]
-- case e of y { C ys -> ... }
-- See Note [Floating single-alternative cases] in GHC.Core.Opt.SetLevels
@@ -741,7 +743,7 @@ instance Outputable FloatBind where
ppr (FloatCase e b c bs) = hang (text "CASE" <+> ppr e <+> text "of" <+> ppr b)
2 (ppr c <+> ppr bs)
-wrapFloat :: FloatBind -> CoreExpr -> CoreExpr
+wrapFloat :: HasCallStack => FloatBind -> CoreExpr -> CoreExpr
wrapFloat (FloatLet defns) body = Let defns body
wrapFloat (FloatCase e b con bs) body = mkSingleAltCase e b con bs body
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -41,11 +41,10 @@ import GHC.Utils.Outputable
import Data.List ( mapAccumL )
-{-
+{- |
Top-level interface function, @floatInwards at . Note that we do not
actually float any bindings downwards from the top-level.
-}
-
floatInwards :: Platform -> CoreProgram -> CoreProgram
floatInwards platform binds = map (fi_top_bind platform) binds
where
@@ -144,7 +143,7 @@ instance Outputable FloatInBind where
ppr (FB bvs fvs _) = text "FB" <> braces (sep [ text "bndrs =" <+> ppr bvs
, text "fvs =" <+> ppr fvs ])
-fiExpr :: Platform
+fiExpr :: HasCallStack => Platform
-> RevFloatInBinds -- Binds we're trying to drop
-- as far "inwards" as possible
-> CoreExprWithFVs -- Input expr
@@ -806,7 +805,7 @@ floatedBindsFVs binds = mapUnionDVarSet fbFVs binds
fbFVs :: FloatInBind -> DVarSet
fbFVs (FB _ fvs _) = fvs
-wrapFloats :: RevFloatInBinds -> CoreExpr -> CoreExpr
+wrapFloats :: HasCallStack => RevFloatInBinds -> CoreExpr -> CoreExpr
-- Remember RevFloatInBinds is in *reverse* dependency order
wrapFloats [] e = e
wrapFloats (FB _ _ fl : bs) e = wrapFloats bs (wrapFloat fl e)
=====================================
compiler/GHC/Core/Tidy.hs
=====================================
@@ -229,8 +229,9 @@ tidyExpr env (Lam b e)
------------ Case alternatives --------------
tidyAlt :: TidyEnv -> CoreAlt -> CoreAlt
-tidyAlt env (Alt con vs rhs)
- = tidyBndrs env vs =: \ (env', vs) ->
+tidyAlt env a@(Alt con vs rhs)
+ = pprTrace "tidyAlt" (ppr a $$ ppr (map (\x -> (idBinding x, x)) vs) $$ callStackDoc) $
+ tidyBndrs env vs =: \ (env', vs) ->
(Alt con vs (tidyExpr env' rhs))
------------ Tickish --------------
@@ -277,16 +278,16 @@ tidyVarOcc :: TidyEnv -> Var -> Var
tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
-- tidyBndr is used for lambda and case binders
-tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
+tidyBndr :: HasCallStack => TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr env var
| isTyCoVar var = tidyVarBndr env var
| otherwise = tidyIdBndr env var
-tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
+tidyBndrs :: HasCallStack => TidyEnv -> [Var] -> (TidyEnv, [Var])
tidyBndrs env vars = mapAccumL tidyBndr env vars
-- Non-top-level variables, not covars
-tidyIdBndr :: TidyEnv -> Id -> (TidyEnv, Id)
+tidyIdBndr :: HasCallStack => TidyEnv -> Id -> (TidyEnv, Id)
tidyIdBndr env@(tidy_env, var_env) id
= -- Do this pattern match strictly, otherwise we end up holding on to
-- stuff in the OccName.
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -507,6 +507,10 @@ bindNonRec :: HasDebugCallStack => Id -> CoreExpr -> CoreExpr -> CoreExpr
-- that give Core Lint a heart attack, although actually
-- the simplifier deals with them perfectly well. See
-- also 'GHC.Core.Make.mkCoreLet'
+--
+-- We must be careful about the idBinding of the binder. If we make the let
+-- binder into a case binder, we must update the idBinding to reflect that,
+-- since it must change from LetBound to CaseBound
bindNonRec bndr rhs body
| isTyVar bndr = let_bind
| isCoVar bndr = if isCoArg rhs then let_bind
@@ -515,7 +519,7 @@ 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 (LambdaBound ManyTy)) body
+ case_bind = mkDefaultCase rhs (setIdBinding bndr (maybe (LambdaBound ManyTy) LambdaBound (varMultMaybe bndr))) body -- ROMES:TODO: Explain
let_bind = Let (NonRec bndr rhs) body
-- | Tests whether we have to use a @case@ rather than @let@ binding for this
@@ -543,11 +547,10 @@ mkAltExpr DEFAULT _ _ = panic "mkAltExpr DEFAULT"
mkDefaultCase :: CoreExpr -> Id -> CoreExpr -> CoreExpr
-- Make (case x of y { DEFAULT -> e }
mkDefaultCase scrut case_bndr body
- = pprTrace "mkDefaultCase bndr is LambdaBound?" (ppr $ isJust (varMultMaybe case_bndr)) $
- assertPpr (isJust (varMultMaybe case_bndr)) (text "mkDefaultCase:Case binder is marked LetBound!") $
+ = assertPpr (isJust (varMultMaybe case_bndr)) (text "mkDefaultCase:Case binder is marked LetBound!") $
Case scrut case_bndr (exprType body) [Alt DEFAULT [] body]
-mkSingleAltCase :: CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr
+mkSingleAltCase :: HasCallStack => CoreExpr -> Id -> AltCon -> [Var] -> CoreExpr -> CoreExpr
-- Use this function if possible, when building a case,
-- because it ensures that the type on the Case itself
-- doesn't mention variables bound by the case
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -197,19 +197,26 @@ dsUnliftedBind (FunBind { fun_id = L l fun
{ let rhs' = core_wrap (mkOptTickBox tick rhs)
; return (bindNonRec fun rhs' body) } }
-dsUnliftedBind (PatBind { pat_lhs = pat, pat_rhs = grhss
+dsUnliftedBind p@(PatBind { pat_lhs = pat, pat_rhs = grhss
, pat_ext = (ty, _) }) body
= -- let C x# y# = rhs in body
-- ==> case rhs of C x# y# -> body
do { match_nablas <- pmcGRHSs PatBindGuards grhss
; rhs <- dsGuarded grhss ty match_nablas
; let upat = unLoc pat
- eqn = EqnInfo { eqn_pats = [upat],
+ eqn = pprTrace "dsUnliftedBind" (ppr p $$ ppr upat) $ EqnInfo { eqn_pats = [upat],
eqn_orig = FromSource,
eqn_rhs = cantFailMatchResult body }
; var <- selectMatchVar ManyTy upat
-- `var` will end up in a let binder, so the multiplicity
-- doesn't matter.
+ --
+ -- romes: Why in a let binder? Sometimes it will end up in a
+ -- case binder (see bindNonRec and matchOneConLike).
+
+ -- ROMES:TODO: I will need to make this correct here... this transformation seems suspicious
+ -- Matching will turn a group of equations and matching ids into a group of case expressions?
+ -- It seems really weird for the eqn to have let bound variables, if they're patterns...?
; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
; return (bindNonRec var rhs result) }
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -85,7 +85,7 @@ import qualified Data.Map as Map
************************************************************************
The function @match@ is basically the same as in the Wadler chapter
-from "The Implementation of Functional Programming Languages",
+from "The Implementation of Functional Programming Languages" (Chapter 5),
except it is monadised, to carry around the name supply, info about
annotations, etc.
@@ -180,7 +180,8 @@ See also Note [Localise pattern binders] in GHC.HsToCore.Utils
type MatchId = Id -- See Note [Match Ids]
-match :: [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
+-- | Described by the comment block above
+match :: HasCallStack => [MatchId] -- ^ Variables rep\'ing the exprs we\'re matching with
-- ^ See Note [Match Ids]
--
-- ^ Note that the Match Ids carry not only a name, but
@@ -824,7 +825,22 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
$ replicate (length (grhssGRHSs m)) initNablas
-matchEquations :: HsMatchContext GhcRn
+-- | Matching will turn a group of pattern-matching equations and MatchId's
+-- into a group of case expressions
+--
+-- For example:
+--
+-- mappairs f [] ys = []
+-- mappairs f (x:xs) [] = []
+-- mappairs f (x:xs) (y:ys) = f x y : mappairs f xs ys
+-- ==>
+-- mappairs = \f -> \xs' -> \ys' ->
+-- case xs' of
+-- [] -> []
+-- (x:xs) -> case ys' of
+-- [] -> []
+-- (y:ys) -> f x y : mappairs f xs ys
+matchEquations :: HasCallStack => HsMatchContext GhcRn
-> [MatchId] -> [EquationInfo] -> Type
-> DsM CoreExpr
matchEquations ctxt vars eqns_info rhs_ty
=====================================
compiler/GHC/HsToCore/Match.hs-boot
=====================================
@@ -8,7 +8,9 @@ import GHC.Core ( CoreExpr )
import GHC.Hs ( LPat, HsMatchContext, MatchGroup, LHsExpr )
import GHC.Hs.Extension ( GhcTc, GhcRn )
-match :: [Id]
+import GHC.Stack (HasCallStack)
+
+match :: HasCallStack => [Id]
-> Type
-> [EquationInfo]
-> DsM (MatchResult CoreExpr)
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -29,6 +29,7 @@ import GHC.Core ( CoreExpr )
import GHC.Core.Make ( mkCoreLets )
import GHC.Utils.Misc
import GHC.Types.Id
+import GHC.Types.Var (pprIdWithBinding)
import GHC.Types.Name.Env
import GHC.Types.FieldLabel ( flSelector )
import GHC.Types.SrcLoc
@@ -92,7 +93,7 @@ have-we-used-all-the-constructors? question; the local function
@match_cons_used@ does all the real work.
-}
-matchConFamily :: NonEmpty Id
+matchConFamily :: HasCallStack => NonEmpty Id
-> Type
-> NonEmpty (NonEmpty EquationInfo)
-> DsM (MatchResult CoreExpr)
@@ -126,7 +127,7 @@ matchPatSyn (var :| vars) ty eqns
type ConArgPats = HsConPatDetails GhcTc
-matchOneConLike :: [Id]
+matchOneConLike :: HasCallStack => [Id]
-> Type
-> Mult
-> NonEmpty EquationInfo
@@ -190,8 +191,16 @@ matchOneConLike vars ty mult (eqn1 :| eqns) -- All eqns for a single construct
; match_results <- mapM (match_group arg_vars) groups
+ ; pprTraceM "matchOneConLike" (text "Dicts:" <+> ppr (map pprIdWithBinding dicts1) $$ text "Args:" <+> ppr (map pprIdWithBinding arg_vars))
+ -- ROMES:TODO: Understand better if we could determine this elsewhere, but:
+ --
+ -- The provenence of the variables put in the alt_bndrs is not
+ -- necessarily correct, as it may come from a variable which was
+ -- originally let bound and will now be lambda bound.
+ -- See comments in dsUnliftedBind too.
+ ; let arg_vars' = map (const $ setIdBinding (LambdaBound ManyTy)) arg_vars -- ROMES:TODO: Not ManyTy!! It depends on the constructor!
; return $ MkCaseAlt{ alt_pat = con1,
- alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
+ alt_bndrs = tvs1 ++ dicts1 ++ arg_vars', -- these arg_vars contain variables that were originally let bound
alt_wrapper = wrapper1,
alt_result = foldr1 combineMatchResults match_results } }
where
@@ -243,12 +252,12 @@ same_fields flds1 flds2
-----------------
-selectConMatchVars :: [Scaled Type] -> ConArgPats -> DsM [Id]
+selectConMatchVars :: HasCallStack => [Scaled Type] -> ConArgPats -> DsM [Id]
selectConMatchVars arg_tys con
= case con of
RecCon {} -> newSysLocalsDs arg_tys
- PrefixCon _ ps -> selectMatchVars (zipMults arg_tys ps)
- InfixCon p1 p2 -> selectMatchVars (zipMults arg_tys [p1, p2])
+ PrefixCon _ ps -> pprTrace "selectConMatchVars:InfixCon" (ppr ps) $ selectMatchVars (zipMults arg_tys ps)
+ InfixCon p1 p2 -> pprTrace "selectConMatchVars:InfixCon" (ppr p1 <+> ppr p2) $ selectMatchVars (zipMults arg_tys [p1, p2])
where
zipMults = zipWithEqual "selectConMatchVar" (\a b -> (scaledMult a, unLoc b))
=====================================
compiler/GHC/HsToCore/Utils.hs
=====================================
@@ -1,6 +1,7 @@
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE GADTs #-}
{-
(c) The University of Glasgow 2006
@@ -60,6 +61,7 @@ import GHC.Core.Utils
import GHC.Core.Make
import GHC.Types.Id.Make
import GHC.Types.Id
+import GHC.Types.Var (pprIdWithBinding)
import GHC.Types.Literal
import GHC.Core.TyCon
import GHC.Core.DataCon
@@ -124,16 +126,16 @@ selectSimpleMatchVarL w pat = selectMatchVar w (unLoc pat)
-- Then we must not choose (x::Int) as the matching variable!
-- And nowadays we won't, because the (x::Int) will be wrapped in a CoPat
-selectMatchVars :: [(Mult, Pat GhcTc)] -> DsM [Id]
+selectMatchVars :: HasCallStack => [(Mult, Pat GhcTc)] -> DsM [Id]
-- Postcondition: the returned Ids have Internal Names
selectMatchVars ps = mapM (uncurry selectMatchVar) ps
-selectMatchVar :: Mult -> Pat GhcTc -> DsM Id
+selectMatchVar :: HasCallStack => Mult -> Pat GhcTc -> DsM Id
-- Postcondition: the returned Id has an Internal Name
selectMatchVar w (BangPat _ pat) = selectMatchVar w (unLoc pat)
selectMatchVar w (LazyPat _ pat) = selectMatchVar w (unLoc pat)
selectMatchVar w (ParPat _ _ pat _) = selectMatchVar w (unLoc pat)
-selectMatchVar _w (VarPat _ var) = return (localiseId (unLoc var))
+selectMatchVar _w (VarPat _ var) = pprTrace "selectMatchVar:VarPat" (pprIdWithBinding (unLoc var)) $ return (localiseId (unLoc var))
-- Note [Localise pattern binders]
--
-- Remark: when the pattern is a variable (or
@@ -284,7 +286,7 @@ mkCoPrimCaseMatchResult var ty match_alts
do body <- runMatchResult fail mr
return (Alt (LitAlt lit) [] body)
-data CaseAlt a = MkCaseAlt{ alt_pat :: a,
+data CaseAlt a = HasCallStack => MkCaseAlt{ alt_pat :: a,
alt_bndrs :: [Var],
alt_wrapper :: HsWrapper,
alt_result :: MatchResult CoreExpr }
@@ -367,7 +369,7 @@ mkDataConCase var ty alts@(alt1 :| _)
, alt_result = match_result } =
flip adjustMatchResultDs match_result $ \body -> do
case dataConBoxer con of
- Nothing -> return (Alt (DataAlt con) args body)
+ Nothing -> pprTrace "mk_alt" (ppr (map (\x -> (idBinding x, x)) args)) $ return (Alt (DataAlt con) args body)
Just (DCB boxer) -> do
us <- newUniqueSupply
let (rep_ids, binds) = initUs_ us (boxer ty_args args)
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -253,8 +253,9 @@ tcLocalBinds (EmptyLocalBinds x) thing_inside
= do { thing <- thing_inside
; return (EmptyLocalBinds x, thing) }
-tcLocalBinds (HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
- = do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
+tcLocalBinds h@(HsValBinds x (XValBindsLR (NValBinds binds sigs))) thing_inside
+ = pprTrace "tcLocalBinds:HsValBinds" (ppr h) $
+ do { (binds', thing) <- tcValBinds NotTopLevel binds sigs thing_inside
; return (HsValBinds x (XValBindsLR (NValBinds binds' sigs)), thing) }
tcLocalBinds (HsValBinds _ (ValBinds {})) _ = panic "tcLocalBinds"
@@ -434,6 +435,7 @@ recursivePatSynErr
recursivePatSynErr loc binds
= failAt loc $ TcRnRecursivePatternSynonym binds
+-- | ROMES:TODO: Document
tc_single :: forall thing. HasCallStack =>
TopLevelFlag -> TcSigFun -> TcPragEnv
-> LHsBind GhcRn -> IsGroupClosed -> TcM thing
@@ -704,6 +706,7 @@ it's all cool; each signature has distinct type variables from the renamer.)
* *
********************************************************************* -}
+-- | ROMES:TODO: Document...
tcPolyInfer
:: HasCallStack => RecFlag -- Whether it's recursive after breaking
-- dependencies based on type signatures
@@ -711,7 +714,8 @@ tcPolyInfer
-> [LHsBind GhcRn]
-> TcM (LHsBinds GhcTc, [TcId])
tcPolyInfer rec_tc prag_fn tc_sig_fn bind_list
- = do { (tclvl, wanted, (binds', mono_infos))
+ = pprTrace "tcPolyInfer" (ppr bind_list) $
+ do { (tclvl, wanted, (binds', mono_infos))
<- pushLevelAndCaptureConstraints $
tcMonoBinds rec_tc tc_sig_fn LetLclBndr bind_list
@@ -1695,6 +1699,7 @@ We typecheck pattern bindings as follows. First tcLhs does this:
Result: the type of the binder is always at pc_lvl. This is
crucial.
+ ROMES:TODO: Update note, they're not all let bound, for our definition of let bound
4. Throughout, when we are making up an Id for the pattern-bound variables
(newLetBndr), we have two cases:
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -94,7 +94,7 @@ is used in error messages. It checks that all the equations have the
same number of arguments before using @tcMatches@ to do the work.
-}
-tcMatchesFun :: LocatedN Name -- MatchContext Id
+tcMatchesFun :: HasCallStack => LocatedN Name -- MatchContext Id
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpRhoType -- Expected type of function
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
@@ -209,7 +209,7 @@ type AnnoBody body
)
-- | Type-check a MatchGroup.
-tcMatches :: (AnnoBody body ) => TcMatchCtxt body
+tcMatches :: HasCallStack => (AnnoBody body ) => TcMatchCtxt body
-> [Scaled ExpSigmaTypeFRR] -- ^ Expected pattern types.
-> ExpRhoType -- ^ Expected result-type of the Match.
-> MatchGroup GhcRn (LocatedA (body GhcRn))
@@ -239,7 +239,7 @@ tcMatches ctxt pat_tys rhs_ty (MG { mg_alts = L l matches
}) }
-------------
-tcMatch :: (AnnoBody body) => TcMatchCtxt body
+tcMatch :: HasCallStack => (AnnoBody body) => TcMatchCtxt body
-> [Scaled ExpSigmaType] -- Expected pattern types
-> ExpRhoType -- Expected result-type of the Match.
-> LMatch GhcRn (LocatedA (body GhcRn))
@@ -265,7 +265,7 @@ tcMatch ctxt pat_tys rhs_ty match
_ -> addErrCtxt (pprMatchInCtxt match) thing_inside
-------------
-tcGRHSs :: AnnoBody body
+tcGRHSs :: HasCallStack => AnnoBody body
=> TcMatchCtxt body -> GRHSs GhcRn (LocatedA (body GhcRn)) -> ExpRhoType
-> TcM (GRHSs GhcTc (LocatedA (body GhcTc)))
=====================================
compiler/GHC/Tc/Gen/Match.hs-boot
=====================================
@@ -7,11 +7,13 @@ import GHC.Hs.Extension ( GhcRn, GhcTc )
import GHC.Parser.Annotation ( LocatedN )
import GHC.Types.Name (Name)
+import GHC.Stack
+
tcGRHSsPat :: GRHSs GhcRn (LHsExpr GhcRn)
-> ExpRhoType
-> TcM (GRHSs GhcTc (LHsExpr GhcTc))
-tcMatchesFun :: LocatedN Name
+tcMatchesFun :: HasCallStack => LocatedN Name
-> MatchGroup GhcRn (LHsExpr GhcRn)
-> ExpSigmaType
-> TcM (HsWrapper, MatchGroup GhcTc (LHsExpr GhcTc))
=====================================
compiler/GHC/Tc/Gen/Pat.hs
=====================================
@@ -87,7 +87,11 @@ import Data.List( partition )
************************************************************************
-}
-tcLetPat :: (Name -> Maybe TcId)
+-- The issue being we're incorrectly calling tcLetPat for case bound variables...
+-- ROMES:TODO:! Document that we don't consider case binder variables to be Let
+-- bound, we consider them lambda bound, or Case bound. (this is also in the
+-- definition of PatCtxt)
+tcLetPat :: HasCallStack => (Name -> Maybe TcId)
-> LetBndrSpec
-> LPat GhcRn -> Scaled ExpSigmaTypeFRR
-> TcM a
@@ -104,7 +108,7 @@ tcLetPat sig_fn no_gen pat pat_ty thing_inside
; tc_lpat pat_ty penv pat thing_inside }
-----------------
-tcPats :: HsMatchContext GhcTc
+tcPats :: HasCallStack => HsMatchContext GhcTc
-> [LPat GhcRn] -- ^ atterns
-> [Scaled ExpSigmaTypeFRR] -- ^ types of the patterns
-> TcM a -- ^ checker for the body
@@ -212,7 +216,7 @@ inPatBind (PE { pe_ctxt = LamPat {} }) = False
* *
********************************************************************* -}
-tcPatBndr :: PatEnv -> Name -> Scaled ExpSigmaTypeFRR -> TcM (HsWrapper, TcId)
+tcPatBndr :: HasCallStack => PatEnv -> Name -> Scaled ExpSigmaTypeFRR -> TcM (HsWrapper, TcId)
-- (coi, xp) = tcPatBndr penv x pat_ty
-- Then coi : pat_ty ~ typeof(xp)
--
@@ -239,7 +243,8 @@ tcPatBndr penv@(PE { pe_ctxt = LetPat { pc_lvl = bind_lvl
do { bndr_ty <- inferResultToType infer_res
; return (mkNomReflCo bndr_ty, bndr_ty) }
; let bndr_mult = scaledMult exp_pat_ty
- ; bndr_id <- newLetBndr no_gen bndr_name (unitUE bndr_name bndr_mult) bndr_ty -- ROMES:TODO: Likely incorrect
+ -- ; massert (isOneTy bndr_mult) -- ROMES:It's not necessary, it's just that we won't add it to the usage environment in case it is ManyTy. Do this in a helper UsageEnv "builder"
+ ; bndr_id <- newLetBndr no_gen bndr_name zeroUE bndr_ty -- ROMES:TODO: UE is incorrect here, we were previously doing unitUE bndr_name bndr_mult. What now? -- Keep zeroUE until it compiles
; traceTc "tcPatBndr(nosig)" (vcat [ ppr bind_lvl
, ppr exp_pat_ty, ppr bndr_ty, ppr co
, ppr bndr_id ])
@@ -249,7 +254,7 @@ tcPatBndr _ bndr_name pat_ty
= do { let pat_mult = scaledMult pat_ty
; pat_ty <- expTypeToType (scaledThing pat_ty)
; traceTc "tcPatBndr(not let)" (ppr bndr_name $$ ppr pat_ty)
- ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name (LambdaBound pat_mult) pat_ty) } -- ROMES:TODO: Pat Mult Lambda bound?
+ ; return (idHsWrapper, mkLocalIdOrCoVar bndr_name (LambdaBound pat_mult) pat_ty) } -- ROMES:TODO: Pat Mult Lambda bound, rather should really be binder of binding Pattern? PatCtxt agrees this is LambdaBound
-- We should not have "OrCoVar" here, this is a bug (#17545)
-- Whether or not there is a sig is irrelevant,
-- as this is local
@@ -344,7 +349,7 @@ tcMultiple tc_pat penv args thing_inside
; loop penv args }
--------------------
-tc_lpat :: Scaled ExpSigmaTypeFRR
+tc_lpat :: HasCallStack => Scaled ExpSigmaTypeFRR
-> Checker (LPat GhcRn) (LPat GhcTc)
tc_lpat pat_ty penv (L span pat) thing_inside
= setSrcSpanA span $
@@ -352,7 +357,7 @@ tc_lpat pat_ty penv (L span pat) thing_inside
thing_inside
; return (L span pat', res) }
-tc_lpats :: [Scaled ExpSigmaTypeFRR]
+tc_lpats :: HasCallStack => [Scaled ExpSigmaTypeFRR]
-> Checker [LPat GhcRn] [LPat GhcTc]
tc_lpats tys penv pats
= assertPpr (equalLength pats tys) (ppr pats $$ ppr tys) $
@@ -365,7 +370,7 @@ tc_lpats tys penv pats
checkManyPattern :: Scaled a -> TcM HsWrapper
checkManyPattern pat_ty = tcSubMult NonLinearPatternOrigin ManyTy (scaledMult pat_ty)
-tc_pat :: Scaled ExpSigmaTypeFRR
+tc_pat :: HasCallStack => Scaled ExpSigmaTypeFRR
-- ^ Fully refined result type
-> Checker (Pat GhcRn) (Pat GhcTc)
-- ^ Translated pattern
=====================================
compiler/GHC/Tc/Solver.hs
=====================================
@@ -637,7 +637,7 @@ unsatisfiableEvExpr (unsat_ev, given_msg) wtd_ty
BI_Box { bi_data_con = mkDictBox } -> mkDictBox
_ -> pprPanic "unsatisfiableEvExpr: no DictBox!" (ppr wtd_ty)
dictBox = dataConTyCon mkDictBox
- ; ev_bndr <- mkSysLocalM (fsLit "ct") ManyTy fun_ty
+ ; ev_bndr <- mkSysLocalM (fsLit "ct") (LambdaBound ManyTy) fun_ty
-- Dict ((##) -=> wtd_ty)
; let scrut_ty = mkTyConApp dictBox [fun_ty]
-- unsatisfiable @{LiftedRep} @given_msg @(Dict ((##) -=> wtd_ty)) unsat_ev
=====================================
compiler/GHC/Types/Id.hs
=====================================
@@ -143,7 +143,7 @@ import GHC.Types.Var( Id, CoVar, JoinId,
OutId, OutVar,
idInfo, idDetails, setIdDetails, globaliseId,
isId, isLocalId, isGlobalId, isExportedId,
- setIdBinding, -- used to be setIdMult
+ setIdBinding,
updateIdTypeAndMults, updateIdTypeButNotMults, updateIdTypeAndMultsM,
IdBinding(..)
)
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -59,7 +59,7 @@ module GHC.Types.Var (
setIdExported, setIdNotExported, setIdBinding,
updateIdTypeButNotMults,
updateIdTypeAndMults, updateIdTypeAndMultsM,
- IdBinding(..), idBinding,
+ IdBinding(..), idBinding, pprIdWithBinding,
-- ** Predicates
isId, isTyVar, isTcTyVar,
@@ -283,6 +283,9 @@ data IdBinding where
-- Removed globalbinding in exchange for LetBound with zero Ue (closed top-level let bound)
-- Might no longer make sense to merge with IdScope at all
+pprIdWithBinding :: Id -> SDoc
+pprIdWithBinding x = ppr x <> text "[" <> ppr (idBinding x) <> text "]"
+
{-
Note the binding sites considered in Core (see lintCoreExpr, lintIdBinder)
data BindingSite
=====================================
compiler/GHC/Utils/Outputable.hs
=====================================
@@ -1208,7 +1208,7 @@ data BindingSite
| CaseBind -- ^ The x in case scrut of x { (y,z) -> ... }
| CasePatBind -- ^ The y,z in case scrut of x { (y,z) -> ... }
| LetBind -- ^ The x in (let x = rhs in e)
- deriving Eq
+ deriving (Eq, Show)
-- | When we print a binder, we often want to print its type too.
-- The @OutputableBndr@ class encapsulates this idea.
class Outputable a => OutputableBndr a where
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/070f7fc12fa78440bd9828633f09d234add52c7b
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/070f7fc12fa78440bd9828633f09d234add52c7b
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/20230509/961cb50d/attachment-0001.html>
More information about the ghc-commits
mailing list