Make match variables always lambda boundwip/romes/linear-core

The burning question being: Will variables selected for match
(`selectMatchVar`) always be bound in case patterns?

9 files changed, 66 insertions, 20 deletions

diff --git a/compiler/GHC/Core/Make.hs b/compiler/GHC/Core/Make.hs
index 3bf58dcd55..5984992b31 100644
--- a/compiler/GHC/Core/Make.hs
+++ b/compiler/GHC/Core/Make.hs
@@ -182,7 +182,7 @@ mkCoreAppTyped d (fun, fun_ty) arg
 --
 -- See Note [WildCard binders] in "GHC.Core.Opt.Simplify.Env"
 mkWildValBinder :: Mult -> Type -> Id
-mkWildValBinder w ty = mkLocalIdOrCoVar wildCardName (LambdaBound w) ty -- ROMES: for now we consider wildcards to be lambdabound
+mkWildValBinder w ty = mkLocalIdOrCoVar wildCardName (LambdaBound w) ty -- ROMES: just tepmorarily now we consider wildcards to be lambdabound
   -- "OrCoVar" since a coercion can be a scrutinee with -fdefer-type-errors
   -- (e.g. see test T15695). Ticket #17291 covers fixing this problem.
 
diff --git a/compiler/GHC/Core/Opt/Simplify/Iteration.hs b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
index 74c3e04e82..2dcdeaa7dc 100644
--- a/compiler/GHC/Core/Opt/Simplify/Iteration.hs
+++ b/compiler/GHC/Core/Opt/Simplify/Iteration.hs
@@ -809,14 +809,14 @@ prepareRhs env top_lvl occ rhs0
 
     anfise other = return (emptyLetFloats, other)
 
