[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: ghc-internal: Eliminate GHC.Internal.Data.Kind

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Fri Mar 8 11:35:34 UTC 2024



Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC


Commits:
50454a29 by Ben Gamari at 2024-03-08T03:32:42-05:00
ghc-internal: Eliminate GHC.Internal.Data.Kind

This was simply reexporting things from `ghc-prim`. Instead reexport
these directly from `Data.Kind`. Also add build ordering dependency to
work around #23942.

- - - - -
38a4b6ab by Ben Gamari at 2024-03-08T03:33:18-05:00
rts: Fix SET_HDR initialization of retainer set

This fixes a regression in retainer set profiling introduced by
b0293f78cb6acf2540389e22bdda420d0ab874da. Prior to that commit
the heap traversal word would be initialized by `SET_HDR` using
`LDV_RECORD_CREATE`. However, the commit added a `doingLDVProfiling`
check in `LDV_RECORD_CREATE`, meaning that this initialization no longer
happened.

Given that this initialization was awkwardly indirectly anyways, I have
fixed this by explicitly initializating the heap traversal word to
`NULL` in `SET_PROF_HDR`. This is equivalent to the previous behavior,
but much more direct.

Fixes #24513.

- - - - -
d17e0cfc by Patrick at 2024-03-08T08:54:36+00:00
HieAst: add module name #24493

The main purpose of this is to tuck the module name `xxx` in `module xxx where` into the hieAst.
It should fix #24493.

The following have been done:
1. Renamed and update the `tcg_doc_hdr :: Maybe (LHsDoc GhcRn)` to `tcg_hdr_info :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName))`
   To store the located module name information.
2. update the `RenamedSource` and `RenamedStuff` with extra `Maybe (XRec GhcRn ModuleName)` located module name information.
3. add test `testsuite/tests/hiefile/should_compile/T24493.hs` to ensure the module name is added and update several relevent tests.
4. accompanied submodule haddoc test update MR in https://gitlab.haskell.org/ghc/haddock/-/merge_requests/53

- - - - -
21c7494d by Ben Gamari at 2024-03-08T06:35:23-05:00
rts/linker: Enable GOT support on all platforms

There is nothing platform-dependent about our GOT implementation and
GOT support is needed by `T24171` on i386.

- - - - -


21 changed files:

- compiler/GHC.hs
- compiler/GHC/HsToCore/Docs.hs
- compiler/GHC/Iface/Ext/Ast.hs
- compiler/GHC/Tc/Module.hs
- compiler/GHC/Tc/Types.hs
- compiler/GHC/Tc/Utils/Backpack.hs
- compiler/GHC/Tc/Utils/Monad.hs
- libraries/base/src/Data/Kind.hs
- libraries/ghc-internal/ghc-internal.cabal
- rts/include/rts/storage/ClosureMacros.h
- rts/linker/Elf.c
- + testsuite/tests/hiefile/should_compile/T24493.hs
- + testsuite/tests/hiefile/should_compile/T24493.stderr
- testsuite/tests/hiefile/should_compile/all.T
- testsuite/tests/interface-stability/base-exports.stdout
- testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
- testsuite/tests/interface-stability/base-exports.stdout-mingw32
- testsuite/tests/interface-stability/base-exports.stdout-ws-32
- testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
- testsuite/tests/parser/should_compile/T14189.stderr
- utils/haddock


Changes:

=====================================
compiler/GHC.hs
=====================================
@@ -1157,7 +1157,7 @@ instance DesugaredMod DesugaredModule where
 
 type ParsedSource      = Located (HsModule GhcPs)
 type RenamedSource     = (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
-                          Maybe (LHsDoc GhcRn))
+                          Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName))
 type TypecheckedSource = LHsBinds GhcTc
 
 -- NOTE:


=====================================
compiler/GHC/HsToCore/Docs.hs
=====================================
@@ -63,12 +63,12 @@ extractDocs dflags
                , tcg_imports = import_avails
                , tcg_insts = insts
                , tcg_fam_insts = fam_insts
-               , tcg_doc_hdr = mb_doc_hdr
+               , tcg_hdr_info = mb_hdr_info
                , tcg_th_docs = th_docs_var
                , tcg_type_env = ty_env
                } = do
     th_docs <- liftIO $ readIORef th_docs_var
