[Git][ghc/ghc][wip/romes/linear-core] 2 commits: Progress
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Sat May 27 16:53:20 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/linear-core at Glasgow Haskell Compiler / GHC
Commits:
6ec83341 by Rodrigo Mesquita at 2023-05-26T11:50:06+01:00
Progress
- - - - -
c92538e7 by Rodrigo Mesquita at 2023-05-27T17:53:03+01:00
Multiple further fixes of IdBindings...
- - - - -
8 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/SpecConstr.hs
- compiler/GHC/CoreToStg/Prep.hs
- compiler/GHC/HsToCore.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/Tc/Gen/Foreign.hs
- compiler/GHC/Tc/Types/Evidence.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -12,7 +12,7 @@
-- | GHC.Core holds all the main data types for use by for the Glasgow Haskell Compiler midsection
module GHC.Core (
-- * Main data types
- Expr(..,Let,Lam), Alt(..), Bind(..), AltCon(..), Arg,
+ Expr(..,Let,Lam), Alt(..), Bind(..,Rec,NonRec), AltCon(..), Arg,
CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,
@@ -338,8 +338,28 @@ instance Ord AltCon where
-- If you edit this type, you may need to update the GHC formalism
-- See Note [GHC Formalism] in GHC.Core.Lint
-data Bind b = HasCallStack => NonRec b (Expr b)
- | HasCallStack => Rec [(b, (Expr b))]
+data Bind b = HasCallStack => NonRec' b (Expr b)
+ | HasCallStack => Rec' [(b, (Expr b))]
+
+{-# COMPLETE NonRec, Rec #-}
+
+pattern NonRec :: forall b. (HasCallStack, Typeable b) => b -> Expr b -> Bind b
+pattern NonRec b e <- NonRec' b e where
+ NonRec b e
+ | Just Refl <- eqT @b @Id
+ , not (isLetBinding b)
+ = pprPanic "NonRec" (pprIdWithBinding b)
+ | otherwise
+ = NonRec' b e
+
+pattern Rec :: forall b. (HasCallStack, Typeable b) => [(b, Expr b)] -> Bind b
+pattern Rec bs <- Rec' bs where
+ Rec bs
+ | Just Refl <- eqT @b @Id
+ , any (not . isLetBinding . fst) bs
+ = pprPanic "Rec" (ppr bs)
+ | otherwise
+ = Rec' bs
deriving instance Data b => Data (Bind b)
@@ -2035,32 +2055,32 @@ exprToType _bad = pprPanic "exprToType" empty
-}
-- | Extract every variable by this group
-bindersOf :: Bind b -> [b]
+bindersOf :: Typeable b => Bind b -> [b]
-- If you edit this function, you may need to update the GHC formalism
-- See Note [GHC Formalism] in GHC.Core.Lint
bindersOf (NonRec binder _) = [binder]
bindersOf (Rec pairs) = [binder | (binder, _) <- pairs]
-- | 'bindersOf' applied to a list of binding groups
-bindersOfBinds :: [Bind b] -> [b]
+bindersOfBinds :: Typeable b => [Bind b] -> [b]
bindersOfBinds binds = foldr ((++) . bindersOf) [] binds
-- We inline this to avoid unknown function calls.
{-# INLINE foldBindersOfBindStrict #-}
-foldBindersOfBindStrict :: (a -> b -> a) -> a -> Bind b -> a
+foldBindersOfBindStrict :: Typeable b => (a -> b -> a) -> a -> Bind b -> a
foldBindersOfBindStrict f
= \z bind -> case bind of
NonRec b _rhs -> f z b
Rec pairs -> foldl' f z $ map fst pairs
{-# INLINE foldBindersOfBindsStrict #-}
-foldBindersOfBindsStrict :: (a -> b -> a) -> a -> [Bind b] -> a
+foldBindersOfBindsStrict :: Typeable b => (a -> b -> a) -> a -> [Bind b] -> a
foldBindersOfBindsStrict f = \z binds -> foldl' fold_bind z binds
where
fold_bind = (foldBindersOfBindStrict f)
-rhssOfBind :: Bind b -> [Expr b]
+rhssOfBind :: Typeable b => Bind b -> [Expr b]
rhssOfBind (NonRec _ rhs) = [rhs]
rhssOfBind (Rec pairs) = [rhs | (_,rhs) <- pairs]
@@ -2073,7 +2093,7 @@ rhssOfAlts alts = [e | Alt _ _ e <- alts]
-- | Collapse all the bindings in the supplied groups into a single
-- list of lhs\/rhs pairs suitable for binding in a 'Rec' binding group
-flattenBinds :: [Bind b] -> [(b, Expr b)]
+flattenBinds :: Typeable b => [Bind b] -> [(b, Expr b)]
flattenBinds (NonRec b r : binds) = (b,r) : flattenBinds binds
flattenBinds (Rec prs1 : binds) = prs1 ++ flattenBinds binds
flattenBinds [] = []
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -9,7 +9,7 @@ module GHC.Core.Opt.CSE (cseProgram, cseOneExpr) where
import GHC.Prelude
import GHC.Core.Subst
-import GHC.Types.Var ( Var )
+import GHC.Types.Var ( Var, setIdBinding, IdBinding(..) )
import GHC.Types.Var.Env ( mkInScopeSet )
import GHC.Types.Id ( Id, idType, idHasRules, zapStableUnfolding
, idInlineActivation, setInlineActivation
@@ -20,12 +20,13 @@ import GHC.Core.Utils ( mkAltExpr
, stripTicksE, stripTicksT, mkTicks )
import GHC.Core.FVs ( exprFreeVars )
import GHC.Core.Type ( tyConAppArgs )
+import GHC.Core.Multiplicity
import GHC.Core
import GHC.Utils.Outputable
import GHC.Types.Basic
import GHC.Types.Tickish
import GHC.Core.Map.Expr
-import GHC.Utils.Misc ( filterOut, equalLength )
+import GHC.Utils.Misc ( filterOut, equalLength, HasCallStack )
import GHC.Utils.Panic
import Data.Functor.Identity ( Identity (..) )
import Data.List ( mapAccumL )
@@ -880,15 +881,19 @@ extendCSEnv cse expr triv_expr
where
sexpr = stripTicksE tickishFloatable expr
-extendCSRecEnv :: CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv
+extendCSRecEnv :: HasCallStack => CSEnv -> OutId -> OutExpr -> OutExpr -> CSEnv
-- See Note [CSE for recursive bindings]
extendCSRecEnv cse bndr expr triv_expr
- = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam bndr expr) triv_expr }
+ = cse { cs_rec_map = extendCoreMap (cs_rec_map cse) (Lam (bndr `setIdBinding` LambdaBound ManyTy) expr) triv_expr }
+ -- Set binding as below
-lookupCSRecEnv :: CSEnv -> OutId -> OutExpr -> Maybe OutExpr
+lookupCSRecEnv :: HasCallStack => CSEnv -> OutId -> OutExpr -> Maybe OutExpr
-- See Note [CSE for recursive bindings]
lookupCSRecEnv (CS { cs_rec_map = csmap }) bndr expr
- = lookupCoreMap csmap (Lam bndr expr)
+ = lookupCoreMap csmap (Lam (bndr `setIdBinding` LambdaBound ManyTy) expr)
+ -- See Note [Keeping the IdBinding up to date]
+ -- We look up recursive let-bindings as explained in
+ -- Note [CSE for recursive bindings]
csEnvSubst :: CSEnv -> Subst
csEnvSubst = cs_subst
=====================================
compiler/GHC/Core/Opt/SpecConstr.hs
=====================================
@@ -1876,19 +1876,10 @@ specialise env bind_calls (RI { ri_fn = fn, ri_lam_bndrs = arg_bndrs
Nothing -> return (nullUsage, spec_info)
----------------------
-spec_one :: ScEnv
- -> OutId -- Function
- -> [InVar] -- Lambda-binders of RHS; should match patterns
- -> InExpr -- Body of the original function
- -> (CallPat, Int)
- -> UniqSM (ScUsage, OneSpec) -- Rule and binding
+{- | @'spec_one'@ creates a specialised copy of the function,
+ together with a rule for using it. I'm very proud of how short this
+ function is, considering what it does :-).
--- spec_one creates a specialised copy of the function, together
--- with a rule for using it. I'm very proud of how short this
--- function is, considering what it does :-).
-
-{-
Example
In-scope: a, x::a
@@ -1905,12 +1896,16 @@ spec_one :: ScEnv
f (b,c) ((:) (a,(b,c)) (x,v) hw) = f_spec b c v hw
-}
-
+spec_one :: ScEnv
+ -> OutId -- ^ Function
+ -> [InVar] -- ^ Lambda-binders of RHS; should match patterns
+ -> InExpr -- ^ Body of the original function
+ -> (CallPat, Int)
+ -> UniqSM (ScUsage, OneSpec) -- ^ Rule and binding
spec_one env fn arg_bndrs body (call_pat, rule_number)
| CP { cp_qvars = qvars, cp_args = pats, cp_strict_args = cbv_args } <- call_pat
- = do { -- pprTraceM "spec_one {" (ppr fn <+> ppr pats)
-
- ; spec_uniq <- getUniqueM
+ = do {
+ spec_uniq <- getUniqueM
; let env1 = extendScSubstList (extendScInScope env qvars)
(arg_bndrs `zip` pats)
(body_env, extra_bndrs) = extendBndrs env1 (dropList pats arg_bndrs)
@@ -1933,10 +1928,9 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
spec_name = mkInternalName spec_uniq spec_occ fn_loc
-- Specialise the body
- -- ; pprTraceM "body_subst_for" $ ppr (spec_occ) $$ ppr (sc_subst body_env)
; (spec_usg, spec_body) <- scExpr body_env body
- -- And build the results
+ -- And build the results
; (qvars', pats') <- generaliseDictPats qvars pats
; let spec_body_ty = exprType spec_body
(spec_lam_args, spec_call_args, spec_sig)
@@ -1946,7 +1940,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
spec_join_arity | isJoinId fn = Just (length spec_call_args)
| otherwise = Nothing
spec_id = asWorkerLikeId $
- mkLocalId spec_name (LambdaBound ManyTy)
+ mkLocalId spec_name (LetBound zeroUE) -- Specialized bindings are let-bound
(mkLamTypes spec_lam_args spec_body_ty)
-- See Note [Transfer strictness]
`setIdDmdSig` spec_sig
@@ -1984,7 +1978,7 @@ spec_one env fn arg_bndrs body (call_pat, rule_number)
, os_id = spec_id
, os_rhs = spec_rhs }) }
-generaliseDictPats :: [Var] -> [CoreExpr] -- Quantified vars and pats
+generaliseDictPats :: [Var] -> [CoreExpr] -- Quantified vars and pats
-> UniqSM ([Var], [CoreExpr]) -- New quantified vars and pats
-- See Note [generaliseDictPats]
generaliseDictPats qvars pats
=====================================
compiler/GHC/CoreToStg/Prep.hs
=====================================
@@ -1847,7 +1847,8 @@ deFloatTop (Floats _ floats)
= foldrOL get [] floats
where
get (FloatLet b) bs = get_bind b : bs
- get (FloatCase body var _ _ _) bs = get_bind (NonRec var body) : bs
+ get (FloatCase body var _ _ _) bs = get_bind (NonRec (var `setIdBinding` LetBound zeroUE) body) : bs
+ -- See Note [Keeping the IdBinding up to date]
get b _ = pprPanic "corePrepPgm" (ppr b)
-- See Note [Dead code in CorePrep]
=====================================
compiler/GHC/HsToCore.hs
=====================================
@@ -187,6 +187,7 @@ deSugar hsc_env
; core_prs <- patchMagicDefns core_prs
; (spec_prs, spec_rules) <- dsImpSpecs imp_specs
; (ds_fords, foreign_prs) <- dsForeigns fords
+ ; pprTraceM "foreign_prs" (ppr foreign_prs)
; ds_rules <- mapMaybeM dsRule rules
; let hpc_init
| gopt Opt_Hpc dflags = hpcInitCode (targetPlatform $ hsc_dflags hsc_env) mod ds_hpc_info
@@ -299,7 +300,7 @@ dsImpSpecs imp_specs
; let (spec_binds, spec_rules) = unzip spec_prs
; return (concatOL spec_binds, spec_rules) }
-combineEvBinds :: [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
+combineEvBinds :: HasCallStack => [CoreBind] -> [(Id,CoreExpr)] -> [CoreBind]
-- Top-level bindings can include coercion bindings, but not via superclasses
-- See Note [Top-level evidence]
combineEvBinds [] val_prs
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -896,7 +896,7 @@ decomposeRuleLhs dflags orig_bndrs orig_lhs rhs_fvs
where
extra_tvs = [ v | v <- extra_vars, isTyVar v ]
extra_dicts =
- [ mkLocalId (localiseName (idName d)) (LambdaBound ManyTy) (idType d) -- ROMES:TODO: Dicts lambda bound here?
+ [ mkLocalId (localiseName (idName d)) (LetBound zeroUE) (idType d)
| d <- extra_vars, isDictId d ]
extra_vars =
[ v
=====================================
compiler/GHC/Tc/Gen/Foreign.hs
=====================================
@@ -52,6 +52,7 @@ import GHC.Core.Coercion
import GHC.Core.Reduction
import GHC.Core.Type
import GHC.Core.Multiplicity
+import GHC.Core.UsageEnv (zeroUE)
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.TyCon.RecWalk
@@ -264,7 +265,7 @@ tcFImport (L dloc fo@(ForeignImport { fd_name = L nloc nm, fd_sig_ty = hs_ty
-- for overloaded functions, but doesn't seem worth it
(arg_tys, res_ty) = splitFunTys (dropForAlls norm_sig_ty)
- id = mkLocalId nm (LambdaBound ManyTy) sig_ty -- ROMES:TODO: how bound?
+ id = mkLocalId nm (LetBound zeroUE) sig_ty -- Let bound top-level foreign import
-- Use a LocalId to obey the invariant that locally-defined
-- things are LocalIds. However, it does not need zonking,
-- (so GHC.Tc.Utils.Zonk.zonkForeignExports ignores it).
=====================================
compiler/GHC/Tc/Types/Evidence.hs
=====================================
@@ -2,13 +2,13 @@
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE ExistentialQuantification, PatternSynonyms #-}
{-# LANGUAGE StandaloneDeriving #-}
module GHC.Tc.Types.Evidence (
-- * HsWrapper
- HsWrapper(..),
+ HsWrapper(.., WpLet),
(<.>), mkWpTyApps, mkWpEvApps, mkWpEvVarApps, mkWpTyLams,
mkWpEvLams, mkWpLet, mkWpFun, mkWpCastN, mkWpCastR, mkWpEta,
collectHsWrapBinders,
@@ -171,14 +171,26 @@ data HsWrapper
| WpTyApp KindOrType -- [] t the 't' is a type (not coercion)
- | HasCallStack => WpLet TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
+ | HasCallStack => WpLet' TcEvBinds -- Non-empty (or possibly non-empty) evidence bindings,
-- so that the identity coercion is always exactly WpHole
| WpMultCoercion Coercion -- Require that a Coercion be reflexive; otherwise,
-- error in the desugarer. See GHC.Tc.Utils.Unify
-- Note [Wrapper returned from tcSubMult]
+
+{-# COMPLETE WpHole, WpCompose, WpFun, WpCast, WpEvLam, WpEvApp, WpTyLam, WpTyApp, WpLet, WpMultCoercion #-}
+
deriving instance Data.Data HsWrapper
+pattern WpLet :: HasCallStack => TcEvBinds -> HsWrapper
+pattern WpLet x <- WpLet' x where
+ WpLet x
+ | EvBinds zs <- x
+ , anyBag (not . isLetBinding . evBindVar) zs
+ = pprPanic "pattern WpLet!" (ppr zs)
+ | otherwise
+ = WpLet' x
+
-- | The Semigroup instance is a bit fishy, since @WpCompose@, as a data
-- constructor, is "syntactic" and not associative. Concretely, if @a@, @b@,
-- and @c@ aren't @WpHole@:
@@ -464,7 +476,7 @@ data EvBindInfo
-----------------
-- All evidence is bound by EvBinds; no side effects
data EvBind
- = EvBind { eb_lhs :: EvVar
+ = HasCallStack => EvBind { eb_lhs :: EvVar
, eb_rhs :: EvTerm
, eb_info :: EvBindInfo
}
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59005e70473f1725fae1384d5825a3cbfb9da09e...c92538e73e6688edee0f59a4ff17ffbd4ae65349
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/59005e70473f1725fae1384d5825a3cbfb9da09e...c92538e73e6688edee0f59a4ff17ffbd4ae65349
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/20230527/fdcdd912/attachment-0001.html>
More information about the ghc-commits
mailing list