-makeTrivialArg :: HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
+makeTrivialArg :: HasCallStack => HasDebugCallStack => SimplEnv -> ArgSpec -> SimplM (LetFloats, ArgSpec)
 makeTrivialArg env arg@(ValArg { as_arg = e, as_dmd = dmd })
   = do { (floats, e') <- makeTrivial env NotTopLevel dmd (fsLit "arg") e
        ; return (floats, arg { as_arg = e' }) }
 makeTrivialArg _ arg
   = return (emptyLetFloats, arg)  -- CastBy, TyArg
 
-makeTrivial :: HasDebugCallStack
+makeTrivial :: HasCallStack => HasDebugCallStack
             => SimplEnv -> TopLevelFlag -> Demand
             -> FastString  -- ^ A "friendly name" to build the new binder from
             -> OutExpr
@@ -3676,7 +3676,12 @@ mkDupableContWithDmds env _
        ; let join_body = wrapFloats floats1 join_inner
              res_ty    = contResultType cont
 
-       ; mkDupableStrictBind env bndr' join_body res_ty }
+         -- romes: The `x` becomes an arg of the join point, so it should move
+         -- from let bound to lambda bound (with which multiplicity? ROMES:TODO).
+         -- (Note [Duplicating StrictBind] explains the transformation)
+             bndr'' = bndr' `setIdBinding` LambdaBound ManyTy
+
+       ; mkDupableStrictBind env bndr'' join_body res_ty }
 
 mkDupableContWithDmds env _
     (StrictArg { sc_fun = fun, sc_cont = cont
@@ -3792,7 +3797,9 @@ mkDupableContWithDmds env _
                                       -- See Note [StaticEnv invariant] in GHC.Core.Opt.Simplify.Utils
                           , sc_cont = mkBoringStop (contResultType cont) } ) }
 
-mkDupableStrictBind :: SimplEnv -> OutId -> OutExpr -> OutType
+-- ROMES:TODO: What does this function do?
+-- Refer to Note [Dupable StrictBind]? StrictBind con?
+mkDupableStrictBind :: HasCallStack => SimplEnv -> OutId -> OutExpr -> OutType
                     -> SimplM (SimplFloats, SimplCont)
 mkDupableStrictBind env arg_bndr join_rhs res_ty
   | exprIsTrivial join_rhs   -- See point (2) of Note [Duplicating join points]
diff --git a/compiler/GHC/HsToCore/Expr.hs b/compiler/GHC/HsToCore/Expr.hs
index 06c9e32e61..0060736ab5 100644
--- a/compiler/GHC/HsToCore/Expr.hs
+++ b/compiler/GHC/HsToCore/Expr.hs
@@ -217,6 +217,12 @@ dsUnliftedBind p@(PatBind { pat_lhs = pat, pat_rhs = grhss
          -- 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...?
+         --
+         -- Should match equations ever move a let bound var into a case bound position?
+         -- If not, then it is never its responsibility to update the IdBindings
+         --
+         -- It seems in matchConFamily is where we treat C x# y# = ... ==> case rhs of C x# y# -> ..?
+       ; pprTraceM "dsUnliftedBind:eqn" (ppr var <+> ppr eqn)
        ; result <- matchEquations PatBindRhs [var] [eqn] (exprType body)
        ; return (bindNonRec var rhs result) }
 
diff --git a/compiler/GHC/HsToCore/Match.hs b/compiler/GHC/HsToCore/Match.hs
index 6b0ea1f12d..f0e2643613 100644
--- a/compiler/GHC/HsToCore/Match.hs
+++ b/compiler/GHC/HsToCore/Match.hs
@@ -371,6 +371,7 @@ 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:
@@ -825,8 +826,9 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
                       $ replicate (length (grhssGRHSs m)) initNablas
 
 
+-- No wait, doesn't seem quite right?
 -- | Matching will turn a group of pattern-matching equations and MatchId's
--- into a group of case expressions
+-- into a case expression
 --
 -- For example:
 --
@@ -840,6 +842,8 @@ matchWrapper ctxt scrs (MG { mg_alts = L _ matches
 --              (x:xs) -> case ys' of
 --                          [] -> []
 --                          (y:ys) -> f x y : mappairs f xs ys
+--
+-- See also 'match'
 matchEquations  :: HasCallStack => HsMatchContext GhcRn
                 -> [MatchId] -> [EquationInfo] -> Type
                 -> DsM CoreExpr
@@ -970,7 +974,7 @@ groupEquations :: Platform -> [EquationInfo] -> [NonEmpty (PatGroup, EquationInf
 -- (b) none of the gi are empty
 -- The ordering of equations is unchanged
 groupEquations platform eqns
-  = NEL.groupBy same_gp $ [(patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
+  = NEL.groupBy same_gp $ [pprTrace "groupEquations" (ppr (firstPat eqn)) $! (patGroup platform (firstPat eqn), eqn) | eqn <- eqns]
   -- comprehension on NonEmpty
   where
     same_gp :: (PatGroup,EquationInfo) -> (PatGroup,EquationInfo) -> Bool
diff --git a/compiler/GHC/HsToCore/Match/Constructor.hs b/compiler/GHC/HsToCore/Match/Constructor.hs
index 50127f9fe3..9ab8913099 100644
--- a/compiler/GHC/HsToCore/Match/Constructor.hs
+++ b/compiler/GHC/HsToCore/Match/Constructor.hs
@@ -93,17 +93,36 @@ have-we-used-all-the-constructors? question; the local function
 @match_cons_used@ does all the real work.
 -}
 
+-- | Turn group of equations for a single constructor into a case expression?
+--
+-- Example:
+--
+-- data T = C Int Int | D Bool
+--
+-- ROMES: Doesn't seem quite right, perhaps each group can only have 1 expr it's deconstructing?
+-- let C a b = <expr>
+--     D c   = <expr> -- not sure about this second one, I think it's wrong here, just adding it bc I'm unsure.
+--  in ...
+--
+-- ==>
+--
+-- case <expr> of
+--    C a b -> ...
+--    D c   -> ... -- not sure about this second constructor being correct 
+--
+-- Relevant notes seem to be [Match Ids] and [Localise pattern binders]
 matchConFamily :: HasCallStack => NonEmpty Id
                -> Type
                -> NonEmpty (NonEmpty EquationInfo)
                -> DsM (MatchResult CoreExpr)
 -- Each group of eqns is for a single constructor
 matchConFamily (var :| vars) ty groups
-  = do let mult = idMult var
+  = pprTrace "matchConFamily" (ppr var <+> hsep (map ppr vars) $$ ppr (map idBinding (var:vars)) $$ ppr groups) $
+    do let !mult = idMult var
            -- Each variable in the argument list correspond to one column in the
            -- pattern matching equations. Its multiplicity is the context
            -- multiplicity of the pattern. We extract that multiplicity, so that
-           -- 'matchOneconLike' knows the context multiplicity, in case it needs
+           -- 'matchOneConLike' knows the context multiplicity, in case it needs
            -- to come up with new variables.
        alts <- mapM (fmap toRealAlt . matchOneConLike vars ty mult) groups
        return (mkCoAlgCaseMatchResult var ty alts)
@@ -198,9 +217,16 @@ matchOneConLike vars ty mult (eqn1 :| eqns)   -- All eqns for a single construct
         -- 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 (`setIdBinding` (LambdaBound ManyTy)) arg_vars -- ROMES:TODO: Not ManyTy!! It depends on the constructor!
+        --
+        -- ROMES:TODO:No,! We should only set LambdaBound x if we have a
+        -- LetBound var, otherwise it already has a multiplicity? Or should we
+        -- simply recompute it completely here?
+        --
+        -- What if the only case putting us here really is dsUnliftedBind? Try to make the change there.
+        -- ; let arg_vars' = map (`setIdBinding` (LambdaBound ManyTy)) arg_vars -- ROMES:TODO: Not ManyTy!! It depends on the constructor! Don't always overwrite?
+        -- ...these arg_vars sometimes contain variables that were originally let bound, when do we make the change passing let bound variables to matchEquations? Should we always discern it here?
         ; return $ MkCaseAlt{ alt_pat = con1,
-                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars', -- these arg_vars contain variables that were originally let bound
+                              alt_bndrs = tvs1 ++ dicts1 ++ arg_vars,
                               alt_wrapper = wrapper1,
                               alt_result = foldr1 combineMatchResults match_results } }
   where
diff --git a/compiler/GHC/HsToCore/Monad.hs b/compiler/GHC/HsToCore/Monad.hs
index fcc80f8dba..811c19375a 100644
--- a/compiler/GHC/HsToCore/Monad.hs
+++ b/compiler/GHC/HsToCore/Monad.hs
@@ -395,7 +395,7 @@ newSysLocalDs = mkSysLocalM (fsLit "ds")
 newFailLocalDs = mkSysLocalM (fsLit "fail")
 
 newSysLocalsDs :: [Scaled Type] -> DsM [Id]
-newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs (LambdaBound w) t) -- Scaled -> LambdaBound
+newSysLocalsDs = mapM (\(Scaled w t) -> newSysLocalDs (LambdaBound w) t) -- Scaled -> LambdaBound?
 
 {-
 We can also reach out and either set/grab location information from
diff --git a/compiler/GHC/HsToCore/Utils.hs b/compiler/GHC/HsToCore/Utils.hs
index 0aad7eab1a..d05e3c956f 100644
--- a/compiler/GHC/HsToCore/Utils.hs
+++ b/compiler/GHC/HsToCore/Utils.hs
@@ -143,7 +143,7 @@ selectMatchVar :: HasCallStack => Mult -> Pat GhcTc -> DsM Id
 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)    = pprTrace "selectMatchVar:VarPat" (pprIdWithBinding (unLoc var)) $ return (localiseId (unLoc var))
+selectMatchVar _w (VarPat _ var)    = pprTrace "selectMatchVar:VarPat" (pprIdWithBinding (unLoc var)) $ return (localiseId ((unLoc var) `setIdBinding` (LambdaBound ManyTy))) -- ROMES:TODO: see comment below about match variables being put in cases
                                   -- Note [Localise pattern binders]
                                   --
                                   -- Remark: when the pattern is a variable (or
@@ -151,8 +151,9 @@ 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))
-selectMatchVar w  other_pat        = newSysLocalDs (LambdaBound w) (hsPatType other_pat) -- ROMES:TODO: provenance isn't so trivial in match var?
+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.
 
 {- Note [Localise pattern binders]
 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -300,7 +301,7 @@ data CaseAlt a = HasCallStack => MkCaseAlt{ alt_pat :: a,
                             alt_result :: MatchResult CoreExpr }
 
 mkCoAlgCaseMatchResult
-  :: Id -- ^ Scrutinee
+  :: HasCallStack => Id -- ^ Scrutinee
   -> Type -- ^ Type of exp
   -> NonEmpty (CaseAlt DataCon) -- ^ Alternatives (bndrs *include* tyvars, dicts)
   -> MatchResult CoreExpr
@@ -310,7 +311,7 @@ mkCoAlgCaseMatchResult var ty match_alts
     mkCoLetMatchResult (NonRec arg_id1 newtype_rhs) match_result1
 
   | otherwise
-  = mkDataConCase var ty match_alts
+  = pprTrace "mkCoAlgCaseMatchResult" (pprIdWithBinding var) $ mkDataConCase var ty match_alts
   where
     isNewtype = isNewTyCon (dataConTyCon (alt_pat alt1))
 
@@ -348,9 +349,9 @@ mkPatSynCase var ty alt fail = do
     ensure_unstrict cont | needs_void_lam = Lam voidArgId cont
                          | otherwise      = cont
 
-mkDataConCase :: Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr
+mkDataConCase :: HasCallStack => Id -> Type -> NonEmpty (CaseAlt DataCon) -> MatchResult CoreExpr
 mkDataConCase var ty alts@(alt1 :| _)
-    = liftA2 mk_case mk_default mk_alts
+    = pprTrace "mkDataConCase" (ppr var <+> ppr (idBinding var)) $ liftA2 mk_case mk_default mk_alts
     -- The liftA2 combines the failability of all the alternatives and the default
   where
     con1          = alt_pat alt1
@@ -365,7 +366,7 @@ mkDataConCase var ty alts@(alt1 :| _)
                                           -- (not that splitTyConApp does, these days)
 
     mk_case :: Maybe CoreAlt -> [CoreAlt] -> CoreExpr
-    mk_case def alts = mkWildCase (Var var) (idScaledType var) ty $
+    mk_case def alts = mkWildCase (Var var) (pprTrace "mk_case:var" (pprIdWithBinding var) $ idScaledType var) ty $
       maybeToList def ++ alts
 
     mk_alts :: MatchResult [CoreAlt]
diff --git a/compiler/GHC/Types/Id.hs b/compiler/GHC/Types/Id.hs
index 1d3c5ec495..bf429bbe61 100644
--- a/compiler/GHC/Types/Id.hs
+++ b/compiler/GHC/Types/Id.hs
@@ -223,6 +223,7 @@ idUsageEnv x = case Var.idBinding x of
 
 -- ROMES: Scaled Types seem to be used mainly in data cons; I think Scaled
 -- things remain as they are, bc they seem to only occur in places where the Id is definitely a lambda bound (or datacon, which would be the same) variable
+-- Truly horrendous that this might fail like this, not how we'll leave it... at least return an optional value
 idScaledType :: HasCallStack => Id -> Scaled Type
 idScaledType id = Scaled (idMult id) (idType id)
 
diff --git a/compiler/GHC/Types/Var.hs b/compiler/GHC/Types/Var.hs
index 412aee27e0..5615643275 100644
--- a/compiler/GHC/Types/Var.hs
+++ b/compiler/GHC/Types/Var.hs
@@ -280,6 +280,7 @@ data Var
 data IdBinding where
   LambdaBound :: !Mult -> IdBinding -- ^ includes lambda-bound and constructor fields---pattern bound
   LetBound    :: HasCallStack => UsageEnv -> IdBinding -- ^ a local let binding has a usage env bc it might have free linear variables in its body
+  -- ROMES:TODO: What about type variables? LambdaBound too? Do type variables have a multiplicity?
   -- 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