[Git][ghc/ghc][wip/T20264] more progress
Simon Peyton Jones (@simonpj)
gitlab at gitlab.haskell.org
Thu Oct 31 17:41:59 UTC 2024
Simon Peyton Jones pushed to branch wip/T20264 at Glasgow Haskell Compiler / GHC
Commits:
dc780436 by Simon Peyton Jones at 2024-10-31T17:41:37+00:00
more progress
- - - - -
12 changed files:
- compiler/GHC/Core.hs
- compiler/GHC/Core/FVs.hs
- compiler/GHC/Core/Opt/CSE.hs
- compiler/GHC/Core/Opt/FloatIn.hs
- compiler/GHC/Core/Opt/Simplify/Env.hs
- compiler/GHC/Core/Opt/Simplify/Iteration.hs
- compiler/GHC/Core/Opt/Simplify/Utils.hs
- compiler/GHC/Core/Subst.hs
- compiler/GHC/Core/Type.hs
- compiler/GHC/Core/Utils.hs
- compiler/GHC/Tc/Zonk/Type.hs
- compiler/Language/Haskell/Syntax/Decls.hs
Changes:
=====================================
compiler/GHC/Core.hs
=====================================
@@ -31,9 +31,8 @@ module GHC.Core (
mkDoubleLit, mkDoubleLitDouble,
mkConApp, mkConApp2, mkTyBind, mkCoBind,
- varToCoreExpr, varsToCoreExprs,
+ varToCoreExpr, varsToCoreExprs, mkBinds,
- mkBinds,
isId, cmpAltCon, cmpAlt, ltAlt,
@@ -311,17 +310,6 @@ data Bind b = NonRec b (Expr b)
| Rec [(b, (Expr b))]
deriving Data
--- | Helper function. You can use the result of 'mkBinds' with 'mkLets' for
--- instance.
---
--- * @'mkBinds' 'Recursive' binds@ makes a single mutually-recursive
--- bindings with all the rhs/lhs pairs in @binds@
--- * @'mkBinds' 'NonRecursive' binds@ makes one non-recursive binding
--- for each rhs/lhs pairs in @binds@
-mkBinds :: RecFlag -> [(b, (Expr b))] -> [Bind b]
-mkBinds Recursive binds = [Rec binds]
-mkBinds NonRecursive binds = map (uncurry NonRec) binds
-
{-
Note [Literal alternatives]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -1950,6 +1938,17 @@ deTagAlt (Alt con bndrs rhs) = Alt con [b | TB b _ <- bndrs] (deTagExpr rhs)
************************************************************************
-}
+-- | Helper function. You can use the result of 'mkBinds' with 'mkLets' for
+-- instance.
+--
+-- * @'mkBinds' 'Recursive' binds@ makes a single mutually-recursive
+-- bindings with all the rhs/lhs pairs in @binds@
+-- * @'mkBinds' 'NonRecursive' binds@ makes one non-recursive binding
+-- for each rhs/lhs pairs in @binds@
+mkBinds :: RecFlag -> [(b, (Expr b))] -> [Bind b]
+mkBinds Recursive binds = [Rec binds]
+mkBinds NonRecursive binds = map (uncurry NonRec) binds
+
-- | Apply a list of argument expressions to a function expression in a nested fashion. Prefer to
-- use 'GHC.Core.Make.mkCoreApps' if possible
mkApps :: Expr b -> [Arg b] -> Expr b
=====================================
compiler/GHC/Core/FVs.hs
=====================================
@@ -613,7 +613,6 @@ idFVs id = assert (isId id) $
bndrRuleAndUnfoldingVarsDSet :: Id -> DVarSet
bndrRuleAndUnfoldingVarsDSet id = fvDVarSet $ bndrRuleAndUnfoldingFVs id
-
bndrRuleAndUnfoldingIds :: Id -> IdSet
bndrRuleAndUnfoldingIds id = fvVarSet $ filterFV isId $ bndrRuleAndUnfoldingFVs id
@@ -734,13 +733,16 @@ freeVars = go
go (Case scrut bndr ty alts)
= ( (bndr `delBinderFV` alts_fvs)
- `unionFVs` freeVarsOf scrut2
+ `unionFVs` scrut_fvs
`unionFVs` tyCoVarsOfTypeDSet ty
-- Don't need to look at (idType bndr)
-- because that's redundant with scrut
- , AnnCase scrut2 bndr ty alts2 )
+ , AnnCase (case_head_fvs, scrut2) bndr ty alts2 )
where
- scrut2 = go scrut
+ (scrut_fvs, scrut2) = go scrut
+ case_head_fvs = scrut_fvs `unionFVs`
+ dVarTypeTyCoVars bndr `unionFVs`
+ tyCoVarsOfTypeDSet ty
(alts_fvs_s, alts2) = mapAndUnzip fv_alt alts
alts_fvs = unionFVss alts_fvs_s
=====================================
compiler/GHC/Core/Opt/CSE.hs
=====================================
@@ -404,7 +404,7 @@ cseBind toplevel env (Rec [(in_id, rhs)])
= (extendCSRecEnv env1 out_id rhs'' id_expr', Rec [(zapped_id, rhs')])
where
- (env1, Identity out_id) = addRecBinders env (Identity in_id)
+ (env1, out_id) = addRecBinder env in_id
rhs' = cseExpr env1 rhs
rhs'' = stripTicksE tickishFloatable rhs'
ticks = stripTicksT tickishFloatable rhs'
@@ -905,8 +905,16 @@ addBinders cse vs = (cse { cs_subst = sub' }, vs')
where
(sub', vs') = substBndrs (cs_subst cse) vs
+
+addRecBinder :: CSEnv -> Id -> (CSEnv, Id)
+{-# INLINE addRecBinder #-}
+addRecBinder env id = (env', id')
+ where
+ (env', Identity id') = addRecBinders env (Identity id)
+
addRecBinders :: Traversable f => CSEnv -> f Id -> (CSEnv, f Id)
+-- Used with f=[] (for a list) and f=Identity (for a single binder)
+{-# INLINE addRecBinders #-}
addRecBinders = \ cse vs ->
let (sub', vs') = substRecBndrs (cs_subst cse) vs
in (cse { cs_subst = sub' }, vs')
-{-# INLINE addRecBinders #-}
=====================================
compiler/GHC/Core/Opt/FloatIn.hs
=====================================
@@ -433,11 +433,19 @@ idFreeVars.
-}
fiExpr platform to_drop (_,AnnLet bind body)
+ | Just bind' <- is_tyco_bind bind -- See Note [Don't float in type or coercion lets]
+ = Let bind' (fiExpr platform to_drop body)
+ | otherwise
= fiExpr platform (after ++ new_float : before) body
-- to_drop is in reverse dependency order
where
(before, new_float, after) = fiBind platform to_drop bind body_fvs
- body_fvs = freeVarsOf body
+ body_fvs = freeVarsOf body
+
+ is_tyco_bind :: CoreBindWithFVs -> Maybe CoreBind
+ is_tyco_bind (AnnNonRec bndr (_, AnnType ty)) = Just (NonRec bndr (Type ty))
+ is_tyco_bind (AnnNonRec bndr (_, AnnCoercion co)) = Just (NonRec bndr (Coercion co))
+ is_tyco_bind _ = Nothing
{- Note [Floating primops]
~~~~~~~~~~~~~~~~~~~~~~~~~~
@@ -568,8 +576,7 @@ fiExpr platform to_drop (_, AnnCase scrut case_bndr ty alts)
scrut_fvs = freeVarsOf scrut
-- all_alt_bndrs: see Note [Shadowing and name capture]
- -- dVarTypeTyCoVars: see Note [Floating type-lets inwards]
- case_bndr_bndrs = dVarTypeTyCoVars case_bndr `extendDVarSet` case_bndr
+ case_bndr_bndrs = unitDVarSet case_bndr
all_alt_bndrs = foldr (unionDVarSet . ann_alt_bndrs) case_bndr_bndrs alts
ann_alt_bndrs (AnnAlt _ bndrs _) = mkDVarSet bndrs
=====================================
compiler/GHC/Core/Opt/Simplify/Env.hs
=====================================
@@ -346,7 +346,7 @@ data SimplFloats
}
instance Outputable SimplFloats where
- ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = is })
+ ppr (SimplFloats { sfLetFloats = lf, sfJoinFloats = jf, sfInScope = _is })
= text "SimplFloats"
<+> braces (vcat [ text "lets: " <+> ppr lf
, text "joins:" <+> ppr jf
@@ -706,7 +706,8 @@ type JoinFloats = OrdList JoinFloat
data FloatFlag
= FltLifted -- All bindings are lifted and lazy *or*
- -- consist of a single primitive string literal
+ -- consist of a single primitive string literal *or*
+ -- or are a type binding
-- Hence ok to float to top level, or recursive
-- NB: consequence: all bindings satisfy let-can-float invariant
@@ -805,9 +806,10 @@ unitJoinFloat bind = assert (all isJoinId (bindersOf bind)) $
mkTyVarFloatBind :: SimplEnv -> InTyVar -> OutTyVar -> OutType -> (SimplFloats, SimplEnv)
mkTyVarFloatBind env@(SimplEnv { seTvSubst = tv_subst, seInScope = in_scope }) old_tv new_tv rhs_ty
- = (floats, env { seTvSubst = tv_subst' })
+ = assertPpr(isTyVar new_tv) (ppr old_tv $$ ppr new_tv) $
+ (floats, env { seTvSubst = tv_subst' })
where
- floats = SimplFloats { sfLetFloats = unitLetFloat (NonRec new_tv_w_unf (Type rhs_ty))
+ floats = SimplFloats { sfLetFloats = unitLetFloat (NonRec new_tv_w_unf (Type rhs_ty))
, sfJoinFloats = emptyJoinFloats
, sfInScope = in_scope }
tv_subst' = extendVarEnv tv_subst old_tv (mkTyVarTy new_tv_w_unf)
@@ -893,19 +895,24 @@ addJoinFlts = appOL
mkRecFloats :: SimplFloats -> SimplFloats
-- Flattens the floats into a single Rec group,
-- They must either all be lifted LetFloats or all JoinFloats
-mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs _ff
- , sfJoinFloats = jbs
+-- If any are type bindings they must be non-recursive, so
+-- do not need to be joined into a letrec
+mkRecFloats floats@(SimplFloats { sfLetFloats = LetFloats bs ff
+ , sfJoinFloats = join_bs
, sfInScope = in_scope })
- = assertPpr (isNilOL bs || isNilOL jbs) (ppr floats) $
- SimplFloats { sfLetFloats = floats'
- , sfJoinFloats = jfloats'
+ = assertPpr (isNilOL bs || isNilOL join_bs) (ppr floats) $
+ SimplFloats { sfLetFloats = LetFloats (type_bs `appOL` val_b) ff
+ , sfJoinFloats = join_b
, sfInScope = in_scope }
where
+ type_bs, val_bs :: OrdList OutBind
+ (type_bs, val_bs) = partitionOL isTypeBind bs
+
-- See Note [Bangs in the Simplifier]
- !floats' | isNilOL bs = emptyLetFloats
- | otherwise = unitLetFloat (Rec (flattenBinds (fromOL bs)))
- !jfloats' | isNilOL jbs = emptyJoinFloats
- | otherwise = unitJoinFloat (Rec (flattenBinds (fromOL jbs)))
+ !val_b | isNilOL val_bs = nilOL
+ | otherwise = unitOL (Rec (flattenBinds (fromOL val_bs)))
+ !join_b | isNilOL join_bs = nilOL
+ | otherwise = unitOL (Rec (flattenBinds (fromOL join_bs)))
wrapFloats :: SimplFloats -> OutExpr -> OutExpr
-- Wrap the floats around the expression
=====================================
compiler/GHC/Core/Opt/Simplify/Iteration.hs
=====================================
@@ -226,8 +226,9 @@ simplTopBinds env0 binds0
= simplRecBind env (BC_Let TopLevel Recursive) pairs
simpl_bind env (NonRec b r)
= do { let bind_cxt = BC_Let TopLevel NonRecursive
- ; (env', b') <- addBndrRules env b (lookupRecBndr env b) bind_cxt
- ; simplRecOrTopPair env' bind_cxt b b' r }
+ b' = lookupRecBndr env b
+ ; (env', b') <- addBndrRules env bind_cxt b b'
+ ; simplRecOrTopPair env' bind_cxt b b' r }
{-
************************************************************************
@@ -253,7 +254,7 @@ simplRecBind env0 bind_cxt pairs0
add_rules :: SimplEnv -> (InBndr,InExpr) -> SimplM (SimplEnv, (InBndr, OutBndr, InExpr))
-- Add the (substituted) rules to the binder
add_rules env (bndr, rhs)
- = do { (env', bndr') <- addBndrRules env bndr (lookupRecBndr env bndr) bind_cxt
+ = do { (env', bndr') <- addBndrRules env bind_cxt bndr (lookupRecBndr env bndr)
; return (env', (bndr, bndr', rhs)) }
go env [] = return (emptyFloats env, env)
@@ -281,7 +282,7 @@ simplRecOrTopPair env bind_cxt old_bndr new_bndr rhs
| Just env' <- preInlineUnconditionally env (bindContextLevel bind_cxt)
old_bndr rhs env
= {-#SCC "simplRecOrTopPair-pre-inline-uncond" #-}
- simplTrace "SimplBindr:inline-uncond" (ppr old_bndr) $
+ simplTrace "SimplBindr:inline-uncond" (ppr old_bndr <+> equals <+> ppr rhs) $
do { tick (PreInlineUnconditionally old_bndr)
; return ( emptyFloats env, env' ) }
@@ -343,7 +344,10 @@ simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
-- Simplify the RHS
; let rhs_cont = mkRhsStop (substTy body_env (exprType body))
is_rec (idDemandInfo bndr)
- ; (body_floats0, body0) <- {-#SCC "simplExprF" #-} simplExprF body_env body rhs_cont
+ ; (body_floats0, body0) <- {-#SCC "simplExprF" #-}
+ simplExprF body_env body rhs_cont
+ ; (if isTopLevel top_lvl then pprTrace "simplLazyBind" (ppr bndr <+> ppr body_floats0 $$ ppr body0) else id) $
+ return ()
-- ANF-ise a constructor or PAP rhs
; (body_floats2, body2) <- {-#SCC "prepareBinding" #-}
@@ -356,16 +360,20 @@ simplLazyBind top_lvl is_rec (bndr,unf_se) (bndr1,env) (rhs,rhs_se)
-- more renaming than necessary => extra work (see !7777 and test T16577).
-- Don't need: we wrap tvs' around the RHS anyway.
+ ; let float_bndrs2 = bindersOfBinds $ letFloatBinds $ sfLetFloats body_floats2
+ -- float_bndrs2 used only in debugging
+
; (rhs_floats, body3)
<- if isEmptyFloats body_floats2 || null tvs then -- Simple floating
{-#SCC "simplLazyBind-simple-floating" #-}
return (body_floats2, body2)
- else if any isTyCoVar
- (bindersOfBinds $ letFloatBinds $ sfLetFloats body_floats2)
- then pprTrace "WARNING-TyCo: skipping abstractFloats" (ppr bndr $$ ppr body_floats2) $
- -- No Float
- return (emptyFloats env, wrapFloats body_floats2 body2)
+ else if any isTyCoVar float_bndrs2
+ then (if not (any isId float_bndrs2) then id
+ else pprTrace "WARNING-TyCo: skipping abstractFloats"
+ (ppr bndr $$ ppr body_floats2)) $
+ -- No Float because of the type bindings
+ return (emptyFloats env, wrapFloats body_floats2 body2)
else -- Non-empty floats, and non-empty tyvars: do type-abstraction first
{-#SCC "simplLazyBind-type-abstraction-first" #-}
@@ -1576,7 +1584,7 @@ completeBindX env from_what bndr rhs body cont
| otherwise -- Make a let-binding
= do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
+ ; (env2, bndr2) <- addBndrRules env1 (BC_Let NotTopLevel NonRecursive) bndr bndr1
; let is_strict = isStrictId bndr2
-- isStrictId: use simplified binder because the InId bndr might not have
@@ -1921,7 +1929,7 @@ simplNonRecE env from_what bndr (rhs, rhs_se) body cont
| otherwise -- Evaluate RHS lazily
= do { (env1, bndr1) <- simplNonRecBndr env bndr
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Let NotTopLevel NonRecursive)
+ ; (env2, bndr2) <- addBndrRules env1 (BC_Let NotTopLevel NonRecursive) bndr bndr1
; (floats1, env3) <- simplLazyBind NotTopLevel NonRecursive
(bndr,env) (bndr2,env2) (rhs,rhs_se)
; (floats2, expr') <- simplNonRecBody env3 from_what body cont
@@ -2065,7 +2073,7 @@ simplNonRecJoinPoint env bndr rhs body cont
; let mult = contHoleScaling cont
res_ty = contResultType cont
; (env1, bndr1) <- simplNonRecJoinBndr env bndr mult res_ty
- ; (env2, bndr2) <- addBndrRules env1 bndr bndr1 (BC_Join NonRecursive cont)
+ ; (env2, bndr2) <- addBndrRules env1 (BC_Join NonRecursive cont) bndr bndr1
; (floats1, env3) <- simplJoinBind NonRecursive cont (bndr,env) (bndr2,env2) (rhs,env)
; (floats2, body') <- simplExprF env3 body cont
; return (floats1 `addFloats` floats2, body') }
@@ -4701,11 +4709,11 @@ to apply in that function's own right-hand side.
See Note [Forming Rec groups] in "GHC.Core.Opt.OccurAnal"
-}
-addBndrRules :: SimplEnv -> InVar -> OutVar
- -> BindContext
+addBndrRules :: SimplEnv -> BindContext
+ -> InVar -> OutVar
-> SimplM (SimplEnv, OutBndr)
-- Rules are added back into the bin
-addBndrRules env in_id out_id bind_cxt
+addBndrRules env bind_cxt in_id out_id
| isTyVar in_id
= return (env, out_id)
| null old_rules
=====================================
compiler/GHC/Core/Opt/Simplify/Utils.hs
=====================================
@@ -1492,7 +1492,7 @@ preInlineUnconditionally env top_lvl bndr rhs rhs_env
where
unf = idUnfolding bndr
extend_id_subst_with inl_rhs = extendIdSubst env bndr $! (mkContEx rhs_env inl_rhs)
- extend_tv_subst_with ty = extendTvSubst env bndr ty
+ extend_tv_subst_with ty = extendTvSubst env bndr $! (substTy rhs_env ty)
one_occ IAmDead = True -- Happens in ((\x.1) v)
one_occ OneOcc{ occ_n_br = 1
=====================================
compiler/GHC/Core/Subst.hs
=====================================
@@ -354,23 +354,28 @@ substBndrs = mapAccumL substBndr
{-# INLINE substBndrs #-}
-- | Substitute in a mutually recursive group of 'Id's
-substRecBndrs :: Traversable f => Subst -> f Id -> (Subst, f Id)
+substRecBndrs :: (HasDebugCallStack, Traversable f) => Subst -> f Id -> (Subst, f Id)
+-- Used with f=[] (for a list) and f=Identity (for a single binder)
substRecBndrs subst bndrs
= (new_subst, new_bndrs)
where -- Here's the reason we need to pass rec_subst to subst_id
(new_subst, new_bndrs) = mapAccumL (substIdBndr (text "rec-bndr") new_subst) subst bndrs
-{-# SPECIALIZE substRecBndrs :: Subst -> [Id] -> (Subst, [Id]) #-}
-{-# SPECIALIZE substRecBndrs :: Subst -> Identity Id -> (Subst, Identity Id) #-}
+{-# SPECIALIZE substRecBndrs :: HasDebugCallStack => Subst -> [Id] -> (Subst, [Id]) #-}
+{-# SPECIALIZE substRecBndrs :: HasDebugCallStack => Subst -> Identity Id -> (Subst, Identity Id) #-}
-substIdBndr :: SDoc
+substIdBndr :: HasDebugCallStack
+ => SDoc
-> Subst -- ^ Substitution to use for the IdInfo
-> Subst -> Id -- ^ Substitution and Id to transform
-> (Subst, Id) -- ^ Transformed pair
-- NB: unfolding may be zapped
-substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
- = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
- (Subst new_in_scope new_env tvs cvs, new_id)
+substIdBndr _doc rec_subst subst old_id
+ = assertPpr (isId old_id) (ppr old_id) $
+ substIdBndr' _doc rec_subst subst old_id
+
+substIdBndr' _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
+ = (Subst new_in_scope new_env tvs cvs, new_id)
where
id1 = uniqAway in_scope old_id -- id1 is cloned if necessary
id2 | no_type_change = id1
=====================================
compiler/GHC/Core/Type.hs
=====================================
@@ -509,10 +509,12 @@ on its fast path must also be inlined, linked back to this Note.
********************************************************************* -}
expandTyVarUnfoldings :: TyVarEnv Type -> Type -> Type
--- (expandTyvarUnfoldings tvs ty) replace any occurrences of tvs in ty
--- with their unfoldings. There are no substitution or variable-capture
--- issues: if we have (let @a = ty in body), then at all occurrences of `a`
--- the free vars of `body` are also in scope, without having been shadowed.
+-- (expandTyvarUnfoldings tvs ty) replace any occurrences of `tvs` in `ty`
+-- with their unfoldings. The returned type does not mention any of `tvs`.
+--
+-- There are no substitution or variable-capture issues: if we have (let @a = ty
+-- in body), then at all occurrences of `a` the free vars of `body` are also in
+-- scope, without having been shadowed.
expandTyVarUnfoldings tvs ty
| isEmptyVarEnv tvs = ty
| otherwise = runIdentity (expand ty)
@@ -523,7 +525,7 @@ expandTyVarUnfoldings tvs ty
, tcm_hole = exp_hole, tcm_tycobinder = exp_tcb
, tcm_tycon = pure })
exp_tv _ tv = case lookupVarEnv tvs tv of
- Just ty -> pure ty
+ Just ty -> expand ty
Nothing -> pure (TyVarTy tv)
exp_cv _ cv = pure (CoVarCo cv)
exp_hole _ cv = pprPanic "expand_tv_unf" (ppr cv)
=====================================
compiler/GHC/Core/Utils.hs
=====================================
@@ -54,8 +54,7 @@ module GHC.Core.Utils (
collectMakeStaticArgs,
-- * Predicates on binds
- isJoinBind,
- isTypeBind,
+ isJoinBind, isTypeBind, isTyCoBind,
-- * Tag inference
mkStrictFieldSeqs, shouldStrictifyIdForCbv, shouldUseCbvForId,
@@ -2662,6 +2661,17 @@ locBind loc b1 b2 diffs = map addLoc diffs
| otherwise = ppr b1 <> char '/' <> ppr b2
+dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
+dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids)
+ where
+ ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
+ getIds (NonRec i _) = [ i ]
+ getIds (Rec bs) = map fst bs
+ -- By default only include full info for exported ids, unless we run in the verbose
+ -- pprDebug mode.
+ printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id))
+ | otherwise = empty
+
{- *********************************************************************
* *
\subsection{Determining non-updatable right-hand-sides}
@@ -2755,33 +2765,27 @@ collectMakeStaticArgs _ = Nothing
{-
************************************************************************
* *
-\subsection{Predicates on binds}
+ Predicates on binds
* *
************************************************************************
-}
+-- | `isTypeBind` is True of type bindings (@a = Type ty)
+isTypeBind :: Bind b -> Bool
+isTypeBind (NonRec _ (Type {})) = True
+isTypeBind _ = False
+
+-- | `isTypeBind` is True of type bindings (@a = Type ty)
+isTyCoBind :: Bind b -> Bool
+isTyCoBind (NonRec _ (Type {})) = True
+isTyCoBind (NonRec _ (Coercion {})) = True
+isTyCoBind _ = False
+
isJoinBind :: CoreBind -> Bool
isJoinBind (NonRec b _) = isJoinId b
isJoinBind (Rec ((b, _) : _)) = isJoinId b
isJoinBind _ = False
--- | Does this binding bind a type?
-isTypeBind :: CoreBind -> Bool
--- See Note [Type and coercion lets] in GHC.Core
-isTypeBind (NonRec b (Type _)) = isTyVar b
-isTypeBind _ = False
-
-dumpIdInfoOfProgram :: Bool -> (IdInfo -> SDoc) -> CoreProgram -> SDoc
-dumpIdInfoOfProgram dump_locals ppr_id_info binds = vcat (map printId ids)
- where
- ids = sortBy (stableNameCmp `on` getName) (concatMap getIds binds)
- getIds (NonRec i _) = [ i ]
- getIds (Rec bs) = map fst bs
- -- By default only include full info for exported ids, unless we run in the verbose
- -- pprDebug mode.
- printId id | isExportedId id || dump_locals = ppr id <> colon <+> (ppr_id_info (idInfo id))
- | otherwise = empty
-
{-
************************************************************************
* *
=====================================
compiler/GHC/Tc/Zonk/Type.hs
=====================================
@@ -671,7 +671,7 @@ zonkTopDecls ev_binds binds rules imp_specs fords
-- Top level is implicitly recursive
do { rules' <- zonkRules rules
; specs' <- zonkLTcSpecPrags imp_specs
- ; fords' <- zonkForeignExports fords
+ ; fords' <- zonkForeignDecls fords
; ty_env <- zonkEnvIds <$> getZonkEnv
; return (ty_env, ev_binds', binds', fords', specs', rules') }
@@ -1650,19 +1650,20 @@ zonkPats = traverse zonkPat
************************************************************************
-}
-zonkForeignExports :: [LForeignDecl GhcTc]
+zonkForeignDecls :: [LForeignDecl GhcTc]
-> ZonkTcM [LForeignDecl GhcTc]
-zonkForeignExports ls = mapM (wrapLocZonkMA zonkForeignExport) ls
-
-zonkForeignExport :: ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc)
-zonkForeignExport (ForeignExport { fd_name = i, fd_e_ext = co
- , fd_fe = spec })
- = do { i' <- zonkLIdOcc i
- ; return (ForeignExport { fd_name = i'
- , fd_sig_ty = undefined, fd_e_ext = co
- , fd_fe = spec }) }
-zonkForeignExport for_imp
- = return for_imp -- Foreign imports don't need zonking
+zonkForeignDecls ls = mapM (wrapLocZonkMA zonkForeignDecl) ls
+
+zonkForeignDecl :: ForeignDecl GhcTc -> ZonkTcM (ForeignDecl GhcTc)
+-- Zonk foreign decls, even though they are closed, to turn TcTyVars into TyVars
+zonkForeignDecl fd@(ForeignExport { fd_name = i, fd_e_ext = co })
+ = do { i' <- zonkLIdOcc i
+ ; co' <- zonkCoToCo co
+ ; return (fd { fd_name = i', fd_e_ext = co' }) }
+zonkForeignDecl fd@(ForeignImport { fd_name = i, fd_i_ext = co })
+ = do { i' <- zonkLIdOcc i
+ ; co' <- zonkCoToCo co
+ ; return (fd { fd_name = i', fd_i_ext = co' }) }
zonkRules :: [LRuleDecl GhcTc] -> ZonkTcM [LRuleDecl GhcTc]
zonkRules rs = mapM (wrapLocZonkMA zonkRule) rs
=====================================
compiler/Language/Haskell/Syntax/Decls.hs
=====================================
@@ -1398,13 +1398,13 @@ type LForeignDecl pass = XRec pass (ForeignDecl pass)
-- | Foreign Declaration
data ForeignDecl pass
= ForeignImport
- { fd_i_ext :: XForeignImport pass -- Post typechecker, rep_ty ~ sig_ty
+ { fd_i_ext :: XForeignImport pass -- Post typechecker, co : rep_ty ~ sig_ty
, fd_name :: LIdP pass -- defines this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
, fd_fi :: ForeignImport pass }
| ForeignExport
- { fd_e_ext :: XForeignExport pass -- Post typechecker, rep_ty ~ sig_ty
+ { fd_e_ext :: XForeignExport pass -- Post typechecker, co : rep_ty ~ sig_ty
, fd_name :: LIdP pass -- uses this name
, fd_sig_ty :: LHsSigType pass -- sig_ty
, fd_fe :: ForeignExport pass }
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc780436d233e1ea8d892ea659f28721efca09d9
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/dc780436d233e1ea8d892ea659f28721efca09d9
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/20241031/8be70511/attachment-0001.html>
More information about the ghc-commits
mailing list