[Git][ghc/ghc][wip/T23210] 7 commits: nativeGen: Explicitly set flags of text sections on Windows

Ben Gamari (@bgamari) gitlab at gitlab.haskell.org
Fri Jul 21 15:50:44 UTC 2023



Ben Gamari pushed to branch wip/T23210 at Glasgow Haskell Compiler / GHC


Commits:
3ece9856 by Ben Gamari at 2023-07-21T07:30:45-04:00
nativeGen: Explicitly set flags of text sections on Windows

The binutils documentation (for COFF) claims,

> If no flags are specified, the default flags depend upon the section
> name. If the section name is not recognized, the default will be for the
> section to be loaded and writable.

We previously assumed that this would do the right thing for split
sections (e.g. a section named `.text$foo` would be correctly inferred
to be a text section). However, we have observed that this is not the
case (at least under the clang toolchain used on Windows): when
split-sections is enabled, text sections are treated by the assembler as
data (matching the "default" behavior specified by the documentation).

Avoid this by setting section flags explicitly. This should fix split
sections on Windows.

Fixes #22834.

- - - - -
db7f7240 by Ben Gamari at 2023-07-21T07:30:45-04:00
nativeGen: Set explicit section types on all platforms

- - - - -
b444c16f by Finley McIlwaine at 2023-07-21T07:31:28-04:00
Insert documentation into parsed signature modules

Causes haddock comments in signature modules to be properly
inserted into the AST (just as they are for regular modules)
if the `-haddock` flag is given.

Also adds a test that compares `-ddump-parsed-ast` output
for a signature module to prevent further regressions.

Fixes #23315

- - - - -
ba7a5753 by Ben Gamari at 2023-07-21T11:50:27-04:00
rts: Tighten up invariants of PACK

- - - - -
cc5ee991 by Ben Gamari at 2023-07-21T11:50:27-04:00
StgToByteCode: Don't assume that data con workers are nullary

Previously StgToByteCode assumed that all data-con workers were of a
nullary representation. This is not a valid assumption, as seen
in #23210, where an unsaturated application of a unary data
constructor's worker resulted in invalid bytecode. Sadly, I have not yet
been able to reduce a minimal testcase for this.

Fixes #23210.

- - - - -
1fe4fc2b by Ben Gamari at 2023-07-21T11:50:27-04:00
StgToByteCode: Fix handling of Addr# literals

Previously we assumed that all unlifted types were Addr#.

- - - - -
35d666ae by Ben Gamari at 2023-07-21T11:50:27-04:00
testsuite: Mark MulMayOflo_full as req_cmm

As it involves cmm compilation and can't currently be run in the ghci
ways.

- - - - -


18 changed files:

- .gitlab-ci.yml
- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- compiler/GHC/CmmToAsm/Ppr.hs
- compiler/GHC/Parser.y
- compiler/GHC/Stg/Utils.hs
- compiler/GHC/StgToByteCode.hs
- rts/Interpreter.c
- rts/include/rts/storage/InfoTables.h
- testsuite/tests/codeGen/should_run/T23146/all.T
- testsuite/tests/codeGen/should_run/all.T
- + testsuite/tests/parser/should_compile/T23315/Makefile
- + testsuite/tests/parser/should_compile/T23315/Setup.hs
- + testsuite/tests/parser/should_compile/T23315/T23315.cabal
- + testsuite/tests/parser/should_compile/T23315/T23315.hsig
- + testsuite/tests/parser/should_compile/T23315/T23315.stderr
- + testsuite/tests/parser/should_compile/T23315/all.T
- testsuite/tests/unlifted-datatypes/should_run/all.T


Changes:

=====================================
.gitlab-ci.yml
=====================================
@@ -511,7 +511,7 @@ doc-tarball:
       optional: true
     - job: nightly-x86_64-windows-validate
       optional: true
-    - job: release-x86_64-windows-release+no_split_sections
+    - job: release-x86_64-windows-release
       optional: true
 
   tags:
