[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 7 commits: ts: add compile_artifact, ignore_extension flag

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Tue Jan 9 20:02:43 UTC 2024



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


Commits:
232afe4f by doyougnu at 2024-01-09T15:01:49-05:00
ts: add compile_artifact, ignore_extension flag

In b521354216f2821e00d75f088d74081d8b236810 the testsuite gained the
capability to collect generic metrics. But this assumed that the test
was not linking and producing artifacts and we only wanted to track
object files, interface files, or build artifacts from the compiler
build. However, some backends, such as the JS backend, produce artifacts when
compiling, such as the jsexe directory which we want to track.

This patch:

- tweaks the testsuite to collect generic metrics on any build artifact
in the test directory.

- expands the exe_extension function to consider windows and adds the
ignore_extension flag.

- Modifies certain tests to add the ignore_extension flag. Tests such as
heaprof002 expect a .ps file, but on windows without ignore_extensions
the testsuite will look for foo.exe.ps. Hence the flag.

- adds the size_hello_artifact test

- - - - -
134a313a by amesgen at 2024-01-09T15:01:56-05:00
WASM metadata: use correct GHC version

- - - - -
90b672bb by Xiaoyan Ren at 2024-01-09T15:02:00-05:00
Allow SCC declarations in TH (#24081)

- - - - -
47cae88d by Xiaoyan Ren at 2024-01-09T15:02:00-05:00
Fix prettyprinting of SCC pragmas

- - - - -
da367bfe by Simon Peyton Jones at 2024-01-09T15:02:00-05:00
Make TYPE and CONSTRAINT not-apart

Issue #24279 showed up a bug in the logic in GHC.Core.Unify.unify_ty
which is supposed to make TYPE and CONSTRAINT be not-apart.

Easily fixed.

- - - - -
87045641 by Zubin Duggal at 2024-01-09T15:02:01-05:00
ci: Fix typo in mk_ghcup_metadata.py

There was a missing colon in the fix to #24268 in 989bf8e53c08eb22de716901b914b3607bc8dd08

- - - - -
f86a1daf by Zubin Duggal at 2024-01-09T15:02:01-05:00
release-ci: remove release-x86_64-linux-deb11-release+boot_nonmoving_gc job

There is no reason to have this release build or distribute this variation.
This configuration is for testing purposes only.

- - - - -


30 changed files:

- .gitlab/generate-ci/gen_ci.hs
- .gitlab/jobs.yaml
- .gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
- compiler/GHC/Builtin/Names/TH.hs
- compiler/GHC/CmmToAsm/Wasm/Asm.hs
- compiler/GHC/Core/Unify.hs
- compiler/GHC/HsToCore/Quote.hs
- compiler/GHC/ThToHs.hs
- compiler/GHC/Types/SourceText.hs
- libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
- libraries/template-haskell/Language/Haskell/TH/Ppr.hs
- libraries/template-haskell/Language/Haskell/TH/Syntax.hs
- libraries/template-haskell/changelog.md
- testsuite/driver/testglobals.py
- testsuite/driver/testlib.py
- testsuite/tests/hpc/function/test.T
- testsuite/tests/hpc/function2/test.T
- testsuite/tests/hpc/simple/test.T
- testsuite/tests/perf/size/all.T
- + testsuite/tests/perf/size/size_hello_artifact.hs
- testsuite/tests/profiling/should_run/all.T
- + testsuite/tests/th/should_compile/T24081/Main.hs
- + testsuite/tests/th/should_compile/T24081/Makefile
- + testsuite/tests/th/should_compile/T24081/T24081.stderr
- + testsuite/tests/th/should_compile/T24081/TH.hs
- + testsuite/tests/th/should_compile/T24081/all.T
- + testsuite/tests/typecheck/should_fail/T24279.hs
- + testsuite/tests/typecheck/should_fail/T24279.stderr
- testsuite/tests/typecheck/should_fail/all.T
- testsuite/tests/typecheck/testeq1/test.T


Changes:

=====================================
.gitlab/generate-ci/gen_ci.hs
=====================================
@@ -1020,7 +1020,7 @@ job_groups =
          make_wasm_jobs wasm_build_config {bignumBackend = Native}
      , modifyValidateJobs manual $
          make_wasm_jobs wasm_build_config {unregisterised = True}
-     , onlyRule NonmovingGc (standardBuildsWithConfig Amd64 (Linux Debian11) vanilla {validateNonmovingGc = True})
+     , onlyRule NonmovingGc (validateBuilds Amd64 (Linux Debian11) vanilla {validateNonmovingGc = True})
      , onlyRule IpeData (validateBuilds Amd64 (Linux Debian10) zstdIpe)
      ]
 


=====================================
.gitlab/jobs.yaml
=====================================
@@ -3565,70 +3565,6 @@
       "XZ_OPT": "-9"
     }
   },
