[Git][ghc/ghc][wip/t24277] 3 commits: testsuite: Handle exceptions in framework_fail when testdir is not initialised

Finley McIlwaine (@FinleyMcIlwaine) gitlab at gitlab.haskell.org
Wed May 1 17:18:39 UTC 2024



Finley McIlwaine pushed to branch wip/t24277 at Glasgow Haskell Compiler / GHC


Commits:
c56d728e by Zubin Duggal at 2024-04-30T22:45:09-04:00
testsuite: Handle exceptions in framework_fail when testdir is not initialised

When `framework_fail` is called before initialising testdir, it would fail with
an exception reporting the testdir not being initialised instead of the actual failure.

Ensure we report the actual reason for the failure instead of failing in this way.

One way this can manifest is when trying to run a test that doesn't exist using `--only`

- - - - -
d5bea4d6 by Alan Zimmerman at 2024-04-30T22:45:45-04:00
EPA: Fix range for GADT decl with sig only

Closes #24714

- - - - -
807da909 by Finley McIlwaine at 2024-05-01T10:18:30-07:00
ghc-internal: Add CostCentreId, currentCallStackIds, ccsToIds, ccId

Add functions for gettings the IDs of cost centres to the interface of
`GHC.Internal.Stack`, `GHC.Internal.Stack.CCS`, and `GHC.Internal.Exts`.
Also add an opaque type for cost center ids, `CostCentreId`, with
appropriate instances.

Resolves #24277

- - - - -


8 changed files:

- compiler/GHC/Parser.y
- libraries/ghc-internal/src/GHC/Internal/Exts.hs
- libraries/ghc-internal/src/GHC/Internal/Stack.hs
- libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc
- testsuite/driver/testlib.py
- + testsuite/tests/printer/DataDeclShort.hs
- testsuite/tests/printer/Makefile
- testsuite/tests/printer/all.T


Changes:

=====================================
compiler/GHC/Parser.y
=====================================
@@ -1303,7 +1303,7 @@ ty_decl :: { LTyClDecl GhcPs }
         | type_data_or_newtype capi_ctype tycl_hdr opt_kind_sig
                  gadt_constrlist
                  maybe_derivings
