[Git][ghc/ghc][wip/romes/linear-core] Lam and Let pattern synonyms
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Thu May 25 19:17:43 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/linear-core at Glasgow Haskell Compiler / GHC
Commits:
6e5fe8b1 by Rodrigo Mesquita at 2023-05-25T19:59:13+01:00
Lam and Let pattern synonyms
For debugging purposes only :)
- - - - -
13 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Lint.hs
- compiler/GHC/Core/Make.hs
- compiler/GHC/Core/Opt/Exitify.hs
- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/Tc/TyCl/Class.hs
- compiler/GHC/Tc/TyCl/Instance.hs
- compiler/GHC/Types/Var.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -7,12 +7,12 @@
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE BangPatterns #-}
-{-# LANGUAGE GADTs, StandaloneDeriving #-}
+{-# LANGUAGE GADTs, StandaloneDeriving, PatternSynonyms #-}
-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection
module GHC.Core (
-- * Main data types
- Expr(..), Alt(..), Bind(..), AltCon(..), Arg,
+ Expr(..,Let,Lam), Alt(..), Bind(..), AltCon(..), Arg,
CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,
@@ -252,8 +252,8 @@ data Expr b
= Var Id
| Lit Literal
| App (Expr b) (Arg b)
- | HasCallStack => Lam b (Expr b)
- | HasCallStack => Let (Bind b) (Expr b)
+ | HasCallStack => Lam' b (Expr b)
+ | HasCallStack => Let' (Bind b) (Expr b)
| HasCallStack => Case (Expr b) b Type [Alt b] -- See Note [Case expression invariants]
-- and Note [Why does Case have a 'Type' field?]
| Cast (Expr b) CoercionR -- The Coercion has Representational role
@@ -262,6 +262,30 @@ data Expr b
| Coercion Coercion
deriving instance Data b => Data (Expr b)
+
+pattern Lam :: forall b. (HasCallStack, Typeable b) => b -> Expr b -> Expr b
+pattern Lam x y <- Lam' x y where
+ Lam x y
+ | Just Refl <- eqT @b @Id
+ , not (isLambdaBinding x)
+ = pprPanic "pattern Lam!" (pprIdWithBinding x)
+ | otherwise
+ = Lam' x y
+
+pattern Let :: forall b. (HasCallStack, Typeable b) => Bind b -> Expr b -> Expr b
+pattern Let x y <- Let' x y where
+ Let x y
+ | Just Refl <- eqT @b @Id
+ , NonRec z _ <- x
+ , not (isLetBinding z)
+ = pprPanic "pattern Let 1!" (pprIdWithBinding z)
+ | Just Refl <- eqT @b @Id
+ , Rec zs <- x
+ , any (not . isLetBinding . fst) zs
+ = pprPanic "pattern Let 2!" (ppr zs)
+ | otherwise
+ = Let' x y
+
-- | Type synonym for expressions that occur in function argument positions.
-- Only 'Arg' should contain a 'Type' at top level, general 'Expr' should not
type Arg b = Expr b
@@ -1808,7 +1832,7 @@ type TaggedAlt t = Alt (TaggedBndr t)
instance Outputable b => Outputable (TaggedBndr b) where
ppr (TB b l) = char '<' <> ppr b <> comma <> ppr l <> char '>'
-deTagExpr :: TaggedExpr t -> CoreExpr
+deTagExpr :: Typeable t => TaggedExpr t -> CoreExpr
deTagExpr (Var v) = Var v
deTagExpr (Lit l) = Lit l
deTagExpr (Type ty) = Type ty
@@ -1820,11 +1844,11 @@ deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts
deTagExpr (Tick t e) = Tick t (deTagExpr e)
deTagExpr (Cast e co) = Cast (deTagExpr e) co
-deTagBind :: TaggedBind t -> CoreBind
+deTagBind :: Typeable t => TaggedBind t -> CoreBind
deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs)
deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs]
-deTagAlt :: TaggedAlt t -> CoreAlt
+deTagAlt :: Typeable t => TaggedAlt t -> CoreAlt
deTagAlt (Alt con bndrs rhs) = Alt con [b | TB b _ <- bndrs] (deTagExpr rhs)
{-
@@ -1954,12 +1978,12 @@ mkLet bind body = case (eqT @b @Id) of Just Refl -> if not (isLetBinder bind
pprLetBinderId (Rec ls) = hsep $ map (pprIdWithBinding . fst) ls
-- | @mkLetNonRec bndr rhs body@ wraps @body@ in a @let@ binding @bndr at .
-mkLetNonRec :: b -> Expr b -> Expr b -> Expr b
+mkLetNonRec :: Typeable b => b -> Expr b -> Expr b -> Expr b
mkLetNonRec b rhs body = Let (NonRec b rhs) body
-- | @mkLetRec binds body@ wraps @body@ in a @let rec@ with the given set of
-- @binds@ if binds is non-empty.
-mkLetRec :: [(b, Expr b)] -> Expr b -> Expr b
+mkLetRec :: Typeable b => [(b, Expr b)] -> Expr b -> Expr b
mkLetRec [] body = body
mkLetRec bs body = Let (Rec bs) body
@@ -2056,7 +2080,7 @@ flattenBinds [] = []
-- | We often want to strip off leading lambdas before getting down to
-- business. Variants are 'collectTyBinders', 'collectValBinders',
-- and 'collectTyAndValBinders'
-collectBinders :: Expr b -> ([b], Expr b)
+collectBinders :: Typeable b => Expr b -> ([b], Expr b)
collectTyBinders :: CoreExpr -> ([TyVar], CoreExpr)
collectValBinders :: CoreExpr -> ([Id], CoreExpr)
collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
@@ -2064,7 +2088,7 @@ collectTyAndValBinders :: CoreExpr -> ([TyVar], [Id], CoreExpr)
-- | Strip off exactly N leading lambdas (type or value).
-- Good for use with join points.
-- Panic if there aren't enough
-collectNBinders :: JoinArity -> Expr b -> ([b], Expr b)
+collectNBinders :: Typeable b => JoinArity -> Expr b -> ([b], Expr b)
collectBinders expr
= go [] expr
@@ -2111,7 +2135,7 @@ collectNValBinders_maybe orig_n orig_expr
-- | Takes a nested application expression and returns the function
-- being applied and the arguments to which it is applied
-collectArgs :: Expr b -> (Expr b, [Arg b])
+collectArgs :: Typeable b => Expr b -> (Expr b, [Arg b])
collectArgs expr
= go expr []
where
@@ -2120,7 +2144,7 @@ collectArgs expr
-- | Takes a nested application expression and returns the function
-- being applied. Looking through casts and ticks to find it.
-collectFunSimple :: Expr b -> Expr b
+collectFunSimple :: Typeable b => Expr b -> Expr b
collectFunSimple expr
= go expr
where
@@ -2268,10 +2292,10 @@ collectAnnArgsTicks tickishOk expr
= go e as (t:ts)
go e as ts = (e, as, reverse ts)
-deAnnotate :: AnnExpr bndr annot -> Expr bndr
+deAnnotate :: Typeable bndr => AnnExpr bndr annot -> Expr bndr
deAnnotate (_, e) = deAnnotate' e
-deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
+deAnnotate' :: Typeable bndr => AnnExpr' bndr annot -> Expr bndr
deAnnotate' (AnnType t) = Type t
deAnnotate' (AnnCoercion co) = Coercion co
deAnnotate' (AnnVar v) = Var v
@@ -2286,15 +2310,15 @@ deAnnotate' (AnnLet bind body)
deAnnotate' (AnnCase scrut v t alts)
= Case (deAnnotate scrut) v t (map deAnnAlt alts)
-deAnnAlt :: AnnAlt bndr annot -> Alt bndr
+deAnnAlt :: Typeable bndr => AnnAlt bndr annot -> Alt bndr
deAnnAlt (AnnAlt con args rhs) = Alt con args (deAnnotate rhs)
-deAnnBind :: AnnBind b annot -> Bind b
+deAnnBind :: Typeable b => AnnBind b annot -> Bind b
deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
-- | As 'collectBinders' but for 'AnnExpr' rather than 'Expr'
-collectAnnBndrs :: AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
+collectAnnBndrs :: Typeable bndr => AnnExpr bndr annot -> ([bndr], AnnExpr bndr annot)
collectAnnBndrs e
= collect [] e
where
=====================================
compiler/GHC/Core/Lint.hs
=====================================
@@ -1738,7 +1738,8 @@ lintIdBndr top_lvl bind_site id thing_inside
matchesBindingSite :: IdBinding -> BindingSite -> Bool
matchesBindingSite (LetBound _) LetBind = True
matchesBindingSite (LambdaBound _) LambdaBind = True
- -- ROMES:TODO: Other binding sites!
+ matchesBindingSite (LambdaBound _) CaseBind = True
+ matchesBindingSite (LambdaBound _) CasePatBind = True
matchesBindingSite _ _ = False
{-
=====================================
compiler/GHC/Core/Make.hs
=====================================
@@ -531,7 +531,7 @@ unwrapBox us var body
BI_Box { bi_data_con = box_con, bi_boxed_type = box_ty }
-> (us', var', body')
where
- var' = mkSysLocal (fsLit "uc") uniq (LambdaBound ManyTy) box_ty -- ROMES:TODO: LambdaBound here?
+ var' = mkSysLocal (fsLit "uc") uniq (LambdaBound ManyTy) box_ty -- ROMES:TODO: LambdaBound since its put in case binder
body' = Case (Var var') var' (exprType body)
[Alt (DataAlt box_con) [var] body]
where
=====================================
compiler/GHC/Core/Opt/Exitify.hs
=====================================
@@ -265,7 +265,7 @@ mkExitJoinId in_scope ty join_arity = do
`extendInScopeSet` exit_id_tmpl -- just cosmetics
return (uniqAway avoid exit_id_tmpl)
where
- exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique (LambdaBound ManyTy) ty -- ROMES:TODO: LambdaBound here for ExitJoinId??
+ exit_id_tmpl = mkSysLocal (fsLit "exit") initExitJoinUnique (LetBound zeroUE) ty
`asJoinId` join_arity
addExit :: InScopeSet -> JoinArity -> CoreExpr -> ExitifyM JoinId
=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1751,7 +1751,7 @@ newLvlVar lvld_rhs join_arity_maybe is_mk_static
= mkExportedVanillaId (mkSystemVarName uniq (mkFastString "static_ptr"))
rhs_ty
| otherwise
- = mkSysLocal (mkFastString "lvl") uniq (LambdaBound ManyTy) rhs_ty -- ROMES:TODO: What's the IdBinding
+ = mkSysLocal (mkFastString "lvl") uniq (LetBound zeroUE) rhs_ty
-- | Clone the binders bound by a single-alternative case.
cloneCaseBndrs :: LevelEnv -> Level -> [Var] -> LvlM (LevelEnv, [Var])
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -4,7 +4,7 @@
\section[GHC.Core.Opt.Simplify.Monad]{The simplifier Monad}
-}
-
+{-# LANGUAGE ExistentialQuantification #-}
module GHC.Core.Opt.Simplify.Env (
-- * The simplifier mode
@@ -812,7 +812,7 @@ addJoinFloats floats join_floats
, sfInScope = foldlOL extendInScopeSetBind
(sfInScope floats) join_floats }
-addFloats :: SimplFloats -> SimplFloats -> SimplFloats
+addFloats :: HasCallStack => SimplFloats -> SimplFloats -> SimplFloats
-- Add both let-floats and join-floats for env2 to env1;
-- *plus* the in-scope set for env2, which is bigger
-- than that for env1
@@ -849,7 +849,7 @@ mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff
!jfloats' | isNilOL jbs = emptyJoinFloats
| otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
-wrapFloats :: SimplFloats -> OutExpr -> OutExpr
+wrapFloats :: HasCallStack => SimplFloats -> OutExpr -> OutExpr
-- Wrap the floats around the expression
wrapFloats (SimplFloats { sfLetFloats = LetFloats bs flag
, sfJoinFloats = jbs }) body
@@ -867,7 +867,7 @@ wrapJoinFloatsX floats body
= ( floats { sfJoinFloats = emptyJoinFloats }
, wrapJoinFloats (sfJoinFloats floats) body )
-wrapJoinFloats :: JoinFloats -> OutExpr -> OutExpr
+wrapJoinFloats :: HasCallStack => JoinFloats -> OutExpr -> OutExpr
-- Wrap the sfJoinFloats of the env around the expression,
-- and take them out of the SimplEnv
wrapJoinFloats join_floats body
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -2249,7 +2249,8 @@ rebuildCall env (ArgInfo { ai_fun = fun_id, ai_args = rev_args })
; return (Lam s' body') }
-- Important: do not try to eta-expand this lambda
-- See Note [No eta-expansion in runRW#]
- _ -> do { s' <- newId (fsLit "s") (LambdaBound ManyTy) realWorldStatePrimTy
+-- ROMES:TODO:
+ _ -> do { s' <- newId (fsLit "s") (LambdaBound OneTy) realWorldStatePrimTy
; let (m,_,_) = splitFunTy fun_ty
env' = arg_env `addNewInScopeIds` [s']
cont' = ApplyToVal { sc_dup = Simplified, sc_arg = Var s'
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -47,6 +47,7 @@ import GHC.Core.TyCon (TyCon, tyConName )
import GHC.Core.Multiplicity
import GHC.Core.Ppr ( pprParendExpr )
import GHC.Core.Make ( mkImpossibleExpr )
+import GHC.Types.Var (pprIdWithBinding, isLetBinding, isLambdaBinding, zeroUE)
import GHC.Unit.Module
import GHC.Unit.Module.ModGuts
@@ -1484,11 +1485,22 @@ scExpr' env (Cast e co) = do (usg, e') <- scExpr env e
-- Important to use mkCast here
-- See Note [SpecConstr call patterns]
scExpr' env e@(App _ _) = scApp env (collectArgs e)
-scExpr' env (Lam b e) = do let (env', b') = extendBndr env b
- (usg, e') <- scExpr env' e
- return (usg, Lam b' e')
+scExpr' env (Lam b e)
+ | not (isLambdaBinding b)
+ = pprPanic "scExpr':Lam" (pprIdWithBinding b)
+ | otherwise
+ = do let (env', b') = extendBndr env b
+ (usg, e') <- scExpr env' e
+ return (usg, Lam b' e')
scExpr' env (Let bind body)
+ | NonRec b _ <- bind
+ , not (isLetBinding b)
+ = pprPanic "scExpr':Let:NonRec" (pprIdWithBinding b)
+ | Rec bs <- bind
+ , any (not . isLetBinding . fst) bs
+ = pprPanic "scExpr':Let:Rec" (ppr bs)
+ | otherwise
= do { (final_usage, binds', body') <- scBind NotTopLevel env bind $
(\env -> scExpr env body)
; return (final_usage, mkLets binds' body') }
@@ -1606,6 +1618,8 @@ scApp env (Var fn, args) -- Function is a variable
where
doBeta :: OutExpr -> [OutExpr] -> OutExpr
doBeta (Lam bndr body) (arg : args) = Let (NonRec bndr arg) (doBeta body args)
+ where bndr' | isId bndr = bndr `setIdBinding` LetBound zeroUE
+ | otherwise = bndr
doBeta fn args = mkApps fn args
-- The function is almost always a variable, but not always.
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -65,6 +65,7 @@ module GHC.Core.Utils (
dumpIdInfoOfProgram
) where
+import Data.Typeable (Typeable)
import GHC.Prelude
import GHC.Platform
@@ -453,7 +454,7 @@ stripTicksTopT p = go []
-- | Completely strip ticks satisfying a predicate from an
-- expression. Note this is O(n) in the size of the expression!
-stripTicksE :: (CoreTickish -> Bool) -> Expr b -> Expr b
+stripTicksE :: Typeable b => (CoreTickish -> Bool) -> Expr b -> Expr b
stripTicksE p expr = go expr
where go (App e a) = App (go e) (go a)
go (Lam b e) = Lam b (go e)
@@ -469,7 +470,7 @@ stripTicksE p expr = go expr
go_b (b, e) = (b, go e)
go_a (Alt c bs e) = Alt c bs (go e)
-stripTicksT :: (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
+stripTicksT :: Typeable b => (CoreTickish -> Bool) -> Expr b -> [CoreTickish]
stripTicksT p expr = fromOL $ go expr
where go (App e a) = go e `appOL` go a
go (Lam _ e) = go e
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -58,7 +58,6 @@ import GHC.Core.Make
import GHC.Core.Rules
import GHC.Core.Opt.Pipeline.Types ( CoreToDo(..) )
import GHC.Core.Ppr
-import GHC.Core.UsageEnv ( zeroUE )
import GHC.Builtin.Names
import GHC.Builtin.Types.Prim
=====================================
compiler/GHC/Tc/TyCl/Class.hs
=====================================
@@ -45,7 +45,6 @@ import GHC.Tc.TyCl.Build( TcMethInfo )
import GHC.Core.Type ( extendTvSubstWithClone, piResultTys )
import GHC.Core.Predicate
-import GHC.Core.UsageEnv (zeroUE)
import GHC.Core.Class
import GHC.Core.Coercion ( pprCoAxiom )
import GHC.Core.FamInstEnv
=====================================
compiler/GHC/Tc/TyCl/Instance.hs
=====================================
@@ -43,7 +43,6 @@ import GHC.Tc.Types.Origin
import GHC.Tc.TyCl.Build
import GHC.Tc.Utils.Instantiate
import GHC.Tc.Instance.Class( AssocInstInfo(..), isNotAssociated )
-import GHC.Core.Multiplicity
import GHC.Core.InstEnv
import GHC.Tc.Instance.Family
import GHC.Core.FamInstEnv
@@ -59,7 +58,6 @@ import GHC.Core.Type
import GHC.Core.SimpleOpt
import GHC.Core.Predicate( classMethodInstTy )
import GHC.Tc.Types.Evidence
-import GHC.Core.UsageEnv (zeroUE)
import GHC.Core.TyCon
import GHC.Core.Coercion.Axiom
import GHC.Core.DataCon
@@ -1477,7 +1475,7 @@ tcSuperClasses skol_info dfun_id cls tyvars dfun_evs dfun_ev_binds sc_theta
; sc_ev_id <- newEvVar sc_pred
; addTcEvBind ev_binds_var $ mkWantedEvBind sc_ev_id IsCoherent sc_ev_tm
; let sc_top_ty = tcMkDFunSigmaTy tyvars (map idType dfun_evs) sc_pred
- sc_top_id = mkLocalId sc_top_name (LambdaBound ManyTy) sc_top_ty -- ROMES:TODO:
+ sc_top_id = mkLocalId sc_top_name (LetBound zeroUE) sc_top_ty
export = ABE { abe_wrap = idHsWrapper
, abe_poly = sc_top_id
, abe_mono = sc_ev_id
@@ -2043,7 +2041,7 @@ tcMethodBodyHelp hs_sig_fn sel_id local_meth_id meth_bind
; let ctxt = FunSigCtxt sel_name (lhsSigTypeContextSpan hs_sig_ty)
-- WantRCC <=> check for redundant constraints in the
-- user-specified instance signature
- inner_meth_id = mkLocalId inner_meth_name (LambdaBound ManyTy) sig_ty -- ROMES:TODO:
+ inner_meth_id = mkLocalId inner_meth_name (LetBound zeroUE) sig_ty
inner_meth_sig = CompleteSig { sig_bndr = inner_meth_id
, sig_ctxt = ctxt
, sig_loc = getLocA hs_sig_ty }
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -59,7 +59,7 @@ module GHC.Types.Var (
setIdExported, setIdNotExported, setIdBinding,
updateIdTypeButNotMults,
updateIdTypeAndMults, updateIdTypeAndMultsM,
- IdBinding(..), idBinding, pprIdWithBinding,
+ IdBinding(..), idBinding, pprIdWithBinding, zeroUE,
-- ** Predicates
isId, isTyVar, isTcTyVar,
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e5fe8b1bbb404792b2f25554fe78232930ef43f
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/6e5fe8b1bbb404792b2f25554fe78232930ef43f
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20230525/b3293f8f/attachment-0001.html>
More information about the ghc-commits
mailing list