-  "release-x86_64-linux-deb11-release+boot_nonmoving_gc": {
-    "after_script": [
-      ".gitlab/ci.sh save_cache",
-      ".gitlab/ci.sh save_test_output",
-      ".gitlab/ci.sh clean",
-      "cat ci_timings"
-    ],
-    "allow_failure": false,
-    "artifacts": {
-      "expire_in": "1 year",
-      "paths": [
-        "ghc-x86_64-linux-deb11-release+boot_nonmoving_gc.tar.xz",
-        "junit.xml",
-        "unexpected-test-output.tar.gz"
-      ],
-      "reports": {
-        "junit": "junit.xml"
-      },
-      "when": "always"
-    },
-    "cache": {
-      "key": "x86_64-linux-deb11-$CACHE_REV",
-      "paths": [
-        "cabal-cache",
-        "toolchain"
-      ]
-    },
-    "dependencies": [],
-    "image": "registry.gitlab.haskell.org/ghc/ci-images/x86_64-linux-deb11:$DOCKER_REV",
-    "needs": [
-      {
-        "artifacts": false,
-        "job": "hadrian-ghc-in-ghci"
-      }
-    ],
-    "rules": [
-      {
-        "if": "(\"true\" == \"true\") && ($RELEASE_JOB == \"yes\") && ($NIGHTLY == null)",
-        "when": "on_success"
-      }
-    ],
-    "script": [
-      "sudo chown ghc:ghc -R .",
-      ".gitlab/ci.sh setup",
-      ".gitlab/ci.sh configure",
-      ".gitlab/ci.sh build_hadrian",
-      ".gitlab/ci.sh test_hadrian"
-    ],
-    "stage": "full-build",
-    "tags": [
-      "x86_64-linux"
-    ],
-    "variables": {
-      "BIGNUM_BACKEND": "gmp",
-      "BIN_DIST_NAME": "ghc-x86_64-linux-deb11-release+boot_nonmoving_gc",
-      "BUILD_FLAVOUR": "release+boot_nonmoving_gc",
-      "CONFIGURE_ARGS": "--enable-strict-ghc-toolchain-check",
-      "HADRIAN_ARGS": "--hash-unit-ids",
-      "IGNORE_PERF_FAILURES": "all",
-      "RUNTEST_ARGS": "--way=nonmoving --way=nonmoving_thr --way=nonmoving_thr_sanity",
-      "TEST_ENV": "x86_64-linux-deb11-release+boot_nonmoving_gc",
-      "XZ_OPT": "-9"
-    }
-  },
   "release-x86_64-linux-deb12-release": {
     "after_script": [
       ".gitlab/ci.sh save_cache",


=====================================
.gitlab/rel_eng/mk-ghcup-metadata/mk_ghcup_metadata.py
=====================================
@@ -145,7 +145,7 @@ def mk_one_metadata(release_mode, version, job_map, artifact):
         # So we must manually set the name of the bindist location
         if artifact == test_artifact:
             bindist_name = "testsuite"
-        else
+        else:
             bindist_name = fetch_gitlab.job_triple(artifact.job_name)
         final_url = release_base.format( version=version
                                        , bindistName=urllib.parse.quote_plus(f"{bindist_name}.tar.xz"))


=====================================
compiler/GHC/Builtin/Names/TH.hs
=====================================
@@ -76,7 +76,8 @@ templateHaskellNames = [
     classDName, instanceWithOverlapDName,
     standaloneDerivWithStrategyDName, sigDName, kiSigDName, forImpDName,
     pragInlDName, pragOpaqueDName, pragSpecDName, pragSpecInlDName, pragSpecInstDName,
-    pragRuleDName, pragCompleteDName, pragAnnDName, defaultSigDName, defaultDName,
+    pragRuleDName, pragCompleteDName, pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
+    defaultSigDName, defaultDName,
     dataFamilyDName, openTypeFamilyDName, closedTypeFamilyDName,
     dataInstDName, newtypeInstDName, tySynInstDName,
     infixLDName, infixRDName, infixNDName,
@@ -374,7 +375,8 @@ recSName    = libFun (fsLit "recS")    recSIdKey
 funDName, valDName, dataDName, newtypeDName, typeDataDName, tySynDName, classDName,
     instanceWithOverlapDName, sigDName, kiSigDName, forImpDName, pragInlDName,
     pragSpecDName, pragSpecInlDName, pragSpecInstDName, pragRuleDName,
-    pragAnnDName, standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
+    pragAnnDName, pragSCCFunDName, pragSCCFunNamedDName,
+    standaloneDerivWithStrategyDName, defaultSigDName, defaultDName,
     dataInstDName, newtypeInstDName, tySynInstDName, dataFamilyDName,
     openTypeFamilyDName, closedTypeFamilyDName, infixLDName, infixRDName,
     infixNDName, roleAnnotDName, patSynDName, patSynSigDName,
@@ -401,6 +403,8 @@ pragSpecInstDName                = libFun (fsLit "pragSpecInstD")
 pragRuleDName                    = libFun (fsLit "pragRuleD")                    pragRuleDIdKey
 pragCompleteDName                = libFun (fsLit "pragCompleteD")                pragCompleteDIdKey
 pragAnnDName                     = libFun (fsLit "pragAnnD")                     pragAnnDIdKey
+pragSCCFunDName                  = libFun (fsLit "pragSCCFunD")                  pragSCCFunDKey
+pragSCCFunNamedDName             = libFun (fsLit "pragSCCFunNamedD")             pragSCCFunNamedDKey
 dataInstDName                    = libFun (fsLit "dataInstD")                    dataInstDIdKey
 newtypeInstDName                 = libFun (fsLit "newtypeInstD")                 newtypeInstDIdKey
 tySynInstDName                   = libFun (fsLit "tySynInstD")                   tySynInstDIdKey
@@ -921,7 +925,8 @@ funDIdKey, valDIdKey, dataDIdKey, newtypeDIdKey, tySynDIdKey, classDIdKey,
     newtypeInstDIdKey, tySynInstDIdKey, standaloneDerivWithStrategyDIdKey,
     infixLDIdKey, infixRDIdKey, infixNDIdKey, roleAnnotDIdKey, patSynDIdKey,
     patSynSigDIdKey, pragCompleteDIdKey, implicitParamBindDIdKey,
-    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey :: Unique
+    kiSigDIdKey, defaultDIdKey, pragOpaqueDIdKey, typeDataDIdKey,
+    pragSCCFunDKey, pragSCCFunNamedDKey :: Unique
 funDIdKey                         = mkPreludeMiscIdUnique 320
 valDIdKey                         = mkPreludeMiscIdUnique 321
 dataDIdKey                        = mkPreludeMiscIdUnique 322
@@ -958,6 +963,8 @@ kiSigDIdKey                       = mkPreludeMiscIdUnique 352
 defaultDIdKey                     = mkPreludeMiscIdUnique 353
 pragOpaqueDIdKey                  = mkPreludeMiscIdUnique 354
 typeDataDIdKey                    = mkPreludeMiscIdUnique 355
+pragSCCFunDKey                    = mkPreludeMiscIdUnique 356
+pragSCCFunNamedDKey               = mkPreludeMiscIdUnique 357
 
 -- type Cxt = ...
 cxtIdKey :: Unique


=====================================
compiler/GHC/CmmToAsm/Wasm/Asm.hs
=====================================
@@ -12,6 +12,7 @@ import Control.Monad.Trans.Reader
 import Data.ByteString (ByteString)
 import qualified Data.ByteString as BS
 import Data.ByteString.Builder
+import qualified Data.ByteString.Char8 as BS8
 import Data.Coerce
 import Data.Foldable
 import qualified GHC.Data.Word64Set as WS
@@ -25,6 +26,7 @@ import GHC.CmmToAsm.Wasm.Utils
 import GHC.Data.FastString
 import GHC.Float
 import GHC.Prelude
+import GHC.Settings.Config (cProjectVersion)
 import GHC.Types.Basic
 import GHC.Types.Unique
 import GHC.Types.Unique.Map
@@ -485,7 +487,7 @@ asmTellProducers = do
         asmTellVec
           [ do
               asmTellBS "ghc"
-              asmTellBS "9.6"
+              asmTellBS $ BS8.pack cProjectVersion
           ]
     ]
 


=====================================
compiler/GHC/Core/Unify.hs
=====================================
@@ -31,6 +31,7 @@ import GHC.Types.Var
 import GHC.Types.Var.Env
 import GHC.Types.Var.Set
 import GHC.Types.Name( Name, mkSysTvName, mkSystemVarName )
+import GHC.Builtin.Names( tYPETyConKey, cONSTRAINTTyConKey )
 import GHC.Core.Type     hiding ( getTvSubstEnv )
 import GHC.Core.Coercion hiding ( getCvSubstEnv )
 import GHC.Core.TyCon
@@ -1149,8 +1150,10 @@ unify_ty env ty1 ty2 _kco
   -- TYPE and CONSTRAINT are not Apart
   -- See Note [Type and Constraint are not apart] in GHC.Builtin.Types.Prim
   -- NB: at this point we know that the two TyCons do not match
-  | Just {} <- sORTKind_maybe ty1
-  , Just {} <- sORTKind_maybe ty2
+  | Just (tc1,_) <- mb_tc_app1, let u1 = tyConUnique tc1
+  , Just (tc2,_) <- mb_tc_app2, let u2 = tyConUnique tc2
+  , (u1 == tYPETyConKey && u2 == cONSTRAINTTyConKey) ||
+    (u2 == tYPETyConKey && u1 == cONSTRAINTTyConKey)
   = maybeApart MARTypeVsConstraint
     -- We don't bother to look inside; wrinkle (W3) in GHC.Builtin.Types.Prim
     -- Note [Type and Constraint are not apart]


=====================================
compiler/GHC/HsToCore/Quote.hs
=====================================
@@ -997,7 +997,7 @@ rep_sig (L loc (SpecSig _ nm tys ispec))
   = concatMapM (\t -> rep_specialise nm t ispec (locA loc)) tys
 rep_sig (L loc (SpecInstSig _ ty))  = rep_specialiseInst ty (locA loc)
 rep_sig (L _   (MinimalSig {}))       = notHandled ThMinimalPragmas
-rep_sig (L _   (SCCFunSig {}))        = notHandled ThSCCPragmas
+rep_sig (L loc (SCCFunSig _ nm str)) = rep_sccFun nm str (locA loc)
 rep_sig (L loc (CompleteMatchSig _ cls mty))
   = rep_complete_sig cls mty (locA loc)
 rep_sig d@(L _ (XSig {}))             = pprPanic "rep_sig IdSig" (ppr d)
@@ -1121,6 +1121,21 @@ rep_specialiseInst ty loc
        ; pragma <- repPragSpecInst ty1
        ; return [(loc, pragma)] }
 
+rep_sccFun :: LocatedN Name
+        -> Maybe (XRec GhcRn StringLiteral)
+        -> SrcSpan
+        -> MetaM [(SrcSpan, Core (M TH.Dec))]
+rep_sccFun nm Nothing loc = do
+  nm1 <- lookupLOcc nm
+  scc <- repPragSCCFun nm1
+  return [(loc, scc)]
+
+rep_sccFun nm (Just (L _ str)) loc = do
+  nm1 <- lookupLOcc nm
+  str1 <- coreStringLit (sl_fs str)
+  scc <- repPragSCCFunNamed nm1 str1
+  return [(loc, scc)]
+
 repInline :: InlineSpec -> MetaM (Core TH.Inline)
 repInline (NoInline          _ )   = dataCon noInlineDataConName
 -- There is a mismatch between the TH and GHC representation because
@@ -2687,6 +2702,12 @@ repPragRule (MkC nm) (MkC ty_bndrs) (MkC tm_bndrs) (MkC lhs) (MkC rhs) (MkC phas
 repPragAnn :: Core TH.AnnTarget -> Core (M TH.Exp) -> MetaM (Core (M TH.Dec))
 repPragAnn (MkC targ) (MkC e) = rep2 pragAnnDName [targ, e]
 
+repPragSCCFun :: Core TH.Name -> MetaM (Core (M TH.Dec))
+repPragSCCFun (MkC nm) = rep2 pragSCCFunDName [nm]
+
+repPragSCCFunNamed :: Core TH.Name -> Core String -> MetaM (Core (M TH.Dec))
+repPragSCCFunNamed (MkC nm) (MkC str) = rep2 pragSCCFunNamedDName [nm, str]
+
 repTySynInst :: Core (M TH.TySynEqn) -> MetaM (Core (M TH.Dec))
 repTySynInst (MkC eqn)
     = rep2 tySynInstDName [eqn]


=====================================
compiler/GHC/ThToHs.hs
=====================================
@@ -954,6 +954,12 @@ cvtPragmaD (CompleteP cls mty)
        ; mty'  <- traverse tconNameN mty
        ; returnJustLA $ Hs.SigD noExtField
                    $ CompleteMatchSig (noAnn, NoSourceText) cls' mty' }
+cvtPragmaD (SCCP nm str) = do
+  nm' <- vcNameN nm
+  str' <- traverse (\s ->
+    returnLA $ StringLiteral NoSourceText (mkFastString s) Nothing) str
+  returnJustLA $ Hs.SigD noExtField
+    $ SCCFunSig (noAnn, SourceText $ fsLit "{-# SCC") nm' str'
 
 dfltActivation :: TH.Inline -> Activation
 dfltActivation TH.NoInline = NeverActive