-    let doc_hdr = (unLoc <$> mb_doc_hdr)
+    let doc_hdr = unLoc <$> fst mb_hdr_info
         ExtractedTHDocs th_hdr th_decl_docs th_arg_docs th_inst_docs = extractTHDocs th_docs
         mod_docs
          =  Docs


=====================================
compiler/GHC/Iface/Ext/Ast.hs
=====================================
@@ -210,7 +210,8 @@ call and just recurse directly in to the subexpressions.
 -- These synonyms match those defined in compiler/GHC.hs
 type RenamedSource     = ( HsGroup GhcRn, [LImportDecl GhcRn]
                          , Maybe [(LIE GhcRn, Avails)]
-                         , Maybe (LHsDoc GhcRn) )
+                         , Maybe (LHsDoc GhcRn)
+                         , Maybe (XRec GhcRn ModuleName) )
 type TypecheckedSource = LHsBinds GhcTc
 
 
@@ -321,8 +322,9 @@ getCompressedAsts ts rs top_ev_binds insts tcs =
 
 enrichHie :: TypecheckedSource -> RenamedSource -> Bag EvBind -> [ClsInst] -> [TyCon]
   -> HieASTs Type
-enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs =
+enrichHie ts (hsGrp, imports, exports, docs, modName) ev_bs insts tcs =
   runIdentity $ flip evalStateT initState $ flip runReaderT SourceInfo $ do
+    modName <- toHie (IEC Export <$> modName)
     tasts <- toHie $ fmap (BC RegularBind ModuleScope) ts
     rasts <- processGrp hsGrp
     imps <- toHie $ filter (not . ideclImplicit . ideclExt . unLoc) imports
@@ -344,7 +346,8 @@ enrichHie ts (hsGrp, imports, exports, docs) ev_bs insts tcs =
               (realSrcSpanEnd   $ nodeSpan (NE.last children))
 
         flat_asts = concat
-          [ tasts
+          [ modName
+          , tasts
           , rasts
           , imps
           , exps


=====================================
compiler/GHC/Tc/Module.hs
=====================================
@@ -297,8 +297,8 @@ tcRnModuleTcRnM hsc_env mod_sum
         -- We will rename it properly after renaming everything else so that
         -- haddock can link the identifiers
         ; tcg_env <- return (tcg_env
-                              { tcg_doc_hdr = fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str [])
-                                                                                 <$> maybe_doc_hdr })
+                              { tcg_hdr_info = (fmap (\(WithHsDocIdentifiers str _) -> WithHsDocIdentifiers str [])
+                                                <$> maybe_doc_hdr , maybe_mod ) })
         ; -- If the whole module is warned about or deprecated
           -- (via mod_deprec) record that in tcg_warns. If we do thereby add
           -- a WarnAll, it will override any subsequent deprecations added to tcg_warns
@@ -347,7 +347,7 @@ tcRnModuleTcRnM hsc_env mod_sum
                       -- Rename the module header properly after we have renamed everything else
                       ; maybe_doc_hdr <- traverse rnLHsDoc maybe_doc_hdr;
                       ; tcg_env <- return (tcg_env
-                                            { tcg_doc_hdr = maybe_doc_hdr })
+                                            { tcg_hdr_info = (maybe_doc_hdr, maybe_mod) })
 
                       ; -- add extra source files to tcg_dependent_files
                         addDependentFiles src_files
@@ -3115,14 +3115,15 @@ runRenamerPlugin gbl_env hs_group = do
 -- exception/signal an error.
 type RenamedStuff =
         (Maybe (HsGroup GhcRn, [LImportDecl GhcRn], Maybe [(LIE GhcRn, Avails)],
-                Maybe (LHsDoc GhcRn)))
+                Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)))
 
 -- | Extract the renamed information from TcGblEnv.
 getRenamedStuff :: TcGblEnv -> RenamedStuff
 getRenamedStuff tc_result
   = fmap (\decls -> ( decls, tcg_rn_imports tc_result
-                    , tcg_rn_exports tc_result, tcg_doc_hdr tc_result ) )
+                    , tcg_rn_exports tc_result, doc_hdr, name_hdr ))
          (tcg_rn_decls tc_result)
+  where (doc_hdr, name_hdr) = tcg_hdr_info tc_result
 
 runTypecheckerPlugin :: ModSummary -> TcGblEnv -> TcM TcGblEnv
 runTypecheckerPlugin sum gbl_env = do