@@ -535,7 +535,7 @@ doc-tarball:
         || mv "ghc-x86_64-linux-deb10-release.tar.xz" "$LINUX_BINDIST" \
         || true
       mv "ghc-x86_64-windows-validate.tar.xz" "$WINDOWS_BINDIST" \
-        || mv "ghc-x86_64-windows-release+no_split_sections.tar.xz" "$WINDOWS_BINDIST" \
+        || mv "ghc-x86_64-windows-release.tar.xz" "$WINDOWS_BINDIST" \
         || true
       if [ ! -f "$LINUX_BINDIST" ]; then
         echo "Error: $LINUX_BINDIST does not exist. Did the Debian 9 job fail?"


=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -921,8 +921,8 @@ job_groups =
      -- This job is only for generating head.hackage docs
      , hackage_doc_job (disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora33) releaseConfig))
      , disableValidate (standardBuildsWithConfig Amd64 (Linux Fedora33) dwarf)
-     , fastCI (standardBuildsWithConfig Amd64 Windows (splitSectionsBroken vanilla))
-     , disableValidate (standardBuildsWithConfig Amd64 Windows (splitSectionsBroken nativeInt))
+     , fastCI (standardBuildsWithConfig Amd64 Windows vanilla)
+     , disableValidate (standardBuildsWithConfig Amd64 Windows nativeInt)
      , standardBuilds Amd64 Darwin
      , allowFailureGroup (addValidateRule FreeBSDLabel (validateBuilds Amd64 FreeBSD13 vanilla))
      , fastCI (standardBuilds AArch64 Darwin)


=====================================
.gitlab/jobs.yaml
=====================================
@@ -3577,7 +3577,7 @@
       "XZ_OPT": "-9"
     }
   },