=====================================
compiler/GHC/Types/SourceText.hs
=====================================
@@ -322,4 +322,4 @@ instance Eq StringLiteral where
   (StringLiteral _ a _) == (StringLiteral _ b _) = a == b
 
 instance Outputable StringLiteral where
-  ppr sl = pprWithSourceText (sl_st sl) (ftext $ sl_fs sl)
+  ppr sl = pprWithSourceText (sl_st sl) (doubleQuotes $ ftext $ sl_fs sl)


=====================================
libraries/template-haskell/Language/Haskell/TH/Lib/Internal.hs
=====================================
@@ -553,6 +553,12 @@ pragLineD line file = pure $ PragmaD $ LineP line file
 pragCompleteD :: Quote m => [Name] -> Maybe Name -> m Dec
 pragCompleteD cls mty = pure $ PragmaD $ CompleteP cls mty
 
+pragSCCFunD :: Quote m => Name -> m Dec
+pragSCCFunD nm = pure $ PragmaD $ SCCP nm Nothing
+
+pragSCCFunNamedD :: Quote m => Name -> String -> m Dec
+pragSCCFunNamedD nm str = pure $ PragmaD $ SCCP nm (Just str)
+
 dataInstD :: Quote m => m Cxt -> (Maybe [m (TyVarBndr ())]) -> m Type -> Maybe (m Kind) -> [m Con]
           -> [m DerivClause] -> m Dec
 dataInstD ctxt mb_bndrs ty ksig cons derivs =