=====================================
compiler/GHC/Tc/Types.hs
=====================================
@@ -605,7 +605,9 @@ data TcGblEnv
         tcg_fords     :: [LForeignDecl GhcTc], -- ...Foreign import & exports
         tcg_patsyns   :: [PatSyn],            -- ...Pattern synonyms
 
-        tcg_doc_hdr   :: Maybe (LHsDoc GhcRn), -- ^ Maybe Haddock header docs
+        tcg_hdr_info   :: (Maybe (LHsDoc GhcRn), Maybe (XRec GhcRn ModuleName)),
+        -- ^ Maybe Haddock header docs and Maybe located module name
+
         tcg_hpc       :: !AnyHpcUsage,       -- ^ @True@ if any part of the
                                              --  prog uses hpc instrumentation.
            -- NB. BangPattern is to fix a leak, see #15111


=====================================
compiler/GHC/Tc/Utils/Backpack.hs
=====================================
@@ -523,8 +523,8 @@ mergeSignatures
         tcg_rn_decls   = tcg_rn_decls   orig_tcg_env,
         -- Annotations
         tcg_ann_env    = tcg_ann_env    orig_tcg_env,
-        -- Documentation header
-        tcg_doc_hdr    = tcg_doc_hdr orig_tcg_env
+        -- Documentation header and located module name
+        tcg_hdr_info    = tcg_hdr_info orig_tcg_env
         -- tcg_dus?
         -- tcg_th_used           = tcg_th_used orig_tcg_env,
         -- tcg_th_splice_used    = tcg_th_splice_used orig_tcg_env


=====================================
compiler/GHC/Tc/Utils/Monad.hs
=====================================
@@ -346,7 +346,7 @@ initTc hsc_env hsc_src keep_rn_syntax mod loc do_this
                 tcg_merged         = [],
                 tcg_dfun_n         = dfun_n_var,
                 tcg_keep           = keep_var,
-                tcg_doc_hdr        = Nothing,
+                tcg_hdr_info        = (Nothing,Nothing),
                 tcg_hpc            = False,
                 tcg_main           = Nothing,
                 tcg_self_boot      = NoSelfBoot,


=====================================
libraries/base/src/Data/Kind.hs
=====================================
@@ -1,4 +1,4 @@
-{-# LANGUAGE Safe #-}
+{-# LANGUAGE Trustworthy #-}
 
 -- |
 --
@@ -19,4 +19,6 @@ module Data.Kind
      FUN
      ) where
 
-import GHC.Internal.Data.Kind
\ No newline at end of file
+import GHC.Num.BigNat () -- for build ordering (#23942)
+import GHC.Prim (FUN)
+import GHC.Types (Type, Constraint)


=====================================
libraries/ghc-internal/ghc-internal.cabal
=====================================
@@ -120,7 +120,6 @@ Library
         GHC.Internal.Data.Functor.Utils
         GHC.Internal.Data.IORef
         GHC.Internal.Data.Ix
-        GHC.Internal.Data.Kind
         GHC.Internal.Data.List
         GHC.Internal.Data.Maybe
         GHC.Internal.Data.Monoid


=====================================
rts/include/rts/storage/ClosureMacros.h
=====================================
@@ -147,17 +147,10 @@ EXTERN_INLINE StgHalfWord GET_TAG(const StgClosure *con)
 #if defined(PROFILING)
 /*
   The following macro works for both retainer profiling and LDV profiling. For
- retainer profiling, 'era' remains 0, so by setting the 'ldvw' field we also set
- 'rs' to zero.
-
- Note that we don't have to bother handling the 'flip' bit properly[1] since the
- retainer profiling code will just set 'rs' to NULL upon visiting a closure with
- an invalid 'flip' bit anyways.
-
- See Note [Profiling heap traversal visited bit] for details.
-
- [1]: Technically we should set 'rs' to `NULL | flip`.
+ retainer profiling, we set 'trav' to 0, which is an invalid
+ RetainerSet.
  */
+
 /*
   MP: Various other places use the check era > 0 to check whether LDV profiling
   is enabled. The use of these predicates here is the reason for including RtsFlags.h in
@@ -168,17 +161,14 @@ EXTERN_INLINE StgHalfWord GET_TAG(const StgClosure *con)
 */
 #define SET_PROF_HDR(c, ccs_) \
   { \
-  (c)->header.prof.ccs = ccs_; \
-  if (doingLDVProfiling()) { \
-    LDV_RECORD_CREATE((c)); \
-  } \
-\
-  if (doingRetainerProfiling()) { \
-    LDV_RECORD_CREATE((c)); \
-  }; \
-  if (doingErasProfiling()){ \
-    ERA_RECORD_CREATE((c)); \
-  }; \
+    (c)->header.prof.ccs = ccs_; \
+    if (doingLDVProfiling()) { \
+      LDV_RECORD_CREATE((c)); \
+    } else if (doingRetainerProfiling()) { \
+      (c)->header.prof.hp.trav = 0; \
+    } else if (doingErasProfiling()){ \
+      ERA_RECORD_CREATE((c)); \
+    } \
   }
 
 #else


=====================================
rts/linker/Elf.c
=====================================
@@ -101,10 +101,10 @@
 #  include <elf_abi.h>
 #endif
 
+#include "elf_got.h"
+
 #if defined(arm_HOST_ARCH) || defined(aarch64_HOST_ARCH)
-#  define NEED_GOT
 #  define NEED_PLT
-#  include "elf_got.h"
 #  include "elf_plt.h"
 #  include "elf_reloc.h"
 #endif
@@ -798,7 +798,7 @@ ocGetNames_ELF ( ObjectCode* oc )
          /* This is a non-empty .bss section.  Allocate zeroed space for
             it, and set its .sh_offset field such that
             ehdrC + .sh_offset == addr_of_zeroed_space.  */
-#if defined(NEED_GOT) || RTS_LINKER_USE_MMAP
+#if RTS_LINKER_USE_MMAP
           if (USE_CONTIGUOUS_MMAP || RtsFlags.MiscFlags.linkerAlwaysPic) {
               /* The space for bss sections is already preallocated */
               CHECK(oc->bssBegin != NULL);
@@ -1113,13 +1113,11 @@ ocGetNames_ELF ( ObjectCode* oc )
       }
    }
 
-#if defined(NEED_GOT)
    if(makeGot( oc ))
        errorBelch("Failed to create GOT for %s",
                   oc->archiveMemberName
                   ? oc->archiveMemberName
                   : oc->fileName);
-#endif
    result = 1;
    goto end;
 
@@ -1987,13 +1985,11 @@ ocResolve_ELF ( ObjectCode* oc )
         }
     }
 