-  "release-x86_64-windows-int_native-release+no_split_sections": {
+  "release-x86_64-windows-int_native-release": {
     "after_script": [
       "bash .gitlab/ci.sh save_cache",
       "bash .gitlab/ci.sh save_test_output",
@@ -3587,7 +3587,7 @@
     "artifacts": {
       "expire_in": "1 year",
       "paths": [
-        "ghc-x86_64-windows-int_native-release+no_split_sections.tar.xz",
+        "ghc-x86_64-windows-int_native-release.tar.xz",
         "junit.xml",
         "unexpected-test-output.tar.gz"
       ],
@@ -3626,8 +3626,8 @@
     ],
     "variables": {
       "BIGNUM_BACKEND": "native",
-      "BIN_DIST_NAME": "ghc-x86_64-windows-int_native-release+no_split_sections",
-      "BUILD_FLAVOUR": "release+no_split_sections",
+      "BIN_DIST_NAME": "ghc-x86_64-windows-int_native-release",
+      "BUILD_FLAVOUR": "release",
       "CABAL_INSTALL_VERSION": "3.8.1.0",
       "CONFIGURE_ARGS": "",
       "GHC_VERSION": "9.4.3",
@@ -3636,11 +3636,11 @@
       "LANG": "en_US.UTF-8",
       "MSYSTEM": "CLANG64",
       "RUNTEST_ARGS": "",
-      "TEST_ENV": "x86_64-windows-int_native-release+no_split_sections",
+      "TEST_ENV": "x86_64-windows-int_native-release",
       "XZ_OPT": "-9"
     }
   },
-  "release-x86_64-windows-release+no_split_sections": {
+  "release-x86_64-windows-release": {
     "after_script": [
       "bash .gitlab/ci.sh save_cache",
       "bash .gitlab/ci.sh save_test_output",
@@ -3650,7 +3650,7 @@
     "artifacts": {
       "expire_in": "1 year",
       "paths": [
-        "ghc-x86_64-windows-release+no_split_sections.tar.xz",
+        "ghc-x86_64-windows-release.tar.xz",
         "junit.xml",
         "unexpected-test-output.tar.gz"
       ],
@@ -3689,8 +3689,8 @@
     ],
     "variables": {
       "BIGNUM_BACKEND": "gmp",
-      "BIN_DIST_NAME": "ghc-x86_64-windows-release+no_split_sections",
-      "BUILD_FLAVOUR": "release+no_split_sections",
+      "BIN_DIST_NAME": "ghc-x86_64-windows-release",
+      "BUILD_FLAVOUR": "release",
       "CABAL_INSTALL_VERSION": "3.8.1.0",
       "CONFIGURE_ARGS": "",
       "GHC_VERSION": "9.4.3",
@@ -3699,7 +3699,7 @@
       "LANG": "en_US.UTF-8",
       "MSYSTEM": "CLANG64",
       "RUNTEST_ARGS": "",
-      "TEST_ENV": "x86_64-windows-release+no_split_sections",
+      "TEST_ENV": "x86_64-windows-release",
       "XZ_OPT": "-9"
     }
   },


=====================================
compiler/GHC/CmmToAsm/Ppr.hs
=====================================
@@ -245,6 +245,10 @@ pprGNUSectionHeader config t suffix =
       OtherSection _ ->
         panic "PprBase.pprGNUSectionHeader: unknown section type"
     flags = case t of
+      Text
+        | OSMinGW32 <- platformOS platform
+                    -> text ",\"xr\""
+        | otherwise -> text ",\"ax\"," <> sectionType platform "progbits"
       CString
         | OSMinGW32 <- platformOS platform
                     -> empty


=====================================
compiler/GHC/Parser.y
=====================================
@@ -751,7 +751,7 @@ TH_QQUASIQUOTE  { L _ (ITqQuasiQuote _) }
 
 -- Exported parsers
 %name parseModuleNoHaddock module
-%name parseSignature signature
+%name parseSignatureNoHaddock signature
 %name parseImport importdecl
 %name parseStatement e_stmt
 %name parseDeclaration topdecl
@@ -4416,18 +4416,29 @@ pvL :: MonadP m => m (LocatedAn t a) -> m (Located a)
 pvL a = do { av <- a
            ; return (reLoc av) }
 
--- | Parse a Haskell module with Haddock comments.
--- This is done in two steps:
+-- | Parse a Haskell module with Haddock comments. This is done in two steps:
 --
 -- * 'parseModuleNoHaddock' to build the AST
 -- * 'addHaddockToModule' to insert Haddock comments into it
 --
--- This is the only parser entry point that deals with Haddock comments.
--- The other entry points ('parseDeclaration', 'parseExpression', etc) do
--- not insert them into the AST.
+-- This and the signature module parser are the only parser entry points that
+-- deal with Haddock comments. The other entry points ('parseDeclaration',
+-- 'parseExpression', etc) do not insert them into the AST.
 parseModule :: P (Located (HsModule GhcPs))
 parseModule = parseModuleNoHaddock >>= addHaddockToModule
 
+-- | Parse a Haskell signature module with Haddock comments. This is done in two
+-- steps:
+--
+-- * 'parseSignatureNoHaddock' to build the AST
+-- * 'addHaddockToModule' to insert Haddock comments into it
+--
+-- This and the module parser are the only parser entry points that deal with
+-- Haddock comments. The other entry points ('parseDeclaration',
+-- 'parseExpression', etc) do not insert them into the AST.
+parseSignature :: P (Located (HsModule GhcPs))
+parseSignature = parseSignatureNoHaddock >>= addHaddockToModule
+
 commentsA :: (Monoid ann) => SrcSpan -> EpAnnComments -> SrcSpanAnn' (EpAnn ann)
 commentsA loc cs = SrcSpanAnn (EpAnn (Anchor (rs loc) UnchangedAnchor) mempty cs) loc
 


=====================================
compiler/GHC/Stg/Utils.hs
=====================================
@@ -9,6 +9,7 @@ module GHC.Stg.Utils
     , idArgs
 
     , mkUnarisedId, mkUnarisedIds
+    , hasNoNonZeroWidthArgs
     ) where
 
 import GHC.Prelude
@@ -16,6 +17,7 @@ import GHC.Prelude
 import GHC.Types.Id
 import GHC.Core.Type
 import GHC.Core.TyCon
+import GHC.Core.Multiplicity     ( scaledThing )
 import GHC.Core.DataCon
 import GHC.Core ( AltCon(..) )
 import GHC.Types.Tickish
@@ -31,6 +33,13 @@ import GHC.Utils.Panic
 
 import GHC.Data.FastString
 
+-- | Returns whether there are any arguments with a non-zero-width runtime
+-- representation.
+--
+-- Returns True if the datacon has no or /just/ zero-width arguments.
+hasNoNonZeroWidthArgs :: DataCon -> Bool
+hasNoNonZeroWidthArgs = all (isZeroBitTy . scaledThing) . dataConRepArgTys
+
 mkUnarisedIds :: MonadUnique m => FastString -> [UnaryType] -> m [Id]
 mkUnarisedIds fs tys = mapM (mkUnarisedId fs) tys
 


=====================================
compiler/GHC/StgToByteCode.hs
=====================================
@@ -1855,20 +1855,18 @@ pushAtom d p (StgVarArg var)
         -- PUSH_G doesn't tag constructors. So we use PACK here
         -- if we are dealing with nullary constructor.
         case isDataConWorkId_maybe var of
-          Just con -> do
-            massert (isNullaryRepDataCon con)
-            return (unitOL (PACK con 0), szb)
+          Just con
+            -- See Note [LFInfo of DataCon workers and wrappers] in GHC.Types.Id.Make.
+            | isNullaryRepDataCon con -> do
+              return (unitOL (PACK con 0), szb)
 
-          Nothing
             -- see Note [Generating code for top-level string literal bindings]
-            | isUnliftedType (idType var) -> do
-              massert (idType var `eqType` addrPrimTy)
+          _ | idType var `eqType` addrPrimTy ->
               return (unitOL (PUSH_ADDR (getName var)), szb)
 
             | otherwise -> do
               return (unitOL (PUSH_G (getName var)), szb)
 
-
 pushAtom _ _ (StgLitArg lit) = pushLiteral True lit
 
 pushLiteral :: Bool -> Literal -> BcM (BCInstrList, ByteOff)


=====================================
rts/Interpreter.c
=====================================
@@ -1674,23 +1674,28 @@ run_BCO:
         }
 
         case bci_PACK: {
-            W_ i;
-            W_ o_itbl         = BCO_GET_LARGE_ARG;
-            W_ n_words        = BCO_GET_LARGE_ARG;
-            StgInfoTable* itbl = INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
-            int request        = CONSTR_sizeW( itbl->layout.payload.ptrs,
-                                               itbl->layout.payload.nptrs );
+            int o_itbl         = BCO_GET_LARGE_ARG;
+            int n_words        = BCO_GET_LARGE_ARG;
+            StgConInfoTable* itbl = CON_INFO_PTR_TO_STRUCT((StgInfoTable *)BCO_LIT(o_itbl));
+            int n_ptrs         = itbl->i.layout.payload.ptrs;
+            int n_nptrs        = itbl->i.layout.payload.nptrs;
+            int request        = CONSTR_sizeW( n_ptrs, n_nptrs );
             StgClosure* con = (StgClosure*)allocate_NONUPD(cap,request);
-            ASSERT( itbl->layout.payload.ptrs + itbl->layout.payload.nptrs > 0);
-            for (i = 0; i < n_words; i++) {
+            ASSERT(ip_HNF(&itbl->i)); // We don't have a CON flag, HNF is a good approximation
+                                      // N.
+            // N.B. we may have a nullary datacon with padding, in which case
+            // n_nptrs=1, n_ptrs=0.
+            ASSERT(n_ptrs + n_nptrs == n_words || (n_nptrs == 1 && n_ptrs == 0));
+            ASSERT(n_ptrs + n_nptrs > 0);
+            for (int i = 0; i < n_words; i++) {
                 con->payload[i] = (StgClosure*)SpW(i);
             }
             Sp_addW(n_words);
             Sp_subW(1);
             // No write barrier is needed here as this is a new allocation
             // visible only from our stack
-            StgInfoTable *con_itbl = (StgInfoTable*) BCO_LIT(o_itbl);
-            SET_HDR(con, con_itbl, cap->r.rCCCS);
+            StgInfoTable *con_ptr = (StgInfoTable*) BCO_LIT(o_itbl);
+            SET_HDR(con, con_ptr, cap->r.rCCCS);
 
             StgClosure* tagged_con = tagConstr(con);
             SpW(0) = (W_)tagged_con;


=====================================
rts/include/rts/storage/InfoTables.h
=====================================
@@ -86,7 +86,7 @@ extern const StgWord16 closure_flags[];
 #define closure_IND(c)          (  closureFlags(c) & _IND)
 
 /* same as above but for info-ptr rather than closure */
-#define ipFlags(ip)             (closure_flags[ip->type])
+#define ipFlags(ip)             (closure_flags[(ip)->type])
 
 #define ip_HNF(ip)               (  ipFlags(ip) & _HNF)
 #define ip_BITMAP(ip)            (  ipFlags(ip) & _BTM)


=====================================
testsuite/tests/codeGen/should_run/T23146/all.T
=====================================
@@ -1,4 +1,4 @@
-test('T23146', expect_broken_for(23060, ghci_ways), compile_and_run, [''])
+test('T23146', normal, compile_and_run, [''])
 test('T23146_lifted', normal, compile_and_run, [''])
 test('T23146_liftedeq', expect_broken_for(23060, ghci_ways), compile_and_run, [''])
 test('T23146_lifted_unlifted', normal, compile_and_run, [''])


=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -232,6 +232,7 @@ test('OrigThunkInfo', normal, compile_and_run, ['-forig-thunk-info'])
 # Note [MO_S_MulMayOflo significant width]) and may require fixing/adjustment.
 test('MulMayOflo_full',
      [ extra_files(['MulMayOflo.hs']),
+       req_cmm,
        when(unregisterised(), skip),
        unless(arch('x86_64') or arch('i386'), skip),
         ignore_stdout],


=====================================
testsuite/tests/parser/should_compile/T23315/Makefile
=====================================
@@ -0,0 +1,18 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
+
+SETUP = ./Setup -v0
+
+T23315: clean
+	$(MAKE) clean
+	'$(TEST_HC)' $(TEST_HC_OPTS) -v0 --make Setup
+	$(SETUP) clean
+	$(SETUP) configure $(CABAL_MINIMAL_BUILD) --with-ghc='$(TEST_HC)' --ghc-options='$(TEST_HC_OPTS)'
+	$(SETUP) build 1>&2
+ifneq "$(CLEANUP)" ""
+	$(MAKE) clean
+endif
+
+clean :
+	$(RM) -r */dist Setup$(exeext) *.o *.hi


=====================================
testsuite/tests/parser/should_compile/T23315/Setup.hs
=====================================
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
\ No newline at end of file


=====================================
testsuite/tests/parser/should_compile/T23315/T23315.cabal
=====================================
@@ -0,0 +1,10 @@
+name:                T23315
+version:             0.1.0.0
+build-type:          Simple
+cabal-version:       2.0
+
+library
+  signatures:          T23315
+  build-depends:       base >= 4.3 && < 5
+  default-language:    Haskell2010
+  ghc-options:         -Wall -haddock -ddump-parsed-ast


=====================================
testsuite/tests/parser/should_compile/T23315/T23315.hsig
=====================================
@@ -0,0 +1,4 @@
+signature T23315 where
+-- | My unit
+a :: ()
+-- ^ More docs


=====================================
testsuite/tests/parser/should_compile/T23315/T23315.stderr
=====================================
@@ -0,0 +1,112 @@
+
+==================== Parser AST ====================
+
+(L
+ { T23315.hsig:1:1 }
+ (HsModule
+  (XModulePs
+   (EpAnn
+    (Anchor
+     { T23315.hsig:1:1 }
+     (UnchangedAnchor))
+    (AnnsModule
+     [(AddEpAnn AnnSignature (EpaSpan { T23315.hsig:1:1-9 }))
+     ,(AddEpAnn AnnWhere (EpaSpan { T23315.hsig:1:18-22 }))]
+      []
+     (Nothing))
+    (EpaComments
+     []))
+   (VirtualBraces
+    (1))
+   (Nothing)
+   (Nothing))
+  (Just
+   (L
+    (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:1:11-16 })
+    {ModuleName: T23315}))
+  (Nothing)
+  []
+  [(L
+    (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:2:1-12 })
+    (DocD
+     (NoExtField)
+     (DocCommentNext
+      (L
+       { T23315.hsig:2:1-12 }
+       (WithHsDocIdentifiers
+        (MultiLineDocString
+         (HsDocStringNext)
+         (:|
+          (L
+           { T23315.hsig:2:5-12 }
+           (HsDocStringChunk
+            " My unit"))
+          []))
+        [])))))
+  ,(L
+    (SrcSpanAnn (EpAnn
+                 (Anchor
+                  { T23315.hsig:3:1-7 }
+                  (UnchangedAnchor))
+                 (AnnListItem
+                  [])
+                 (EpaComments
+                  [])) { T23315.hsig:3:1-7 })
+    (SigD
+     (NoExtField)
+     (TypeSig
+      (EpAnn
+       (Anchor
+        { T23315.hsig:3:1 }
+        (UnchangedAnchor))
+       (AnnSig
+        (AddEpAnn AnnDcolon (EpaSpan { T23315.hsig:3:3-4 }))
+        [])
+       (EpaComments
+        []))
+      [(L
+        (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:1 })
+        (Unqual
+         {OccName: a}))]
+      (HsWC
+       (NoExtField)
+       (L
+        (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:6-7 })
+        (HsSig
+         (NoExtField)
+         (HsOuterImplicit
+          (NoExtField))
+         (L
+          (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:3:6-7 })
+          (HsTupleTy
+           (EpAnn
+            (Anchor
+             { T23315.hsig:3:6 }
+             (UnchangedAnchor))
+            (AnnParen
+             (AnnParens)
+             (EpaSpan { T23315.hsig:3:6 })
+             (EpaSpan { T23315.hsig:3:7 }))
+            (EpaComments
+             []))
+           (HsBoxedOrConstraintTuple)
+           []))))))))
+  ,(L
+    (SrcSpanAnn (EpAnnNotUsed) { T23315.hsig:4:1-14 })
+    (DocD
+     (NoExtField)
+     (DocCommentPrev
+      (L
+       { T23315.hsig:4:1-14 }
+       (WithHsDocIdentifiers
+        (MultiLineDocString
+         (HsDocStringPrevious)
+         (:|
+          (L
+           { T23315.hsig:4:5-14 }
+           (HsDocStringChunk
+            " More docs"))
+          []))
+        [])))))]))
+
+


=====================================
testsuite/tests/parser/should_compile/T23315/all.T
=====================================
@@ -0,0 +1,3 @@
+test('T23315',
+     [extra_files(['Setup.hs']), js_broken(22352)],
+     makefile_test, [])


=====================================
testsuite/tests/unlifted-datatypes/should_run/all.T
=====================================
@@ -1,3 +1,3 @@
 test('UnlData1', normal, compile_and_run, [''])
-test('UnlGadt1', [exit_code(1), expect_broken_for(23060, ghci_ways)], compile_and_run, [''])
+test('UnlGadt1', exit_code(1), compile_and_run, [''])
 test('T23549', normal, multimod_compile_and_run, ['T23549', ''])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b5d727194b3bc27da10f4d163b8125bda5a192d...35d666aedd9b70d3d6452cb6efb11be56fffa715

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/5b5d727194b3bc27da10f4d163b8125bda5a192d...35d666aedd9b70d3d6452cb6efb11be56fffa715
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/20230721/96a91982/attachment-0001.html>


More information about the ghc-commits mailing list