=====================================
libraries/template-haskell/Language/Haskell/TH/Ppr.hs
=====================================
@@ -658,6 +658,8 @@ instance Ppr Pragma where
     ppr (CompleteP cls mty)
        = text "{-# COMPLETE" <+> (fsep $ punctuate comma $ map (pprName' Applied) cls)
                 <+> maybe empty (\ty -> dcolon <+> pprName' Applied ty) mty <+> text "#-}"
+    ppr (SCCP nm str)
+       = text "{-# SCC" <+> pprName' Applied nm <+> maybe empty pprString str <+> text "#-}"
 
 ------------------------------
 instance Ppr Inline where


=====================================
libraries/template-haskell/Language/Haskell/TH/Syntax.hs
=====================================
@@ -2629,6 +2629,8 @@ data Pragma = InlineP         Name Inline RuleMatch Phases
             | LineP           Int String
             | CompleteP       [Name] (Maybe Name)
                 -- ^ @{ {\-\# COMPLETE C_1, ..., C_i [ :: T ] \#-} }@
+            | SCCP            Name (Maybe String)
+                -- ^ @{ {\-\# SCC fun "optional_name" \#-} }@
         deriving( Show, Eq, Ord, Data, Generic )
 
 data Inline = NoInline


=====================================
libraries/template-haskell/changelog.md
=====================================
@@ -8,6 +8,8 @@
   * Extend `Pat` with `TypeP` and `Exp` with `TypeE`,
     introduce functions `typeP` and `typeE` (GHC Proposal #281).
 
+  * Extend `Pragma` with `SCCP`.
+
 ## 2.21.0.0
 
   * Record fields now belong to separate `NameSpace`s, keyed by the parent of


=====================================
testsuite/driver/testglobals.py
=====================================
@@ -355,6 +355,9 @@ class TestOptions:
        self.ignore_stdout = False
        self.ignore_stderr = False
 
+       # don't use the executable extension
+       self.ignore_extension = False
+
        # Backpack test
        self.compile_backpack = False
 


=====================================
testsuite/driver/testlib.py
=====================================
@@ -138,9 +138,6 @@ def no_deps( name, opts):
 def skip( name, opts ):
     opts.skip = True
 
-def js_arch() -> bool:
-    return arch("javascript");
-
 # disable test on JS arch
 def js_skip( name, opts ):
     if js_arch():
@@ -398,6 +395,18 @@ def ignore_stdout(name, opts):
 def ignore_stderr(name, opts):
     opts.ignore_stderr = True
 
+def ignore_extension(name, opts):
+    """
+    Some tests generate files that are not expected to be suffixed with an
+    extension type, such as .exe on windows. This option allows these tests to
+    have finer-grained control over the filename that the testsuite will look
+    for. Examples of such tests are hpc tests which expect a .tix extension and
+    hp2ps tests which expect .hp. For these tests, on windows and without
+    ignoring the extension, the testsuite will look for, e.g., 'foo.exe.tix'
+    instead of 'foo.tix'.
+    """
+    opts.ignore_extension = True
+
 def combined_output( name, opts ):
     opts.combined_output = True
 
@@ -811,6 +820,8 @@ KNOWN_OPERATING_SYSTEMS = set([
 def exe_extension() -> str:
     if config.arch == 'wasm32':
         return '.wasm'
+    elif config.os == "mingw32":
+        return '.exe'
     return ''
 
 def opsys( os: str ) -> bool:
@@ -829,6 +840,9 @@ def msys( ) -> bool:
 def cygwin( ) -> bool:
     return config.cygwin
 
+def js_arch() -> bool:
+    return arch("javascript");
+
 def have_vanilla( ) -> bool:
     return config.have_vanilla
 
@@ -1592,6 +1606,10 @@ async def ghci_script( name, way, script):
 async def compile( name, way, extra_hc_opts ):
     return await do_compile( name, way, False, None, [],  [], extra_hc_opts )
 
+async def compile_artifact( name, way, extra_hc_opts ):
+    # We suppress stderr so that the link output isn't compared
+    return await do_compile( name, way, False, None, [], [], extra_hc_opts, should_link=True, compare_stderr=False )
+
 async def compile_fail( name, way, extra_hc_opts ):
     return await do_compile( name, way, True, None, [], [], extra_hc_opts )
 
@@ -1607,9 +1625,6 @@ async def backpack_compile( name, way, extra_hc_opts ):
 async def backpack_compile_fail( name, way, extra_hc_opts ):
     return await do_compile( name, way, True, None, [], [], extra_hc_opts, backpack=True )
 
-async def backpack_run( name, way, extra_hc_opts ):
-    return await compile_and_run__( name, way, None, [], extra_hc_opts, backpack=True )
-
 async def multimod_compile( name, way, top_mod, extra_hc_opts ):
     return await do_compile( name, way, False, top_mod, [], [], extra_hc_opts )
 
@@ -1638,6 +1653,8 @@ async def do_compile(name: TestName,
                extra_mods: List[str],
                units: List[str],
                extra_hc_opts: str,
+               should_link=False,
+               compare_stderr=True,
                **kwargs
                ) -> PassFail:
     # print 'Compile only, extra args = ', extra_hc_opts
@@ -1647,7 +1664,7 @@ async def do_compile(name: TestName,
        return result
     extra_hc_opts = result.hc_opts
 
-    result = await simple_build(name, way, extra_hc_opts, should_fail, top_mod, units, False, True, **kwargs)
+    result = await simple_build(name, way, extra_hc_opts, should_fail, top_mod, units, should_link, True, **kwargs)
 
     if badResult(result):
         return result
@@ -1660,7 +1677,7 @@ async def do_compile(name: TestName,
     actual_stderr_file = add_suffix(name, 'comp.stderr')
     diff_file_name = in_testdir(add_suffix(name, 'comp.diff'))
 
-    if not await compare_outputs(way, 'stderr',
+    if compare_stderr and not await compare_outputs(way, 'stderr',
                            join_normalisers(getTestOpts().extra_errmsg_normaliser,
                                             normalise_errmsg),
                            expected_stderr_file, actual_stderr_file,
@@ -1762,7 +1779,8 @@ async def compile_and_run__(name: TestName,
                       extra_mods: List[str],
                       extra_hc_opts: str,
                       backpack: bool=False,
-                      compile_stderr: bool=False
+                      compile_stderr: bool=False,
+                      use_extension: bool=True
                       ) -> PassFail:
     # print 'Compile and run, extra args = ', extra_hc_opts
 
@@ -1795,8 +1813,11 @@ async def compile_and_run__(name: TestName,
              stderr = diff_file_name.read_text()
              diff_file_name.unlink()
              return failBecause('ghc.stderr mismatch', stderr=stderr)
-#
-        cmd = './' + name + exe_extension()
+
+        opts = getTestOpts()
+        extension = exe_extension() if not opts.ignore_extension else ""
+
+        cmd = './' + name + extension
 
         # we don't check the compiler's stderr for a compile-and-run test
         return await simple_run( name, way, cmd, getTestOpts().extra_run_opts )
@@ -1804,6 +1825,9 @@ async def compile_and_run__(name: TestName,
 async def compile_and_run( name, way, extra_hc_opts ):
     return await compile_and_run__( name, way, None, [], extra_hc_opts)
 
+async def backpack_run( name, way, extra_hc_opts ):
+    return await compile_and_run__( name, way, None, [], extra_hc_opts, backpack=True )
+
 async def multimod_compile_and_run( name, way, top_mod, extra_hc_opts ):
     return await compile_and_run__( name, way, top_mod, [], extra_hc_opts)
 
@@ -2310,8 +2334,8 @@ def write_file(f: Path, s: str) -> None:
 # operate on bytes.
 
 async def check_hp_ok(name: TestName) -> bool:
-    actual_name = name + exe_extension()
     opts = getTestOpts()
+    actual_name = name + exe_extension() if not opts.ignore_extension else name
 
     # do not qualify for hp2ps because we should be in the right directory
     hp2psCmd = 'cd "{opts.testdir}" && {{hp2ps}} {actual_name}'.format(**locals())


=====================================
testsuite/tests/hpc/function/test.T
=====================================
@@ -5,5 +5,6 @@ hpc_prefix = "perl hpcrun.pl --clear --exeext={exeext} --hpc={hpc}"
 test('tough',
      [extra_files(['../hpcrun.pl']),
       cmd_prefix(hpc_prefix),
+      ignore_extension,
       when(arch('wasm32'), fragile(23243))],
      compile_and_run, ['-fhpc'])


=====================================
testsuite/tests/hpc/function2/test.T
=====================================
@@ -10,6 +10,7 @@ test('tough2',
      [extra_files(['../hpcrun.pl', 'subdir/']),
        literate,
        cmd_prefix(hpc_prefix),
+       ignore_extension,
        omit_ways(ghci_ways + prof_ways), # profile goes in the wrong place
        when(arch('wasm32'), fragile(23243)) ],
      multimod_compile_and_run, ['subdir/tough2.lhs', '-fhpc'])


=====================================
testsuite/tests/hpc/simple/test.T
=====================================
@@ -3,6 +3,7 @@ setTestOpts([omit_ghci, when(fast(), skip), js_skip])
 hpc_prefix = "perl hpcrun.pl --clear --exeext={exeext} --hpc={hpc}"
 
 test('hpc001', [extra_files(['../hpcrun.pl']), cmd_prefix(hpc_prefix),
-     when(arch('wasm32'), fragile(23243))
+     when(arch('wasm32'), fragile(23243)),
+     ignore_extension
      ],
      compile_and_run, ['-fhpc'])


=====================================
testsuite/tests/perf/size/all.T
=====================================
@@ -1,3 +1,6 @@
 test('size_hello_obj', [collect_size(5, 'size_hello_obj.o')], compile, [''])
 
+test('size_hello_artifact', [collect_size(5, 'size_hello_artifact' + exe_extension())],
+                             compile_artifact, [''])
+
 test('libdir',[collect_size_dir(10, config.libdir)], static_stats, [] )


=====================================
testsuite/tests/perf/size/size_hello_artifact.hs
=====================================
@@ -0,0 +1,4 @@
+-- same as size_hello_obj but we test the size of the resulting executable.
+module Main where
+
+main = print "Hello World!"


=====================================
testsuite/tests/profiling/should_run/all.T
=====================================
@@ -4,6 +4,7 @@ setTestOpts(js_skip) # JS backend doesn't support profiling yet
 
 test('heapprof002',
      [extra_files(['heapprof001.hs']),
+      ignore_extension,
       pre_cmd('cp heapprof001.hs heapprof002.hs'), extra_ways(['normal_h']),
       extra_run_opts('7')],
      compile_and_run, [''])


=====================================
testsuite/tests/th/should_compile/T24081/Main.hs
=====================================
@@ -0,0 +1,11 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+import TH
+
+x
+y
+a = 1
+b = 1
+gen
+
+main = return ()


=====================================
testsuite/tests/th/should_compile/T24081/Makefile
=====================================
@@ -0,0 +1,3 @@
+TOP=../../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk


=====================================
testsuite/tests/th/should_compile/T24081/T24081.stderr
=====================================
@@ -0,0 +1,15 @@
+Main.hs:5:1: Splicing declarations
+    x
+  ======>
+    {-# SCC f #-}
+    f = 1
+Main.hs:6:1: Splicing declarations
+    y
+  ======>
+    {-# SCC g "custom_name_g" #-}
+    g = 1
+Main.hs:9:1-3: Splicing declarations
+    gen
+  ======>
+    {-# SCC a #-}
+    {-# SCC b "custom_name_b" #-}


=====================================
testsuite/tests/th/should_compile/T24081/TH.hs
=====================================
@@ -0,0 +1,18 @@
+{-# LANGUAGE TemplateHaskell #-}
+module TH where
+
+import Data.Maybe
+import Language.Haskell.TH
+
+x, y :: Q [Dec]
+x = [d|{-# SCC f #-}; f = 1|]
+y = [d|{-# SCC g "custom_name_g" #-}; g = 1|]
+
+gen :: Q [Dec]
+gen = do
+  a <- fromJust <$> lookupValueName "a"
+  b <- fromJust <$> lookupValueName "b"
+  pure
+    [ PragmaD $ SCCP a Nothing
+    , PragmaD $ SCCP b (Just "custom_name_b")
+    ]


=====================================
testsuite/tests/th/should_compile/T24081/all.T
=====================================
@@ -0,0 +1,2 @@
+test('T24081', [extra_files(['TH.hs', 'Main.hs']), req_th],
+	      multimod_compile, ['TH Main', '-v0 -ddump-splices -dsuppress-uniques'])


=====================================
testsuite/tests/typecheck/should_fail/T24279.hs
=====================================
@@ -0,0 +1,31 @@
+{-# LANGUAGE TypeFamilies #-}
+module T24279 where
+
+import GHC.Exts
+import Data.Kind
+
+type F :: (RuntimeRep -> Type) -> Type
+type family F a where
+  F TYPE = Int
+  F CONSTRAINT = Bool
+
+type G :: Type -> RuntimeRep -> Type
+type family G a where
+  G (a b) = a
+
+-- Should be rejected
+foo :: (F (G Constraint)) -> Bool
+foo x = x
+
+
+type family H a b where
+  H a a = Int
+  H a b = Bool
+
+-- Should be rejected
+bar1 :: H TYPE CONSTRAINT -> Int
+bar1 x = x
+
+-- Should be rejected
+bar2 :: H Type Constraint -> Int
+bar2 x = x


=====================================
testsuite/tests/typecheck/should_fail/T24279.stderr
=====================================
@@ -0,0 +1,19 @@
+
+T24279.hs:18:9: error: [GHC-83865]
+    • Couldn't match type ‘F CONSTRAINT’ with ‘Bool’
+      Expected: Bool
+        Actual: F (G Constraint)
+    • In the expression: x
+      In an equation for ‘foo’: foo x = x
+
+T24279.hs:27:10: error: [GHC-83865]
+    • Couldn't match expected type ‘Int’
+                  with actual type ‘H TYPE CONSTRAINT’
+    • In the expression: x
+      In an equation for ‘bar1’: bar1 x = x
+
+T24279.hs:31:10: error: [GHC-83865]
+    • Couldn't match expected type ‘Int’
+                  with actual type ‘H (*) Constraint’
+    • In the expression: x
+      In an equation for ‘bar2’: bar2 x = x


=====================================
testsuite/tests/typecheck/should_fail/all.T
=====================================
@@ -711,3 +711,4 @@ test('T17940', normal, compile_fail, [''])
 test('ErrorIndexLinks', normal, compile_fail, ['-fprint-error-index-links=always'])
 test('T24064', normal, compile_fail, [''])
 test('T24298', normal, compile_fail, [''])
+test('T24279', normal, compile_fail, [''])


=====================================
testsuite/tests/typecheck/testeq1/test.T
=====================================
@@ -1,6 +1,7 @@
 
 test('typecheck.testeq1', [ extra_files(['FakePrelude.hs', 'Main.hs', 'TypeCast.hs', 'TypeEq.hs'])
                           , when(fast(), skip)
+                          , ignore_extension
                           , js_broken(22355)
                           # https://gitlab.haskell.org/ghc/ghc/-/issues/23238
                           , when(arch('wasm32'), skip)



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2eb35b8d2e18b202f8bbcba38a338358a3ef9e83...f86a1daf065d6354bc1a2697bd648ed7632054e8

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/2eb35b8d2e18b202f8bbcba38a338358a3ef9e83...f86a1daf065d6354bc1a2697bd648ed7632054e8
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/20240109/38763967/attachment-0001.html>


More information about the ghc-commits mailing list