-#if defined(NEED_GOT)
     if(fillGot( oc ))
         return 0;
     /* silence warnings */
     (void) shnum;
     (void) shdr;
-#endif /* NEED_GOT */
 
 #if defined(aarch64_HOST_ARCH)
     /* use new relocation design */


=====================================
testsuite/tests/hiefile/should_compile/T24493.hs
=====================================
@@ -0,0 +1,3 @@
+module T24493 where
+
+go = "1"


=====================================
testsuite/tests/hiefile/should_compile/T24493.stderr
=====================================
@@ -0,0 +1,33 @@
+==================== HIE AST ====================
+File: T24493.hs
+Node at T24493.hs:(1,8)-(3,8): Source: From source
+                            {(annotations: {(Module, Module)}),  (types: []), 
+                             (identifier info: {})}
+                            
+  Node at T24493.hs:1:8-13: Source: From source
+                         {(annotations: {}),  (types: []), 
+                          (identifier info: {(module T24493,  Details:  Nothing {export})})}
+                         
+  Node at T24493.hs:3:1-8: Source: From source
+                        {(annotations: {(FunBind, HsBindLR), (Match, Match),
+                                        (XHsBindsLR, HsBindLR)}), 
+                         (types: [0]),  (identifier info: {})}
+                        
+    Node at T24493.hs:3:1-2: Source: From source
+                          {(annotations: {}),  (types: []), 
+                           (identifier info: {(name T24493.go,  Details:  Just 0 {LHS of a match group,
+                                                                                  regular value bound with scope: ModuleScope bound at: T24493.hs:3:1-8})})}
+                          
+    Node at T24493.hs:3:4-8: Source: From source
+                          {(annotations: {(GRHS, GRHS)}),  (types: []), 
+                           (identifier info: {})}
+                          
+      Node at T24493.hs:3:6-8: Source: From source
+                            {(annotations: {(HsLit, HsExpr)}),  (types: [0]), 
+                             (identifier info: {})}
+                                                    
+
+
+
+Got valid scopes
+Got no roundtrip errors
\ No newline at end of file


