[Git][ghc/ghc][wip/sand-witch/dep-anal] 2 commits: Simplify DANodeSig

[Vladislav Zavialov (@int-index)]

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


Commits:
a9a8f5c1 by Vladislav Zavialov at 2023-06-27T21:26:04+02:00
Simplify DANodeSig

- - - - -
828d60d0 by Vladislav Zavialov at 2023-06-27T21:45:21+02:00
doDepAnal: return TyClGroups

- - - - -


2 changed files:

- compiler/GHC/Hs/Decls.hs
- compiler/GHC/Rename/Module.hs


Changes:

=====================================
compiler/GHC/Hs/Decls.hs
=====================================
@@ -773,8 +773,7 @@ instance OutputableBndrId p
     = text "type" <+> pprPrefixOcc (unLoc v) <+> text "::" <+> ppr ki
   ppr (XStandaloneKindSig x) =
     case ghcPass @p of
-      GhcRn -> whenPprDebug $
-        text "CUSK:" <+> ppr (decl_header_name (unLoc x))
+      GhcRn -> ppr x
 
 pp_condecls :: forall p. OutputableBndrId p => [LConDecl (GhcPass p)] -> SDoc
 pp_condecls cs


=====================================
compiler/GHC/Rename/Module.hs
=====================================
@@ -58,7 +58,7 @@ import GHC.Types.Basic  ( TypeOrKind(..), TyConFlavour (..) )
 import GHC.Data.FastString
 import GHC.Types.SrcLoc as SrcLoc
 import GHC.Driver.DynFlags
-import GHC.Utils.Misc   ( lengthExceeds, partitionWith )
+import GHC.Utils.Misc
 import GHC.Utils.Panic
 import GHC.Driver.Env ( HscEnv(..), hsc_home_unit)
 import GHC.Data.List.SetOps ( findDupsEq, removeDupsOn, equivClasses )
@@ -2735,18 +2735,13 @@ data DAPayload =
     DAPhantom Name
   | DAInsts [LInstDecl GhcRn]
   | DATyClDecl (LTyClDecl GhcRn)
-  | DANodeSig
-      (Maybe (LStandaloneKindSig GhcRn))
-      DeclHeaderRn
+  | DANodeSig (LStandaloneKindSig GhcRn)
 
 instance Outputable DAPayload where
   ppr (DAPhantom n) = text "{- No sig for" <+> ppr n <+> text "-}"
   ppr (DAInsts insts) = ppr insts
   ppr (DATyClDecl decl) = ppr decl
-  ppr (DANodeSig msig decl_header) = vcat
-    [ maybe empty ppr msig,
-      ppr decl_header
-    ]
+  ppr (DANodeSig sig) = ppr sig
 
 type DANode = Node DAKey DAPayload
 
@@ -2755,7 +2750,7 @@ doDepAnal ::
   [(LInstDecl GhcRn,FreeVars)] ->
   [((LTyClDecl GhcRn, FreeVars), FreeVars)] ->
   GlobalRdrEnv ->
-  [SCC DAPayload] -- Inv: no DAPhantom
+  [TyClGroup GhcRn]
 doDepAnal sigs insts decls rdr_env =
   let
     -- FIXME: do not discard orphans
@@ -2769,8 +2764,9 @@ doDepAnal sigs insts decls rdr_env =
         sigNodeKey = DASig name
         defNodeKey = DADef name
         sigNode = case msig of
-          Nothing | not cusk -> DigraphNode (DAPhantom name) sigNodeKey [defNodeKey]
-          _ -> DigraphNode (DANodeSig msig decl_header) sigNodeKey (getDeps (fvs_lhs `plusFV` sig_fvs))
+          Nothing | cusk      -> DigraphNode (DANodeSig (noLocA (XStandaloneKindSig (noLocA decl_header))) ) sigNodeKey (getDeps (fvs_lhs `plusFV` sig_fvs))
+                  | otherwise -> DigraphNode (DAPhantom name) sigNodeKey [defNodeKey]
+          Just sig -> DigraphNode (DANodeSig sig) sigNodeKey (getDeps (fvs_lhs `plusFV` sig_fvs))
 
       sigNode : case decl of
         FamDecl{} | OpenFamilyFlavour{} <- flav -> do
@@ -2785,7 +2781,7 @@ doDepAnal sigs insts decls rdr_env =
           [defNode, instNode]
         _ ->
           pure (DigraphNode (DATyClDecl ldecl) defNodeKey (sigNodeKey : getDeps (fvs_lhs `plusFV` fvs_rhs)))
-  in (stronglyConnCompFromEdgedVerticesOrd declNodes)
+  in filterOut isEmptyTyClGroup $ map mk_group (stronglyConnCompFromEdgedVerticesOrd declNodes)
   where
     -- decl_headers = [mkDeclHeaderRn decl | (((L _ decl), _), _) <- decls]
 
@@ -2820,6 +2816,18 @@ doDepAnal sigs insts decls rdr_env =
               _ -> panic "doDepAnal: getDep"
         Just _ -> [DASig name]
         Nothing -> []
+
+    mk_group :: SCC DAPayload -> TyClGroup GhcRn
+    mk_group = foldr f (TyClGroup noExtField [] [] [] []) . flattenSCC
+      where
+        f :: DAPayload -> TyClGroup GhcRn -> TyClGroup GhcRn
+        f (DAPhantom _) = id
+        f (DAInsts insts) = \g -> g { group_instds = insts ++ group_instds g }
+        f (DATyClDecl decl) = \g -> g { group_tyclds = decl : group_tyclds g }
+        f (DANodeSig sig) = \g -> g { group_kisigs = sig : group_kisigs g }
+
+    isEmptyTyClGroup (TyClGroup _ [] [] [] []) = True
+    isEmptyTyClGroup _ = False
 {-
 data GREInfo
       -- | No particular information... e.g. a function



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ff06bcc4e40e1d90fcd2c2bac0e35e9f388facc...828d60d0facb0d69149ad89bf62c5d99f1a1d82a

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/1ff06bcc4e40e1d90fcd2c2bac0e35e9f388facc...828d60d0facb0d69149ad89bf62c5d99f1a1d82a
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/79c16a6f/attachment-0001.html>