[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