=====================================
testsuite/tests/hiefile/should_compile/all.T
=====================================
@@ -23,3 +23,4 @@ test('Scopes',       normal,                   compile, ['-fno-code -fwrite-ide-
 test('ScopesBug',    expect_broken(18425),     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 test('T18425',       normal,     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
 test('T22416',       normal,     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info'])
+test('T24493',       normal,     compile, ['-fno-code -fwrite-ide-info -fvalidate-ide-info -ddump-hie'])


=====================================
testsuite/tests/interface-stability/base-exports.stdout
=====================================
@@ -1276,7 +1276,7 @@ module Data.Ix where
     {-# MINIMAL range, (index | GHC.Internal.Ix.unsafeIndex), inRange #-}
 
 module Data.Kind where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Constraint :: *
   type Constraint = GHC.Prim.CONSTRAINT GHC.Types.LiftedRep
   type role FUN nominal representational representational


=====================================
testsuite/tests/interface-stability/base-exports.stdout-javascript-unknown-ghcjs
=====================================
@@ -1276,7 +1276,7 @@ module Data.Ix where
     {-# MINIMAL range, (index | GHC.Internal.Ix.unsafeIndex), inRange #-}
 
 module Data.Kind where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Constraint :: *
   type Constraint = GHC.Prim.CONSTRAINT GHC.Types.LiftedRep
   type role FUN nominal representational representational


=====================================
testsuite/tests/interface-stability/base-exports.stdout-mingw32
=====================================
@@ -1276,7 +1276,7 @@ module Data.Ix where
     {-# MINIMAL range, (index | GHC.Internal.Ix.unsafeIndex), inRange #-}
 
 module Data.Kind where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Constraint :: *
   type Constraint = GHC.Prim.CONSTRAINT GHC.Types.LiftedRep
   type role FUN nominal representational representational


=====================================
testsuite/tests/interface-stability/base-exports.stdout-ws-32
=====================================
@@ -1276,7 +1276,7 @@ module Data.Ix where
     {-# MINIMAL range, (index | GHC.Internal.Ix.unsafeIndex), inRange #-}
 
 module Data.Kind where
-  -- Safety: Safe
+  -- Safety: Trustworthy
   type Constraint :: *
   type Constraint = GHC.Prim.CONSTRAINT GHC.Types.LiftedRep
   type role FUN nominal representational representational


=====================================
testsuite/tests/parser/should_compile/DumpRenamedAst.stderr
=====================================
@@ -2,7 +2,7 @@
 ==================== Renamer ====================
 
 (Just
- ((,,,)
+ ((,,,,)
   (HsGroup
    (NoExtField)
    (XValBindsLR
@@ -2367,6 +2367,16 @@
               {Name: GHC.Types.Type})))
            (Nothing)))])))))]
   (Nothing)
-  (Nothing)))
+  (Nothing)
+  (Just
+   (L
+    (EpAnn
+     (EpaSpan { DumpRenamedAst.hs:4:8-21 })
+     (AnnListItem
+      [])
+     (EpaComments
+      []))
+    {ModuleName: DumpRenamedAst}))))
+
 
 


=====================================
testsuite/tests/parser/should_compile/T14189.stderr
=====================================
@@ -2,7 +2,7 @@
 ==================== Renamer ====================
 
 (Just
- ((,,,)
+ ((,,,,)
   (HsGroup
    (NoExtField)
    (XValBindsLR
@@ -316,6 +316,13 @@
        [{Name: T14189.MyType}
        ,{Name: T14189.f}
        ,{Name: T14189.NT}])])])
-  (Nothing)))
-
-
+  (Nothing)
+  (Just
+  (L
+    (EpAnn
+    (EpaSpan { T14189.hs:1:8-13 })
+    (AnnListItem
+      [])
+    (EpaComments
+      []))
+    {ModuleName: T14189}))))


=====================================
utils/haddock
=====================================
@@ -1 +1 @@
-Subproject commit 91f338a4f1ae59fd6ea482b73a27708113912d5d
+Subproject commit 730749b48c3d7b358f4fb07774a1ccfc1d63968a



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/acc39486d1b9b94a7378d08448b7450248131df5...21c7494d64fc83bcfbb3dbb4f8cb7965efb129cd

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/acc39486d1b9b94a7378d08448b7450248131df5...21c7494d64fc83bcfbb3dbb4f8cb7965efb129cd
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/20240308/3047f4a4/attachment-0001.html>


More information about the ghc-commits mailing list