[Git][ghc/ghc][wip/romes/linear-core] 2 commits: Some tweaks and note:
Rodrigo Mesquita (@alt-romes)
gitlab at gitlab.haskell.org
Mon Jun 26 16:43:44 UTC 2023
Rodrigo Mesquita pushed to branch wip/romes/linear-core at Glasgow Haskell Compiler / GHC
Commits:
0c7745f9 by Rodrigo Mesquita at 2023-06-23T23:03:23+01:00
Some tweaks and note:
* It seems very important that if we update the Id binding of some Id
that happens in a binder we also update the Id binding of occurrences
of that Id in Var expressions. Otherwise we'll fail important things
like lookups on triemaps
- - - - -
4dfac578 by Rodrigo Mesquita at 2023-06-26T17:42:27+01:00
Compilation fixes
- - - - -
17 changed files:
- compiler/GHC/Core/Coercion.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Opt/WorkWrap/Utils.hs
- compiler/GHC/Core/Rules.hs
- compiler/GHC/Core/SimpleOpt.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/CoreToIface.hs
- compiler/GHC/HsToCore/Binds.hs
- compiler/GHC/HsToCore/Expr.hs
- compiler/GHC/HsToCore/Match.hs
- compiler/GHC/HsToCore/Match/Constructor.hs
- compiler/GHC/Tc/Gen/Bind.hs
- compiler/GHC/Tc/Gen/Match.hs
- compiler/GHC/Tc/Utils/Unify.hs
- compiler/GHC/Tc/Zonk/TcType.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/GHC/Types/Var.hs
Changes:
=====================================
compiler/GHC/Core/Coercion.hs
=====================================
@@ -1677,7 +1677,7 @@ mkFunResCo role id res_co
= mkFunCoNoFTF role mult arg_co res_co
where
arg_co = mkReflCo role (varType id) -- (arg ~ arg)
- mult = multToCo $ case idBinding id of
+ mult = multToCo $ case idBinding id of
LambdaBound m -> m
LetBound -> panic "mkFunResCo"
-- ROMES:
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -2539,7 +2539,7 @@ mkCase mode scrut outer_bndr alts_ty (Alt DEFAULT _ deflt_rhs : outer_alts)
-- that outer_bndr is not shadowed by the inner patterns
wrap_rhs rhs = Let (NonRec (toLetBound inner_bndr) (Var outer_bndr)) rhs
-- IdBinding: See Note [Keeping the IdBinding up to date]
- --
+ --
-- The let is OK even for unboxed binders,
wrapped_alts | isDeadBinder inner_bndr = inner_alts
=====================================
compiler/GHC/Core/Opt/WorkWrap/Utils.hs
=====================================
@@ -987,7 +987,7 @@ unbox_one_arg opts arg_var
; let wrap_arg = mkConApp dc (map Type tc_args ++ wrap_args) `mkCast` mkSymCo co
-- See Note [Unboxing through unboxed tuples]
; return $ if isUnboxedTupleDataCon dc && not nested_useful
- then (boringSplit, [(arg_var,NotMarkedStrict)], nop_fn, varToCoreExpr arg_var)
+ then (boringSplit, [(toLambdaBound arg_var,NotMarkedStrict)], nop_fn, varToCoreExpr $ toLambdaBound arg_var)
else (usefulSplit, worker_args, unbox_fn . wrap_fn, wrap_arg) }
-- | Tries to find a suitable absent filler to bind the given absent identifier
=====================================
compiler/GHC/Core/Rules.hs
=====================================
@@ -193,7 +193,7 @@ mkRule this_mod is_auto is_local name act fn bndrs args rhs
= Rule { ru_name = name
, ru_act = act
, ru_fn = fn
- , ru_bndrs = bndrs
+ , ru_bndrs = map toLambdaBound bndrs -- romes:todo: the issue being if we don't do this elsewhere we'll get our vars and binders out of sync (let bound vs lambda bound)
, ru_args = args
, ru_rhs = occurAnalyseExpr rhs
-- See Note [OccInfo in unfoldings and rules]
=====================================
compiler/GHC/Core/SimpleOpt.hs
=====================================
@@ -35,7 +35,6 @@ import GHC.Types.Id.Info ( realUnfoldingInfo, setUnfoldingInfo, setRuleInfo, Id
import GHC.Types.Var ( isNonCoVarId, toLetBound )
import GHC.Types.Var.Set
import GHC.Types.Var.Env
-import GHC.Core.UsageEnv
import GHC.Core.DataCon
import GHC.Types.Demand( etaConvertDmdSig, topSubDmd )
import GHC.Types.Tickish
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -176,12 +176,12 @@ mkLamType v body_ty
| otherwise
= mkFunctionType mult (varType v) body_ty
where
- !mult = case varMultMaybe v of
- -- ROMES: Can we avoid this panic by encoding this at the type level somehow?
- -- ... it could prove pretty invasive...
- Nothing -> pprTrace "mkLamType: LetBound var turned to LambdaBound" (ppr v <+> ppr (idBinding v)) ManyTy
- -- panic "mkLamTypes: lambda bound var (be it a big or small lambda) should be annotated with LambdaBound"
- Just m -> m
+ mult = case varMultMaybe v of
+ -- ROMES: Can we avoid this panic by encoding this at the type level somehow?
+ -- ... it could prove pretty invasive...
+ Nothing -> pprTrace "mkLamType: LetBound var turned to LambdaBound" (ppr v <+> ppr (idBinding v)) ManyTy
+ -- panic "mkLamTypes: lambda bound var (be it a big or small lambda) should be annotated with LambdaBound"
+ Just m -> m
mkLamTypes vs ty = foldr mkLamType ty vs
@@ -523,7 +523,7 @@ bindNonRec bndr rhs body
lambda_bndr = toLambdaBound bndr -- ROMES:TODO: Explain, is this the best place to do this?
case_bind = mkDefaultCase rhs lambda_bndr body
-- ROMES:TODO: I couldn't find the root cause, for now we simply override the idBinding here
- let_bind
+ let_bind
| isId bndr
= Let (NonRec (toLetBound bndr) rhs) body
| otherwise
=====================================
compiler/GHC/CoreToIface.hs
=====================================
@@ -1,4 +1,5 @@
{-# LANGUAGE Strict #-} -- See Note [Avoiding space leaks in toIface*]
+{-# LANGUAGE ViewPatterns #-}
-- | Functions for converting Core things to interface file things.
module GHC.CoreToIface
@@ -135,10 +136,11 @@ toIfaceIdBndr :: Id -> IfaceIdBndr
toIfaceIdBndr = toIfaceIdBndrX emptyVarSet
toIfaceIdBndrX :: VarSet -> CoVar -> IfaceIdBndr
-toIfaceIdBndrX fr covar = ( toIfaceType (idMult $ toLambdaBound covar) -- idMult of coercion variable should already always be ManyTy?...
- , occNameFS (getOccName covar)
- , toIfaceTypeX fr (varType covar)
- )
+toIfaceIdBndrX fr (toLambdaBound -> covar)
+ = ( toIfaceType (idMult covar) -- idMult of coercion variable should already always be ManyTy?...
+ , occNameFS (getOccName covar)
+ , toIfaceTypeX fr (varType covar)
+ )
toIfaceBndr :: Var -> IfaceBndr
toIfaceBndr var
=====================================
compiler/GHC/HsToCore/Binds.hs
=====================================
@@ -245,8 +245,9 @@ dsAbsBinds dflags tyvars dicts exports
-- If there is a variable to force, it's just the
-- single variable we are binding here
= do { dsHsWrapper wrap $ \core_wrap -> do -- Usually the identity
- { let rhs = core_wrap $
- mkLams tyvars $ mkLams (map toLambdaBound dicts) $
+ { let dicts' = map toLambdaBound dicts
+ rhs = core_wrap $
+ mkLams tyvars $ mkLams dicts' $
-- The tyvars aren't really just TyVars, right? $dEq can end up there it seems
-- and
-- So dicts names mention the
@@ -266,7 +267,7 @@ dsAbsBinds dflags tyvars dicts exports
; let global_id' = addIdSpecialisations global_id rules
main_bind = makeCorePair dflags global_id'
(isDefaultMethod prags)
- (dictArity dicts) rhs
+ (dictArity dicts') rhs
; return (force_vars', main_bind : fromOL spec_binds) } }
@@ -719,8 +720,9 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
{ this_mod <- getModule
; let fn_unf = realIdUnfolding poly_id
+ spec_bndrs' = map toLambdaBound spec_bndrs
simpl_opts = initSimpleOpts dflags
- spec_unf = specUnfolding simpl_opts (map toLambdaBound spec_bndrs) core_app rule_lhs_args fn_unf
+ spec_unf = specUnfolding simpl_opts spec_bndrs' core_app rule_lhs_args fn_unf
spec_id = mkLocalId spec_name LetBound spec_ty
`setInlinePragma` inl_prag
`setIdUnfolding` spec_unf
@@ -728,8 +730,8 @@ dsSpec mb_poly_rhs (L loc (SpecPrag poly_id spec_co spec_inl))
rule = mkSpecRule dflags this_mod False rule_act (text "USPEC")
poly_id rule_bndrs rule_lhs_args
-- ROMES:TODO: Perhaps this kind of SetIdBinding is something that the functions actually constructing the lambda abstractions could always do by default
- (mkVarApps (Var spec_id) spec_bndrs)
- spec_rhs = mkLams spec_bndrs (core_app poly_rhs)
+ (mkVarApps (Var spec_id) spec_bndrs')
+ spec_rhs = mkLams spec_bndrs' (core_app poly_rhs)
; dsWarnOrphanRule rule
=====================================
compiler/GHC/HsToCore/Expr.hs
=====================================
@@ -51,7 +51,6 @@ import GHC.Core.Make
import GHC.Driver.Session
import GHC.Types.CostCentre
import GHC.Types.Id
-import GHC.Types.Var (pprIdWithBinding)
import GHC.Types.Id.Make
import GHC.Unit.Module
import GHC.Core.ConLike
=====================================
compiler/GHC/HsToCore/Match.hs
=====================================
@@ -288,7 +288,6 @@ matchCoercion (var :| vars) ty (eqns@(eqn1 :| _))
; match_result <- match (var':vars) ty $ NEL.toList $
decomposeFirstPat getCoPat <$> eqns
; dsHsWrapper co $ \core_wrap -> do
- -- romes:I don't know
{ let bind = NonRec (toLetBound var') (core_wrap (Var var))
; return (mkCoLetMatchResult bind match_result) } }
=====================================
compiler/GHC/HsToCore/Match/Constructor.hs
=====================================
@@ -107,7 +107,7 @@ have-we-used-all-the-constructors? question; the local function
--
-- case <expr> of
-- C a b -> ...
--- D c -> ... -- not sure about this second constructor being correct
+-- D c -> ... -- not sure about this second constructor being correct
--
-- Relevant notes seem to be [Match Ids] and [Localise pattern binders]
matchConFamily :: NonEmpty Id
=====================================
compiler/GHC/Tc/Gen/Bind.hs
=====================================
@@ -57,7 +57,6 @@ import GHC.Tc.Zonk.TcType
import GHC.Core.Predicate ( getEqPredTys_maybe )
import GHC.Core.Reduction ( Reduction(..) )
import GHC.Core.Multiplicity
-import GHC.Core.UsageEnv
import GHC.Core.FamInstEnv( normaliseType )
import GHC.Core.Class ( Class )
import GHC.Core.Coercion( mkSymCo )
=====================================
compiler/GHC/Tc/Gen/Match.hs
=====================================
@@ -542,7 +542,7 @@ tcLcStmt m_tc ctxt (TransStmt { trS_form = form, trS_stmts = stmts
-- typically something like [(Int,Bool,Int)]
-- We don't know what tuple_ty is yet, so we use a variable
; let mk_n_bndr :: Name -> TcId -> TcId
- mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name LetBound (n_app (idType bndr_id)) -- romes:TODO: LetBound or LambdaBound?
+ mk_n_bndr n_bndr_name bndr_id = mkLocalId n_bndr_name (LambdaBound ManyTy) (n_app (idType bndr_id))
-- Ensure that every old binder of type `b` is linked up with its
-- new binder which should have type `n b`
=====================================
compiler/GHC/Tc/Utils/Unify.hs
=====================================
@@ -1385,11 +1385,11 @@ deeplySkolemise skol_info ty
= do { let arg_tys' = substScaledTys subst arg_tys
; ids1 <- newSysLocalIds (fsLit "dk") arg_tys'
; (subst', tvs1) <- tcInstSkolTyVarsX skol_info subst tvs
- ; ev_vars1 <- newEvVars (substTheta subst' theta)
+ ; ev_vars1 <- map toLambdaBound <$> newEvVars (substTheta subst' theta)
; (wrap, tvs_prs2, ev_vars2, rho) <- go subst' ty'
; let tv_prs1 = map tyVarName tvs `zip` tvs1
; return ( mkWpEta ids1 (mkWpTyLams tvs1
- <.> mkWpEvLams (map toLambdaBound ev_vars1)
+ <.> mkWpEvLams ev_vars1
<.> wrap)
, tv_prs1 ++ tvs_prs2
, ev_vars1 ++ ev_vars2
=====================================
compiler/GHC/Tc/Zonk/TcType.hs
=====================================
@@ -337,7 +337,7 @@ zonkTyCoVarBndrKind (Bndr tv flag) =
-- | zonkId is used *during* typechecking just to zonk the 'Id''s type
zonkId :: TcId -> ZonkM TcId
-zonkId id = updateIdTypeAndMultM zonkTcType id
+zonkId id = updateIdTypeAndMultsM zonkTcType id
zonkCoVar :: CoVar -> ZonkM CoVar
zonkCoVar = zonkId
@@ -402,7 +402,7 @@ zonkImplication implic@(Implic { ic_skols = skols
, ic_info = info' }) }
zonkEvVar :: EvVar -> ZonkM EvVar
-zonkEvVar var = updateIdTypeAndMultM zonkTcType var
+zonkEvVar var = updateIdTypeAndMultsM zonkTcType var
zonkWC :: WantedConstraints -> ZonkM WantedConstraints
@@ -677,4 +677,4 @@ tidyFRROrigin env (FixedRuntimeRepOrigin ty orig)
----------------
tidyEvVar :: TidyEnv -> EvVar -> EvVar
-tidyEvVar env var = updateIdTypeAndMult (tidyType env) var
+tidyEvVar env var = updateIdTypeAndMults (tidyType env) var
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -597,8 +597,15 @@ zonkIdBndrX v
zonkIdBndr :: TcId -> ZonkTcM Id
zonkIdBndr v
- = do { Scaled w' ty' <- zonkScaledTcTypeToTypeX (idScaledType v)
- ; return $ setIdMult (setIdType v ty') w' }
+ = do idBinding' <- zonkIdBinding (idBinding v)
+ ty' <- zonkTcTypeToTypeX (idType v)
+ return $ setIdBinding (setIdType v ty') idBinding'
+
+zonkIdBinding :: IdBinding -> ZonkTcM IdBinding
+zonkIdBinding b = case b of
+ LambdaBound m -> LambdaBound <$> zonkTcTypeToTypeX m
+ -- LetBound ue -> LetBound <$> mapUEM zonkTcTypeToTypeX ue
+ LetBound -> pure LetBound
zonkIdBndrs :: [TcId] -> ZonkTcM [Id]
zonkIdBndrs ids = mapM zonkIdBndr ids
@@ -626,7 +633,7 @@ zonkEvBndr :: EvVar -> ZonkTcM EvVar
-- Works for dictionaries and coercions
-- Does not extend the ZonkEnv
zonkEvBndr var
- = updateIdTypeAndMultM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX) var
+ = updateIdTypeAndMultsM ({-# SCC "zonkEvBndr_zonkTcTypeToType" #-} zonkTcTypeToTypeX) var
{-
zonkEvVarOcc :: EvVar -> ZonkTcM EvTerm
@@ -770,7 +777,7 @@ zonk_bind (XHsBindsLR (AbsBinds { abs_tvs = tyvars, abs_ev_vars = evs
, (L loc bind@(FunBind { fun_id = (L mloc mono_id)
, fun_matches = ms
, fun_ext = (co_fn, ticks) })) <- lbind
- = do { new_mono_id <- updateIdTypeAndMultM zonkTcTypeToTypeX mono_id
+ = do { new_mono_id <- updateIdTypeAndMultsM zonkTcTypeToTypeX mono_id
-- Specifically /not/ zonkIdBndr; we do not want to
-- complain about a representation-polymorphic binder
; runZonkBndrT (zonkCoFn co_fn) $ \ new_co_fn ->
=====================================
compiler/GHC/Types/Var.hs
=====================================
@@ -257,7 +257,8 @@ data Var
-- ^ Key for fast comparison
-- Identical to the Unique in the name,
-- cached here for speed
- varType :: Kind -- ^ The type or kind of the 'Var' in question
+ varType :: Kind, -- ^ The type or kind of the 'Var' in question
+ idBinding :: HasCallStack => IdBinding -- Never put anything here, it's just to catch location of bugs when using field accessors
}
| TcTyVar { -- Used only during type inference
@@ -266,7 +267,8 @@ data Var
varName :: !Name,
realUnique :: {-# UNPACK #-} !Int,
varType :: Kind,
- tc_tv_details :: TcTyVarDetails
+ tc_tv_details :: TcTyVarDetails,
+ idBinding :: HasCallStack => IdBinding -- Never put anything here, it's just to catch location of bugs when using field accessors
}
| Id {
@@ -1215,6 +1217,7 @@ mkTyVar :: Name -> Kind -> TyVar
mkTyVar name kind = TyVar { varName = name
, realUnique = getKey (nameUnique name)
, varType = kind
+ , idBinding = error "here"
}
mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
@@ -1224,6 +1227,7 @@ mkTcTyVar name kind details
realUnique = getKey (nameUnique name),
varType = kind,
tc_tv_details = details
+ , idBinding = error "here"
}
tcTyVarDetails :: TyVar -> TcTyVarDetails
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/28ebeed4e4da051c9ea5ce01b8805ba6d5be9152...4dfac578390d7e639bd46e66b0f01b684c4be65a
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/28ebeed4e4da051c9ea5ce01b8805ba6d5be9152...4dfac578390d7e639bd46e66b0f01b684c4be65a
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/20230626/70b645ca/attachment-0001.html>
More information about the ghc-commits
mailing list