Simon Peyton Jones pushed to branch wip/spj-try-opt-coercion at Glasgow Haskell Compiler / GHC Commits: 25b2a74c by Simon Peyton Jones at 2026-01-05T11:31:43+00:00 More on exported coercions - - - - - 5 changed files: - compiler/GHC/CoreToIface.hs - compiler/GHC/Iface/Rename.hs - compiler/GHC/Iface/Syntax.hs - compiler/GHC/Iface/Type.hs - compiler/GHC/IfaceToCore.hs Changes: ===================================== compiler/GHC/CoreToIface.hs ===================================== @@ -223,9 +223,6 @@ toIfaceTypeX fr (TyConApp tc tys) toIfaceTyVar :: TyVar -> IfLclName toIfaceTyVar = mkIfLclName . occNameFS . getOccName -toIfaceCoVar :: CoVar -> IfLclName -toIfaceCoVar = mkIfLclName . occNameFS . getOccName - ---------------- toIfaceTyCon :: TyCon -> IfaceTyCon toIfaceTyCon tc @@ -287,7 +284,11 @@ toIfaceCoercionX fr co go (CoVarCo cv) -- See Note [Free TyVars and CoVars in IfaceType] in GHC.Iface.Type | cv `elemVarSet` fr = IfaceFreeCoVar cv - | otherwise = IfaceCoVarCo (toIfaceCoVar cv) + | isExternalName nm = IfaceExtCoVar nm + | otherwise = IfaceCoVarCo (mkIfLclName $ occNameFS $ nameOccName nm) + where + nm = idName cv + go (HoleCo h) = IfaceHoleCo (coHoleCoVar h) go (AppCo co1 co2) = IfaceAppCo (go co1) (go co2) @@ -454,6 +455,7 @@ toIfaceTopBndr id toIfaceIdDetails :: IdDetails -> IfaceIdDetails toIfaceIdDetails VanillaId = IfVanillaId toIfaceIdDetails (WorkerLikeId dmds) = IfWorkerLikeId dmds +toIfaceIdDetails CoVarId = IfCoVarId toIfaceIdDetails (DFunId {}) = IfDFunId toIfaceIdDetails (RecSelId { sel_naughty = n , sel_tycon = tc ===================================== compiler/GHC/Iface/Rename.hs ===================================== @@ -886,13 +886,14 @@ rnIfaceMCo IfaceMRefl = pure IfaceMRefl rnIfaceMCo (IfaceMCo co) = IfaceMCo <$> rnIfaceCo co rnIfaceCo :: Rename IfaceCoercion +rnIfaceCo co@(IfaceExtCoVar {}) = pure co +rnIfaceCo co@(IfaceFreeCoVar {}) = pure co +rnIfaceCo co@(IfaceCoVarCo {}) = pure co rnIfaceCo (IfaceReflCo ty) = IfaceReflCo <$> rnIfaceType ty rnIfaceCo (IfaceGReflCo role ty mco) = IfaceGReflCo role <$> rnIfaceType ty <*> rnIfaceMCo mco rnIfaceCo (IfaceFunCo role w co1 co2) = IfaceFunCo role <$> rnIfaceCo w <*> rnIfaceCo co1 <*> rnIfaceCo co2 rnIfaceCo (IfaceTyConAppCo role tc cos) = IfaceTyConAppCo role <$> rnIfaceTyCon tc <*> mapM rnIfaceCo cos rnIfaceCo (IfaceAppCo co1 co2) = IfaceAppCo <$> rnIfaceCo co1 <*> rnIfaceCo co2 -rnIfaceCo (IfaceFreeCoVar c) = pure (IfaceFreeCoVar c) -rnIfaceCo (IfaceCoVarCo lcl) = IfaceCoVarCo <$> pure lcl rnIfaceCo (IfaceHoleCo lcl) = IfaceHoleCo <$> pure lcl rnIfaceCo (IfaceSymCo c) = IfaceSymCo <$> rnIfaceCo c rnIfaceCo (IfaceTransCo c1 c2) = IfaceTransCo <$> rnIfaceCo c1 <*> rnIfaceCo c2 ===================================== compiler/GHC/Iface/Syntax.hs ===================================== @@ -490,6 +490,7 @@ data IfGuidance data IfaceIdDetails = IfVanillaId + | IfCoVarId | IfWorkerLikeId [CbvMark] | IfRecSelId { ifRecSelIdParent :: Either IfaceTyCon IfaceDecl @@ -1877,6 +1878,7 @@ instance Outputable IfaceIdDetails where then text "<naughty>" else Outputable.empty ppr IfDFunId = text "DFunId" + ppr IfCoVarId = text "CoVarId" instance Outputable IfaceInfoItem where ppr (HsUnfold lb unf) = text "Unfolding" @@ -1994,6 +1996,7 @@ freeNamesIfIdDetails (IfRecSelId tc first_con _ fl) = freeNamesIfIdDetails IfVanillaId = emptyNameSet freeNamesIfIdDetails (IfWorkerLikeId {}) = emptyNameSet freeNamesIfIdDetails IfDFunId = emptyNameSet +freeNamesIfIdDetails IfCoVarId = emptyNameSet -- All other changes are handled via the version info on the tycon freeNamesIfFamFlav :: IfaceFamTyConFlav -> NameSet @@ -2086,6 +2089,7 @@ freeNamesIfCoercion (IfaceAppCo c1 c2) freeNamesIfCoercion (IfaceForAllCo _tcv _visL _visR kind_co co) = freeNamesIfMCoercion kind_co &&& freeNamesIfCoercion co freeNamesIfCoercion (IfaceFreeCoVar _) = emptyNameSet +freeNamesIfCoercion (IfaceExtCoVar n) = unitNameSet n freeNamesIfCoercion (IfaceCoVarCo _) = emptyNameSet freeNamesIfCoercion (IfaceHoleCo _) = emptyNameSet freeNamesIfCoercion (IfaceUnivCo _ _ t1 t2 cos) @@ -2718,6 +2722,7 @@ instance Binary IfaceIdDetails where ; put_ bh d } put_ bh (IfWorkerLikeId dmds) = putByte bh 2 >> put_ bh dmds put_ bh IfDFunId = putByte bh 3 + put_ bh IfCoVarId = putByte bh 4 get bh = do h <- getByte bh case h of @@ -2729,7 +2734,8 @@ instance Binary IfaceIdDetails where ; return (IfRecSelId a b c d) } 2 -> do { dmds <- get bh ; return (IfWorkerLikeId dmds) } - _ -> return IfDFunId + 3 -> return IfDFunId + _ -> return IfCoVarId instance Binary IfaceInfoItem where put_ bh (HsArity aa) = putByte bh 0 >> put_ bh aa @@ -3167,7 +3173,8 @@ instance NFData IfaceIdDetails where IfWorkerLikeId dmds -> rnf dmds `seq` () IfRecSelId (Left tycon) b c d -> rnf tycon `seq` rnf b `seq` rnf c `seq` rnf d IfRecSelId (Right decl) b c d -> rnf decl `seq` rnf b `seq` rnf c `seq` rnf d - IfDFunId -> () + IfDFunId -> () + IfCoVarId -> () instance NFData IfaceInfoItem where rnf = \case ===================================== compiler/GHC/Iface/Type.hs ===================================== @@ -475,13 +475,15 @@ data IfaceMCoercion | IfaceMCo IfaceCoercion deriving (Eq, Ord) data IfaceCoercion - = IfaceReflCo IfaceType + = IfaceFreeCoVar CoVar -- ^ See Note [Free TyVars and CoVars in IfaceType] + | IfaceExtCoVar IfExtName -- Imported or top-level external coercion var + | IfaceCoVarCo IfLclName -- Regular, locally-bound coercion var + | IfaceReflCo IfaceType | IfaceGReflCo Role IfaceType (IfaceMCoercion) | IfaceFunCo Role IfaceCoercion IfaceCoercion IfaceCoercion | IfaceTyConAppCo Role IfaceTyCon [IfaceCoercion] | IfaceAppCo IfaceCoercion IfaceCoercion | IfaceForAllCo IfaceBndr !ForAllTyFlag !ForAllTyFlag IfaceMCoercion IfaceCoercion - | IfaceCoVarCo IfLclName | IfaceAxiomCo IfaceAxiomRule [IfaceCoercion] -- ^ There are only a fixed number of CoAxiomRules, so it suffices -- to use an IfaceLclName to distinguish them. @@ -494,7 +496,6 @@ data IfaceCoercion | IfaceInstCo IfaceCoercion IfaceCoercion | IfaceKindCo IfaceCoercion | IfaceSubCo IfaceCoercion - | IfaceFreeCoVar CoVar -- ^ See Note [Free TyVars and CoVars in IfaceType] | IfaceHoleCo CoVar -- ^ See Note [Holes in IfaceCoercion] deriving (Eq, Ord) -- Why Ord? See Note [Ord instance of IfaceType] @@ -779,9 +780,10 @@ substIfaceType env ty go_co (IfaceTyConAppCo r tc cos) = IfaceTyConAppCo r tc (go_cos cos) go_co (IfaceAppCo c1 c2) = IfaceAppCo (go_co c1) (go_co c2) go_co (IfaceForAllCo {}) = pprPanic "substIfaceCoercion" (ppr ty) - go_co (IfaceFreeCoVar cv) = IfaceFreeCoVar cv - go_co (IfaceCoVarCo cv) = IfaceCoVarCo cv - go_co (IfaceHoleCo cv) = IfaceHoleCo cv + go_co co@(IfaceFreeCoVar {}) = co + go_co co@(IfaceExtCoVar {}) = co + go_co co@(IfaceCoVarCo {}) = co + go_co co@(IfaceHoleCo {}) = co go_co (IfaceUnivCo p r t1 t2 ds) = IfaceUnivCo p r (go t1) (go t2) (go_cos ds) go_co (IfaceSymCo co) = IfaceSymCo (go_co co) go_co (IfaceTransCo co1 co2) = IfaceTransCo (go_co co1) (go_co co2) @@ -2076,8 +2078,9 @@ ppr_co ctxt_prec co@(IfaceForAllCo {}) = let (tvs, co'') = split_co co' in ((bndr,kind_co,visL,visR):tvs,co'') split_co co' = ([], co') --- Why these three? See Note [Free TyVars and CoVars in IfaceType] +-- Why these four? See Note [Free TyVars and CoVars in IfaceType] ppr_co _ (IfaceFreeCoVar covar) = ppr covar +ppr_co _ (IfaceExtCoVar covar) = ppr covar ppr_co _ (IfaceCoVarCo covar) = ppr covar ppr_co _ (IfaceHoleCo covar) = braces (ppr covar) @@ -2457,6 +2460,9 @@ instance Binary IfaceCoercion where put_ bh (IfaceCoVarCo a) = do putByte bh 7 put_ bh a + put_ bh (IfaceExtCoVar a) = do + putByte bh 8 + put_ bh a put_ bh (IfaceUnivCo a b c d deps) = do putByte bh 9 put_ bh a @@ -2530,6 +2536,8 @@ instance Binary IfaceCoercion where return $ IfaceForAllCo a visL visR b c 7 -> do a <- get bh return $ IfaceCoVarCo a + 8 -> do a <- get bh + return $ IfaceExtCoVar a 9 -> do a <- get bh b <- get bh c <- get bh @@ -2605,13 +2613,14 @@ instance NFData IfaceTyLit where instance NFData IfaceCoercion where rnf = \case + IfaceExtCoVar f1 -> rnf f1 + IfaceCoVarCo f1 -> rnf f1 IfaceReflCo f1 -> rnf f1 IfaceGReflCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 IfaceFunCo f1 f2 f3 f4 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 IfaceTyConAppCo f1 f2 f3 -> rnf f1 `seq` rnf f2 `seq` rnf f3 IfaceAppCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceForAllCo f1 f2 f3 f4 f5 -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf f5 - IfaceCoVarCo f1 -> rnf f1 IfaceAxiomCo f1 f2 -> rnf f1 `seq` rnf f2 IfaceUnivCo f1 f2 f3 f4 deps -> rnf f1 `seq` rnf f2 `seq` rnf f3 `seq` rnf f4 `seq` rnf deps IfaceSymCo f1 -> rnf f1 ===================================== compiler/GHC/IfaceToCore.hs ===================================== @@ -1582,41 +1582,35 @@ tcIfaceCo = go go_mco IfaceMRefl = pure MRefl go_mco (IfaceMCo co) = MCo <$> (go co) + go (IfaceExtCoVar n) = CoVarCo <$> tcIfaceExtId n + go (IfaceCoVarCo n) = CoVarCo <$> tcIfaceLclId n go (IfaceReflCo t) = Refl <$> tcIfaceType t go (IfaceGReflCo r t mco) = GRefl r <$> tcIfaceType t <*> go_mco mco go (IfaceFunCo r w c1 c2) = mkFunCoNoFTF r <$> go w <*> go c1 <*> go c2 go (IfaceTyConAppCo r tc cs) = TyConAppCo r <$> tcIfaceTyCon tc <*> mapM go cs go (IfaceAppCo c1 c2) = AppCo <$> go c1 <*> go c2 + go (IfaceSymCo c) = SymCo <$> go c + go (IfaceTransCo c1 c2) = TransCo <$> go c1 <*> go c2 + go (IfaceInstCo c1 t2) = InstCo <$> go c1 <*> go t2 + go (IfaceSelCo d c) = mkSelCo d <$> go c + go (IfaceLRCo lr c) = LRCo lr <$> go c + go (IfaceKindCo c) = KindCo <$> go c + go (IfaceSubCo c) = SubCo <$> go c go (IfaceForAllCo tcv visL visR k co) = do { k' <- go_mco k ; bindIfaceBndr tcv $ \ tv' -> do { co' <- go co ; return (ForAllCo { fco_tcv = tv', fco_visL = visL, fco_visR = visR , fco_kind = k', fco_body = co' }) } } - go (IfaceCoVarCo n) = CoVarCo <$> go_var n go (IfaceUnivCo p r t1 t2 ds) = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2 ; ds' <- mapM go ds ; return (UnivCo { uco_prov = p, uco_role = r , uco_lty = t1', uco_rty = t2' , uco_deps = ds' }) } - go (IfaceSymCo c) = SymCo <$> go c - go (IfaceTransCo c1 c2) = TransCo <$> go c1 - <*> go c2 - go (IfaceInstCo c1 t2) = InstCo <$> go c1 - <*> go t2 - go (IfaceSelCo d c) = do { c' <- go c - ; return $ mkSelCo d c' } - go (IfaceLRCo lr c) = LRCo lr <$> go c - go (IfaceKindCo c) = KindCo <$> go c - go (IfaceSubCo c) = SubCo <$> go c - go (IfaceAxiomCo ax cos) = AxiomCo <$> tcIfaceAxiomRule ax - <*> mapM go cos + go (IfaceAxiomCo ax cos) = AxiomCo <$> tcIfaceAxiomRule ax <*> mapM go cos go (IfaceFreeCoVar c) = pprPanic "tcIfaceCo:IfaceFreeCoVar" (ppr c) go (IfaceHoleCo c) = pprPanic "tcIfaceCo:IfaceHoleCo" (ppr c) - go_var :: IfLclName -> IfL CoVar - go_var = tcIfaceLclId - {- ************************************************************************ * * @@ -1801,6 +1795,7 @@ tcIfaceDataAlt mult con inst_tys arg_strs rhs tcIdDetails :: Name -> Type -> IfaceIdDetails -> IfL IdDetails tcIdDetails _ _ IfVanillaId = return VanillaId +tcIdDetails _ _ IfCoVarId = return CoVarId tcIdDetails _ _ (IfWorkerLikeId dmds) = return $ WorkerLikeId dmds tcIdDetails _ ty IfDFunId = return (DFunId (isUnaryClass cls)) where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25b2a74c138f0a02431bcd64f211e5ee... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/25b2a74c138f0a02431bcd64f211e5ee... You're receiving this email because of your account on gitlab.haskell.org.