-            {% mkTyData (comb4 $1 $3 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
+            {% mkTyData (comb5 $1 $3 $4 $5 $6) (sndOf3 $ unLoc $1) (thdOf3 $ unLoc $1) $2 $3
                             (snd $ unLoc $4) (snd $ unLoc $5)
                             (fmap reverse $6)
                             ((fstOf3 $ unLoc $1)++(fst $ unLoc $4)++(fst $ unLoc $5)) }


=====================================
libraries/ghc-internal/src/GHC/Internal/Exts.hs
=====================================
@@ -103,6 +103,8 @@ module GHC.Internal.Exts
 
         -- ** The call stack
         currentCallStack,
+        currentCallStackIds,
+        CostCentreId,
 
         -- * Ids with special behaviour
         inline, noinline, lazy, oneShot, considerAccessible, seq#,


=====================================
libraries/ghc-internal/src/GHC/Internal/Stack.hs
=====================================
@@ -24,6 +24,7 @@ module GHC.Internal.Stack (
 
     -- * Profiling call stacks
     currentCallStack,
+    currentCallStackIds,
     whoCreated,
 
     -- * HasCallStack call stacks
@@ -38,14 +39,17 @@ module GHC.Internal.Stack (
     -- * Internals
     CostCentreStack,
     CostCentre,
+    CostCentreId,
     getCurrentCCS,
     getCCSOf,
     clearCCS,
     ccsCC,
     ccsParent,
+    ccId,
     ccLabel,
     ccModule,
     ccSrcSpan,
+    ccsToIds,
     ccsToStrings,
     renderStack
   ) where


=====================================
libraries/ghc-internal/src/GHC/Internal/Stack/CCS.hsc
=====================================
@@ -16,14 +16,17 @@
 -----------------------------------------------------------------------------
 
 {-# LANGUAGE UnboxedTuples, MagicHash, NoImplicitPrelude #-}
+{-# LANGUAGE DerivingStrategies, GeneralizedNewtypeDeriving #-}
 module GHC.Internal.Stack.CCS (
     -- * Call stacks
     currentCallStack,
+    currentCallStackIds,
     whoCreated,
 
     -- * Internals
     CostCentreStack,
     CostCentre,
+    CostCentreId,
     getCurrentCCS,
     getCCSOf,
     clearCCS,
@@ -31,7 +34,9 @@ module GHC.Internal.Stack.CCS (
     ccsParent,
     ccLabel,
     ccModule,
+    ccId,
     ccSrcSpan,
+    ccsToIds,
     ccsToStrings,
     renderStack,
   ) where
@@ -44,6 +49,12 @@ import GHC.Internal.Base
 import GHC.Internal.Ptr
 import GHC.Internal.IO.Encoding
 import GHC.Internal.List ( concatMap, reverse )
+import GHC.Internal.Word ( Word32 )
+import GHC.Internal.Show
+import GHC.Internal.Read
+import GHC.Internal.Enum
+import GHC.Internal.Real
+import GHC.Internal.Num
 
 #define PROFILING
 #include "Rts.h"
@@ -54,6 +65,13 @@ data CostCentreStack
 -- | A cost-centre from GHC's cost-center profiler.
 data CostCentre
 
+-- | Cost centre identifier
+--
+-- @since 4.20.0.0
+newtype CostCentreId = CostCentreId Word32
+  deriving (Show, Read)
+  deriving newtype (Eq, Ord, Bounded, Enum, Integral, Num, Real)
+
 -- | Returns the current 'CostCentreStack' (value is @nullPtr@ if the current
 -- program was not compiled with profiling support). Takes a dummy argument
 -- which can be used to avoid the call to @getCurrentCCS@ being floated out by
@@ -83,6 +101,12 @@ ccsCC p = peekByteOff p 4
 ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
 ccsParent p = peekByteOff p 8
 
+-- | Get the 'CostCentreId' of a 'CostCentre'.
+--
+-- @since 4.20.0.0
+ccId :: Ptr CostCentre -> IO CostCentreId
+ccId p = fmap CostCentreId $ peekByteOff p 0
+
 ccLabel :: Ptr CostCentre -> IO CString
 ccLabel p = peekByteOff p 4
 
@@ -99,6 +123,12 @@ ccsCC p = (# peek CostCentreStack, cc) p
 ccsParent :: Ptr CostCentreStack -> IO (Ptr CostCentreStack)
 ccsParent p = (# peek CostCentreStack, prevStack) p
 
+-- | Get the 'CostCentreId' of a 'CostCentre'.
+--
+-- @since 4.20.0.0
+ccId :: Ptr CostCentre -> IO CostCentreId
+ccId p = fmap CostCentreId $ (# peek CostCentre, ccID) p
+
 -- | Get the label of a 'CostCentre'.
 ccLabel :: Ptr CostCentre -> IO CString
 ccLabel p = (# peek CostCentre, label) p
@@ -125,6 +155,19 @@ ccSrcSpan p = (# peek CostCentre, srcloc) p
 currentCallStack :: IO [String]
 currentCallStack = ccsToStrings =<< getCurrentCCS ()
 
+-- | Returns a @[CostCentreId]@ representing the current call stack.  This
+-- can be useful for debugging.
+--
+-- The implementation uses the call-stack simulation maintained by the
+-- profiler, so it only works if the program was compiled with @-prof@
+-- and contains suitable SCC annotations (e.g. by using @-fprof-late@).
+-- Otherwise, the list returned is likely to be empty or
+-- uninformative.
+--
+-- @since 4.20.0.0
+currentCallStackIds :: IO [CostCentreId]
+currentCallStackIds = ccsToIds =<< getCurrentCCS ()
+
 -- | Format a 'CostCentreStack' as a list of lines.
 ccsToStrings :: Ptr CostCentreStack -> IO [String]
 ccsToStrings ccs0 = go ccs0 []
@@ -141,6 +184,24 @@ ccsToStrings ccs0 = go ccs0 []
            then return acc
            else go parent ((mdl ++ '.':lbl ++ ' ':'(':loc ++ ")") : acc)
 
+-- | Format a 'CostCentreStack' as a list of cost centre IDs.
+--
+-- @since 4.20.0.0
+ccsToIds :: Ptr CostCentreStack -> IO [CostCentreId]
+ccsToIds ccs0 = go ccs0 []
+  where
+    go ccs acc
+     | ccs == nullPtr = return acc
+     | otherwise = do
+        cc <- ccsCC ccs
+        cc_id <- ccId cc
+        lbl <- GHC.peekCString utf8 =<< ccLabel cc
+        mdl <- GHC.peekCString utf8 =<< ccModule cc
+        parent <- ccsParent ccs
+        if (mdl == "MAIN" && lbl == "MAIN")
+           then return acc
+           else go parent (cc_id : acc)
+
 -- | Get the stack trace attached to an object.
 --
 -- @since base-4.5.0.0


=====================================
testsuite/driver/testlib.py
=====================================
@@ -1542,7 +1542,13 @@ def override_options(pre_cmd):
 
 def framework_fail(name: Optional[TestName], way: Optional[WayName], reason: str) -> None:
     opts = getTestOpts()
-    directory = re.sub(r'^\.[/\\]', '', str(opts.testdir))
+    # framework_fail can be called before testdir is initialised,
+    # so we need to take care not to blow up with the wrong way
+    # and report the actual reason for the failure.
+    try:
+      directory = re.sub(r'^\.[/\\]', '', str(opts.testdir))
+    except:
+      directory = ''
     full_name = '%s(%s)' % (name, way)
     if_verbose(1, '*** framework failure for %s %s ' % (full_name, reason))
     name2 = name if name is not None else TestName('none')


=====================================
testsuite/tests/printer/DataDeclShort.hs
=====================================
@@ -0,0 +1,8 @@
+module DataDeclShort where
+
+data GenericOptions
+  :: fieldLabelModifier
+  -> tagSingleConstructors
+  -> Type
+
+x = 1


=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -836,3 +836,8 @@ CaseAltComments:
 MatchPatComments:
 	$(CHECK_PPR)   $(LIBDIR) MatchPatComments.hs
 	$(CHECK_EXACT) $(LIBDIR) MatchPatComments.hs
+
+.PHONY: DataDeclShort
+DataDeclShort:
+	$(CHECK_PPR)   $(LIBDIR) DataDeclShort.hs
+	$(CHECK_EXACT) $(LIBDIR) DataDeclShort.hs


=====================================
testsuite/tests/printer/all.T
=====================================
@@ -200,3 +200,4 @@ test('Test24533', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24533'])
 test('PprLetIn', [ignore_stderr, req_ppr_deps], makefile_test, ['PprLetIn'])
 test('CaseAltComments', [ignore_stderr, req_ppr_deps], makefile_test, ['CaseAltComments'])
 test('MatchPatComments', [ignore_stderr, req_ppr_deps], makefile_test, ['MatchPatComments'])
+test('DataDeclShort', [ignore_stderr, req_ppr_deps], makefile_test, ['DataDeclShort'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67244b0c5ff1b0d2899c99858e13ec07364255f7...807da9090b0446c11d548856ae20963ee844b685

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/67244b0c5ff1b0d2899c99858e13ec07364255f7...807da9090b0446c11d548856ae20963ee844b685
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/20240501/132afcb5/attachment-0001.html>


More information about the ghc-commits mailing list