[Git][ghc/ghc][wip/sand-witch/dep-anal] Progress: ghc panics with out-of-scope sigs

Vladislav Zavialov (@int-index) gitlab at gitlab.haskell.org
Tue Jun 27 20:36:44 UTC 2023



Vladislav Zavialov pushed to branch wip/sand-witch/dep-anal at Glasgow Haskell Compiler / GHC


Commits:
b492edf0 by Vladislav Zavialov at 2023-06-27T22:36:35+02:00
Progress: ghc panics with out-of-scope sigs

- - - - -


4 changed files:

- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Rename/Module.hs
- compiler/GHC/Tc/Gen/HsType.hs
- compiler/GHC/Tc/TyCl.hs


Changes:

=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -132,6 +132,7 @@ import GHC.Data.Bag
 import GHC.Data.Maybe
 import Data.Data (Data)
 import Data.Foldable (toList)
+import Data.Void
 
 {-
 ************************************************************************
@@ -671,7 +672,7 @@ type LDeclHeaderRn = LocatedA DeclHeaderRn
 --
 data DeclHeaderRn
   = DeclHeaderRn
-      { decl_header_flav :: TyConFlavour GhcRn,
+      { decl_header_flav :: TyConFlavour Void,
         decl_header_name :: Name,
         decl_header_cusk :: Bool,
         decl_header_bndrs :: LHsQTyVars GhcRn,


=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -62,7 +62,7 @@ import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
 import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )
-import GHC.Data.Graph.Directed ( SCC, flattenSCC, flattenSCCs, Node(..)
+import GHC.Data.Graph.Directed ( SCC, flattenSCC, Node(..)
                                , stronglyConnCompFromEdgedVerticesUniq, stronglyConnCompFromEdgedVerticesOrd )
 import GHC.Types.Unique.Set
 import GHC.Data.OrdList
@@ -1414,13 +1414,11 @@ rnTyClDecls :: [TyClGroup GhcPs]
 rnTyClDecls tycl_ds
   = do { -- Rename the type/class, instance, and role declarations
        ; tycls_w_fvs' <- mapM (wrapLocFstMA rnTyClDecl) (tyClGroupTyClDecls tycl_ds)
-       ; let
-            tycls_w_fvs = map (\(L l (t, fv1), fv2) -> (L l t, fv1 `plusFV` fv2)) tycls_w_fvs'
-            tycls_w_fvs_new = map (\(L l (t, fv1), fv2) -> ((L l t, fv1), fv2)) tycls_w_fvs'
-       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst) tycls_w_fvs)
-       ; let decl_headers = mkNameEnv (map mk_pair tycls_w_fvs_new)
+       ; let tycls_w_fvs = map (\(L l (t, fv1), fv2) -> ((L l t, fv1), fv2)) tycls_w_fvs'
+       ; let tc_names = mkNameSet (map (tcdName . unLoc . fst . fst) tycls_w_fvs)
+       ; let decl_headers = mkNameEnv (map mk_pair tycls_w_fvs)
                 where
-                  mk_pair = \((L l t, _fv1), fv2)->
+                  mk_pair ((L l t, _fv1), fv2) =
                     let hdr = mkDeclHeaderRn t
                     in (decl_header_name hdr, (L l hdr, fv2))
        ; traceRn "rnTyClDecls" $
@@ -1428,67 +1426,21 @@ rnTyClDecls tycl_ds
                 , text "tc_names:" <+> ppr tc_names ]
        ; kisigs_w_fvs <- rnStandaloneKindSignatures tc_names decl_headers (tyClGroupKindSigs tycl_ds)
        ; instds_w_fvs <- mapM (wrapLocFstMA rnSrcInstDecl) (tyClGroupInstDecls tycl_ds)
-       ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
+       -- ; role_annots  <- rnRoleAnnots tc_names (tyClGroupRoleDecls tycl_ds)
 
        -- Do SCC analysis on the type/class decls
        ; rdr_env <- getGlobalRdrEnv
        ; traceRn "rnTyClDecls SCC analysis" $
            vcat [ text "rdr_env:" <+> ppr rdr_env ]
-       ; let tycl_sccs = depAnalTyClDecls rdr_env kisig_fv_env tycls_w_fvs
-             role_annot_env = mkRoleAnnotEnv role_annots
-             (kisig_env, kisig_fv_env) = mkKindSig_fv_env kisigs_w_fvs
-
-             inst_ds_map = mkInstDeclFreeVarsMap rdr_env tc_names instds_w_fvs
-             (init_inst_ds, rest_inst_ds) = getInsts [] inst_ds_map
-
-             first_group
-               | null init_inst_ds = []
-               | otherwise = [TyClGroup { group_ext    = noExtField
-                                        , group_tyclds = []
-                                        , group_kisigs = []
-                                        , group_roles  = []
-                                        , group_instds = init_inst_ds }]
-
-             (final_inst_ds, groups)
-                = mapAccumL (mk_group role_annot_env kisig_env) rest_inst_ds tycl_sccs
-
-             all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`
+       ; let all_fvs = foldr (plusFV . snd) emptyFVs tycls_w_fvs  `plusFV`
                        foldr (plusFV . snd) emptyFVs instds_w_fvs `plusFV`
                        foldr (plusFV . snd) emptyFVs kisigs_w_fvs
+       ; let all_groups = doDepAnal kisigs_w_fvs instds_w_fvs tycls_w_fvs rdr_env
 
-             all_groups = first_group ++ groups
-
-       ; massertPpr (null final_inst_ds)
-                    (ppr instds_w_fvs
-                     $$ ppr inst_ds_map
-                     $$ ppr (flattenSCCs tycl_sccs)
-                     $$ ppr final_inst_ds)
-
-       ; traceRn "rnTycl dependency analysis made groups" (ppr all_groups)
-
-       ; traceRn "rnTyClDecls NEW SCC anal could have made groups" $
-          (ppr (doDepAnal kisigs_w_fvs instds_w_fvs tycls_w_fvs_new rdr_env))
+       ; traceRn "rnTyClDecls made groups" $
+          (ppr all_groups)
 
        ; return (all_groups, all_fvs) }
-  where
-    mk_group :: RoleAnnotEnv
-             -> KindSigEnv
-             -> InstDeclFreeVarsMap
-             -> SCC (LTyClDecl GhcRn)
-             -> (InstDeclFreeVarsMap, TyClGroup GhcRn)
-    mk_group role_env kisig_env inst_map scc
-      = (inst_map', group)
-      where
-        tycl_ds              = flattenSCC scc
-        bndrs                = map (tcdName . unLoc) tycl_ds
-        roles                = getRoleAnnots bndrs role_env
-        kisigs               = getKindSigs   bndrs kisig_env
-        (inst_ds, inst_map') = getInsts      bndrs inst_map
-        group = TyClGroup { group_ext    = noExtField
-                          , group_tyclds = tycl_ds
-                          , group_kisigs = kisigs
-                          , group_roles  = roles
-                          , group_instds = inst_ds }
 
 -- | Free variables of standalone kind signatures.
 newtype KindSig_FV_Env = KindSig_FV_Env (NameEnv FreeVars)


=====================================
compiler/GHC/Tc/Gen/HsType.hs
=====================================
@@ -580,14 +580,16 @@ top level of a signature.
 -}
 
 -- Does validity checking and zonking.
-tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, Kind)
+tcStandaloneKindSig :: LStandaloneKindSig GhcRn -> TcM (Name, SAKS_or_CUSK)
 tcStandaloneKindSig (L _ (StandaloneKindSig _ (L _ name) ksig))
   = addSigCtxt ctxt ksig $
     do { kind <- tc_top_lhs_type KindLevel ctxt ksig
        ; checkValidType ctxt kind
-       ; return (name, kind) }
+       ; return (name, SAKS kind) }
   where
    ctxt = StandaloneKindSigCtxt name
+tcStandaloneKindSig (L _ (XStandaloneKindSig hdr)) =
+    return (decl_header_name (unLoc hdr), CUSK)
 
 tcTopLHsType :: UserTypeCtxt -> LHsSigType GhcRn -> TcM Type
 tcTopLHsType ctxt lsig_ty


=====================================
compiler/GHC/Tc/TyCl.hs
=====================================
@@ -115,6 +115,7 @@ import Data.List ( partition)
 import Data.List.NonEmpty ( NonEmpty(..) )
 import qualified Data.List.NonEmpty as NE
 import Data.Tuple( swap )
+import Data.Void
 
 {-
 ************************************************************************
@@ -201,8 +202,29 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
        ; traceTc "Decls for" (ppr (map (tcdName . unLoc) tyclds))
        ; (tyclss, data_deriv_info, kindless) <-
            tcExtendKindEnv (mkPromotionErrorEnv tyclds) $ -- See Note [Type environment evolution]
-           do { kisig_env <- mkNameEnv <$> traverse tcStandaloneKindSig kisigs
-              ; tcTyClDecls tyclds kisig_env role_annots }
+           do { checked_tcs <-
+                  tcExtendKindEnv (mkSigPromotionErrorEnv kisigs) $
+                  mapM tcDeclSig kisigs
+                  -- FIXME: false positives because there might be signatures/cusks
+                  --        in previous declaration groups
+              ; let is_kinded_decl name = any (\tctc -> tyConName tctc == name) checked_tcs
+              ; tcExtendKindEnvWithTyCons checked_tcs $
+                tcTyClDecls tyclds is_kinded_decl role_annots }
+{-
+           do { checked_tcs <-
+                  tcExtendKindEnv (mkSigPromotionErrorEnv kisigs) $
+                  mapMaybeM tcDeclSig kisigs
+              ; let extended_inter_group_env = extendInterGroupEnv checked_tcs inter_group_env
+                    is_kinded_decl = interGroupElem extended_inter_group_env
+              ; (tyclss, data_deriv_info) <-
+                  tcExtendKindEnvWithTyCons (interGroupEnvTyCons extended_inter_group_env) $
+                  tcTyClDecls tyclds is_kinded_decl role_annots
+              ; let purged_inter_group_env = purgeInterGroupEnv tyclss extended_inter_group_env
+              ; return (purged_inter_group_env, tyclss, data_deriv_info)
+              }
+-}
+
+
 
            -- Step 1.5: Make sure we don't have any type synonym cycles
        ; traceTc "Starting synonym cycle check" (ppr tyclss)
@@ -238,20 +260,83 @@ tcTyClGroup (TyClGroup { group_tyclds = tyclds
        ; return (gbl_env'', inst_info, deriv_info,
                  th_bndrs' `plusNameEnv` th_bndrs) }
 
--- Gives the kind for every TyCon that has a standalone kind signature
-type KindSigEnv = NameEnv Kind
+mkSigPromotionErrorEnv :: [LStandaloneKindSig GhcRn] -> TcTypeEnv
+mkSigPromotionErrorEnv =
+  foldr (plusNameEnv . mk_sig_prom_err_env . unLoc) emptyNameEnv
+
+mk_sig_prom_err_env :: StandaloneKindSig GhcRn -> TcTypeEnv
+mk_sig_prom_err_env sig =
+  unitNameEnv (decl_header_name hdr)
+    (case decl_header_flav hdr of
+        ClassFlavour -> APromotionErr ClassPE
+        _ -> APromotionErr TyConPE)
+  where
+    (L _ hdr) = case sig of
+      StandaloneKindSig hdr _ _ -> hdr
+      XStandaloneKindSig hdr -> hdr
+
+tcDeclSig :: LStandaloneKindSig GhcRn -> TcM TcTyCon
+tcDeclSig kisig = do
+    (_, ki) <- tcStandaloneKindSig kisig
+    tc <- check_decl_sig ki hdr
+    return tc
+  where
+    (L _ hdr) = case unLoc kisig of
+      StandaloneKindSig hdr _ _ -> hdr
+      XStandaloneKindSig hdr -> hdr
+
+check_decl_sig :: SAKS_or_CUSK -> DeclHeaderRn -> TcM TcTyCon
+check_decl_sig msig hdr =
+  kcDeclHeader strategy name flav (decl_header_bndrs hdr) $
+    if | flav == ClassFlavour
+       -> return (TheKind constraintKind)
+
+       | flav == DataTypeFlavour
+       -> case res_sig of
+            Just ksig -> TheKind <$> tcLHsKindSig (DataKindCtxt name) ksig
+            Nothing -> return $ dataDeclDefaultResultKind strategy DataType
+
+       | flav == NewtypeFlavour
+       -> case res_sig of
+            Just ksig -> TheKind <$> tcLHsKindSig (DataKindCtxt name) ksig
+            Nothing -> return $ dataDeclDefaultResultKind strategy NewType
+
+       | is_fam_flav flav
+       -> case res_sig of
+            Just ksig -> TheKind <$> tcLHsKindSig (TyFamResKindCtxt name) ksig
+            Nothing ->
+              case msig of
+                CUSK -> return (TheKind liftedTypeKind)
+                SAKS _ -> return AnyKind
+
+       | flav == TypeSynonymFlavour
+       -> case res_sig of
+            Just rhs_sig -> TheKind <$> tcLHsKindSig (TySynKindCtxt name) rhs_sig
+            Nothing -> return AnyKind
+
+       | otherwise -> return AnyKind
+  where
+    name = decl_header_name hdr
+    flav = fmap absurd (decl_header_flav hdr)
+    res_sig = decl_header_res_sig hdr
+    strategy = InitialKindCheck msig
+
+is_fam_flav :: TyConFlavour tc -> Bool
+is_fam_flav OpenFamilyFlavour{} = True
+is_fam_flav ClosedTypeFamilyFlavour = True
+is_fam_flav _ = False
 
 tcTyClDecls
   :: [LTyClDecl GhcRn]
-  -> KindSigEnv
+  -> (Name -> Bool) -- Does this declaration have a SAKS or a CUSK?
   -> RoleAnnotEnv
   -> TcM ([TyCon], [DerivInfo], NameSet)
-tcTyClDecls tyclds kisig_env role_annots
+tcTyClDecls tyclds is_kinded_decl role_annots
   = do {    -- Step 1: kind-check this group and returns the final
             -- (possibly-polymorphic) kind of each TyCon and Class
             -- See Note [Kind checking for type and class decls]
          (tc_tycons, kindless) <- checkNoErrs $
-                                  kcTyClGroup kisig_env tyclds
+                                  kcTyClGroup is_kinded_decl tyclds
             -- checkNoErrs: If the TyCons are ill-kinded, stop now.  Else we
             -- can get follow-on errors. Example: #23252, where the TyCon
             -- had an ill-scoped kind forall (d::k) k (a::k). blah
@@ -857,7 +942,7 @@ been generalized.
 
 -}
 
-kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)
+kcTyClGroup :: (Name -> Bool) -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)
 
 -- Kind check this group, kind generalize, and return the resulting local env
 -- This binds the TyCons and Classes of the group, but not the DataCons
@@ -865,7 +950,7 @@ kcTyClGroup :: KindSigEnv -> [LTyClDecl GhcRn] -> TcM ([PolyTcTyCon], NameSet)
 -- and Note [Inferring kinds for type declarations]
 --
 -- The NameSet returned contains kindless tycon names, without CUSK or SAKS.
-kcTyClGroup kisig_env decls
+kcTyClGroup is_kinded_decl decls
   = do  { mod <- getModule
         ; traceTc "---- kcTyClGroup ---- {"
                   (text "module" <+> ppr mod $$ vcat (map ppr decls))
@@ -876,31 +961,36 @@ kcTyClGroup kisig_env decls
           --    3. Generalise the inferred kinds
           -- See Note [Kind checking for type and class decls]
 
-        ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
-                    -- See Note [CUSKs and PolyKinds]
-        ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls
-              kindless_names = mkNameSet $ map get_name kindless_decls
+        -- ; cusks_enabled <- xoptM LangExt.CUSKs <&&> xoptM LangExt.PolyKinds
+        --             -- See Note [CUSKs and PolyKinds]
+        -- ; let (kindless_decls, kinded_decls) = partitionWith get_kind decls
+        --       kindless_names = mkNameSet $ map get_name kindless_decls
 
-              get_name d = tcdName (unLoc d)
+        --       get_name d = tcdName (unLoc d)
 
-              get_kind d
-                | Just ki <- lookupNameEnv kisig_env (get_name d)
-                = Right (d, SAKS ki)
+        --       get_kind d
+        --         | Just ki <- lookupNameEnv kisig_env (get_name d)
+        --         = Right (d, SAKS ki)
 
-                | cusks_enabled && hsDeclHasCusk (unLoc d)
-                = Right (d, CUSK)
+        --         | cusks_enabled && hsDeclHasCusk (unLoc d)
+        --         = Right (d, CUSK)
 
-                | otherwise = Left d
+        --         | otherwise = Left d
+        ; let (kinded_decls, kindless_decls) = partition (is_kinded_decl . tcdName . unLoc) decls
+              kindless_names = mkNameSet $ map get_name kindless_decls
+              get_name d = tcdName (unLoc d)
+        ; (checked_tcs, concat -> checked_assoc_tcs) <-
+            mapAndUnzipM checkKindedDecl kinded_decls
 
-        ; checked_tcs <- checkNoErrs $
-                         checkInitialKinds kinded_decls
-                         -- checkNoErrs because we are about to extend
-                         -- the envt with these tycons, and we get
-                         -- knock-on errors if we have tycons with
-                         -- malformed kinds
+        -- ; checked_tcs <- checkNoErrs $
+        --                  checkInitialKinds kinded_decls
+        --                  -- checkNoErrs because we are about to extend
+        --                  -- the envt with these tycons, and we get
+        --                  -- knock-on errors if we have tycons with
+        --                  -- malformed kinds
 
         ; inferred_tcs
-            <- tcExtendKindEnvWithTyCons checked_tcs  $
+            <- tcExtendKindEnvWithTyCons checked_assoc_tcs  $
                pushLevelAndSolveEqualities unkSkolAnon [] $
                      -- We are going to kind-generalise, so unification
                      -- variables in here must be one level in
@@ -929,13 +1019,25 @@ kcTyClGroup kisig_env decls
         ; generalized_tcs <- concatMapM (generaliseTyClDecl inferred_tc_env)
                                         kindless_decls
 
-        ; let poly_tcs = checked_tcs ++ generalized_tcs
+        ; let poly_tcs = checked_tcs ++ checked_assoc_tcs ++ generalized_tcs
         ; traceTc "---- kcTyClGroup end ---- }" (ppr_tc_kinds poly_tcs)
         ; return (poly_tcs, kindless_names) }
   where
     ppr_tc_kinds tcs = vcat (map pp_tc tcs)
     pp_tc tc = ppr (tyConName tc) <+> dcolon <+> ppr (tyConKind tc)
 
+checkKindedDecl :: LTyClDecl GhcRn -> TcM (TcTyCon, [TcTyCon])
+checkKindedDecl (L _ (ClassDecl { tcdLName = L _ name , tcdATs = ats }))
+  = do { cls <- tcLookupTcTyCon name
+       ; let parent_tv_prs = tcTyConScopedTyVars cls
+       ; inner_tcs <-
+           tcExtendNameTyVarEnv parent_tv_prs $
+           mapM (addLocMA (check_initial_kind_assoc_fam cls)) ats
+       ; return (cls, inner_tcs) }
+checkKindedDecl (L _ d)
+  = do { tc <- tcLookupTcTyCon (tcdName d)
+       ; return (tc, []) }
+
 type ScopedPairs = [(Name, TcTyVar)]
   -- The ScopedPairs for a TcTyCon are precisely
   --    specified-tvs ++ required-tvs
@@ -1510,17 +1612,17 @@ inferInitialKinds decls
   where
     infer_initial_kind = addLocMA (getInitialKind InitialKindInfer)
 
--- Check type/class declarations against their standalone kind signatures or
--- CUSKs, producing a generalized TcTyCon for each.
-checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon]
-checkInitialKinds decls
-  = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)
-       ; tcs <- concatMapM check_initial_kind decls
-       ; traceTc "checkInitialKinds done }" empty
-       ; return tcs }
-  where
-    check_initial_kind (ldecl, msig) =
-      addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
+-- -- Check type/class declarations against their standalone kind signatures or
+-- -- CUSKs, producing a generalized TcTyCon for each.
+-- checkInitialKinds :: [(LTyClDecl GhcRn, SAKS_or_CUSK)] -> TcM [PolyTcTyCon]
+-- checkInitialKinds decls
+--   = do { traceTc "checkInitialKinds {" $ ppr (mapFst (tcdName . unLoc) decls)
+--        ; tcs <- concatMapM check_initial_kind decls
+--        ; traceTc "checkInitialKinds done }" empty
+--        ; return tcs }
+--   where
+--     check_initial_kind (ldecl, msig) =
+--       addLocMA (getInitialKind (InitialKindCheck msig)) ldecl
 
 -- | Get the initial kind of a TyClDecl, either generalized or non-generalized,
 -- depending on the 'InitialKindStrategy'.



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b492edf08f2e4047ee9cd6b7b101c3f7a47f21bc

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b492edf08f2e4047ee9cd6b7b101c3f7a47f21bc
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/20230627/f15ecdeb/attachment-0001.html>


More information about the ghc-commits mailing list