[Git][ghc/ghc][wip/T24504] 4 commits: Add test cases for #24664

Serge S. Gulin (@gulin.serge) gitlab at gitlab.haskell.org
Tue May 7 09:45:22 UTC 2024



Serge S. Gulin pushed to branch wip/T24504 at Glasgow Haskell Compiler / GHC


Commits:
a19201d4 by Matthew Craven at 2024-05-06T19:54:29-04:00
Add test cases for #24664

...since none are present in the original MR !12463 fixing this issue.

- - - - -
46328a49 by Alan Zimmerman at 2024-05-06T19:55:05-04:00
EPA: preserve comments in data decls

Closes #24771

- - - - -
c301d80a by Ben Gamari at 2024-05-07T12:44:54+03:00
IPE: Eliminate dependency on Read

Instead of encoding the closure type as decimal string we now simply
represent it as an integer, eliminating the need for `Read` in
`GHC.Internal.InfoProv.Types.peekInfoProv`.

Closes #24504.

-------------------------
Metric Decrease:
    T24602_perf_size
    size_hello_artifact
-------------------------

- - - - -
1e9948e3 by Serge S. Gulin at 2024-05-07T12:44:54+03:00
IPE: WIP: Replace closure_desc string representation in logs output on Word64

- - - - -


17 changed files:

- compiler/GHC/Parser.y
- compiler/GHC/Parser/PostProcess.hs
- compiler/GHC/StgToCmm/InfoTableProv.hs
- libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc
- rts/IPE.c
- rts/Trace.c
- rts/eventlog/EventLog.c
- rts/include/rts/IPE.h
- + testsuite/tests/codeGen/should_run/T24664a.hs
- + testsuite/tests/codeGen/should_run/T24664a.stdout
- + testsuite/tests/codeGen/should_run/T24664b.hs
- + testsuite/tests/codeGen/should_run/T24664b.stdout
- testsuite/tests/codeGen/should_run/all.T
- testsuite/tests/printer/Makefile
- testsuite/tests/printer/Test24755.hs
- + testsuite/tests/printer/Test24771.hs
- testsuite/tests/printer/all.T


Changes:

=====================================
compiler/GHC/Parser.y
=====================================
@@ -2486,9 +2486,8 @@ forall :: { Located ([AddEpAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) }
         | {- empty -}                 { noLoc ([], Nothing) }
 
 constr_stuff :: { Located (LocatedN RdrName, HsConDeclH98Details GhcPs) }
-        : infixtype       {% fmap (reLoc. (fmap (\b -> (dataConBuilderCon b,
-                                                        dataConBuilderDetails b))))
-                                  (runPV $1) }
+        : infixtype       {% do { b <- runPV $1
+                                ; return (sL1 b (dataConBuilderCon b, dataConBuilderDetails b)) }}
         | '(#' usum_constr '#)' {% let (t, tag, arity) = $2 in pure (sLL $1 $3 $ mkUnboxedSumCon t tag arity)}
 
 usum_constr :: { (LHsType GhcPs, Int, Int) } -- constructor for the data decls SumN#


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -236,7 +236,8 @@ mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
        ; let anns' = annsIn Semi.<> ann
        ; data_cons <- checkNewOrData loc' (unLoc tc) is_type_data new_or_data data_cons
        ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
-       ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
+       ; !cs' <- getCommentsFor loc'
+       ; let loc = EpAnn (spanAsAnchor loc') noAnn (cs' Semi.<> cs)
        ; return (L loc (DataDecl { tcdDExt = anns',
                                    tcdLName = tc, tcdTyVars = tyvars,
                                    tcdFixity = fixity,
@@ -2065,25 +2066,26 @@ instance DisambTD (HsType GhcPs) where
     return (L (addCommentsToEpAnn l cs) ty)
   mkUnpackednessPV = addUnpackednessP
 
-dataConBuilderCon :: DataConBuilder -> LocatedN RdrName
-dataConBuilderCon (PrefixDataConBuilder _ dc) = dc
-dataConBuilderCon (InfixDataConBuilder _ dc _) = dc
+dataConBuilderCon :: LocatedA DataConBuilder -> LocatedN RdrName
+dataConBuilderCon (L _ (PrefixDataConBuilder _ dc)) = dc
+dataConBuilderCon (L _ (InfixDataConBuilder _ dc _)) = dc
 
-dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs
+dataConBuilderDetails :: LocatedA DataConBuilder -> HsConDeclH98Details GhcPs
 
 -- Detect when the record syntax is used:
 --   data T = MkT { ... }
-dataConBuilderDetails (PrefixDataConBuilder flds _)
+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
   | [L (EpAnn anc _ cs) (HsRecTy an fields)] <- toList flds
   = RecCon (L (EpAnn anc an cs) fields)
 
 -- Normal prefix constructor, e.g.  data T = MkT A B C
-dataConBuilderDetails (PrefixDataConBuilder flds _)
+dataConBuilderDetails (L _ (PrefixDataConBuilder flds _))
   = PrefixCon noTypeArgs (map hsLinear (toList flds))
 
 -- Infix constructor, e.g. data T = Int :! Bool
-dataConBuilderDetails (InfixDataConBuilder lhs _ rhs)
-  = InfixCon (hsLinear lhs) (hsLinear rhs)
+dataConBuilderDetails (L (EpAnn _ _ csl) (InfixDataConBuilder (L (EpAnn anc ann csll) lhs) _ rhs))
+  = InfixCon (hsLinear (L (EpAnn anc ann (csl Semi.<> csll)) lhs)) (hsLinear rhs)
+
 
 instance DisambTD DataConBuilder where
   mkHsAppTyHeadPV = tyToDataConBuilder


=====================================
compiler/GHC/StgToCmm/InfoTableProv.hs
=====================================
@@ -178,7 +178,7 @@ toIpeBufferEntries byte_order cg_ipes =
     to_ipe_buf_ent :: CgInfoProvEnt -> [Word32]
     to_ipe_buf_ent cg_ipe =
       [ ipeTableName cg_ipe
-      , ipeClosureDesc cg_ipe
+      , fromIntegral $ ipeClosureDesc cg_ipe
       , ipeTypeDesc cg_ipe
       , ipeLabel cg_ipe
       , ipeSrcFile cg_ipe
@@ -193,7 +193,6 @@ toIpeBufferEntries byte_order cg_ipes =
 toCgIPE :: Platform -> SDocContext -> InfoProvEnt -> State StringTable CgInfoProvEnt
 toCgIPE platform ctx ipe = do
     table_name <- lookupStringTable $ ST.pack $ renderWithContext ctx (pprCLabel platform (infoTablePtr ipe))
-    closure_desc <- lookupStringTable $ ST.pack $ show (infoProvEntClosureType ipe)
     type_desc <- lookupStringTable $ ST.pack $ infoTableType ipe
     let label_str = maybe "" ((\(LexicalFastString s) -> unpackFS s) . snd) (infoTableProv ipe)
     let (src_loc_file, src_loc_span) =
@@ -208,7 +207,7 @@ toCgIPE platform ctx ipe = do
     src_span <- lookupStringTable $ ST.pack src_loc_span
     return $ CgInfoProvEnt { ipeInfoTablePtr = infoTablePtr ipe
                            , ipeTableName = table_name
-                           , ipeClosureDesc = closure_desc
+                           , ipeClosureDesc = fromIntegral (infoProvEntClosureType ipe)
                            , ipeTypeDesc = type_desc
                            , ipeLabel = label
                            , ipeSrcFile = src_file
@@ -218,7 +217,7 @@ toCgIPE platform ctx ipe = do
 data CgInfoProvEnt = CgInfoProvEnt
                                { ipeInfoTablePtr :: !CLabel
                                , ipeTableName :: !StrTabOffset
-                               , ipeClosureDesc :: !StrTabOffset
+                               , ipeClosureDesc :: !Word32
                                , ipeTypeDesc :: !StrTabOffset
                                , ipeLabel :: !StrTabOffset
                                , ipeSrcFile :: !StrTabOffset


=====================================
libraries/ghc-internal/src/GHC/Internal/InfoProv/Types.hsc
=====================================
@@ -18,8 +18,9 @@ module GHC.Internal.InfoProv.Types
     ) where
 
 import GHC.Internal.Base
-import GHC.Internal.Data.Maybe
 import GHC.Internal.Enum
+import GHC.Internal.Real (fromIntegral)
+import GHC.Internal.Word (Word32)
 import GHC.Internal.Show (Show)
 import GHC.Internal.Ptr (Ptr(..), plusPtr)
 import GHC.Internal.Foreign.C.String.Encoding (CString, peekCString)
@@ -28,7 +29,6 @@ import GHC.Internal.Foreign.Marshal.Alloc (allocaBytes)
 import GHC.Internal.IO.Encoding (utf8)
 import GHC.Internal.Foreign.Storable (peekByteOff)
 import GHC.Internal.ClosureTypes
-import GHC.Internal.Text.Read
 import GHC.Prim (whereFrom##)
 
 data InfoProv = InfoProv {
@@ -70,9 +70,11 @@ getIPE obj fail k = allocaBytes (#size InfoProvEnt) $ \p -> IO $ \s ->
 ipeProv :: Ptr InfoProvEnt -> Ptr InfoProv
 ipeProv p = (#ptr InfoProvEnt, prov) p
 
-peekIpName, peekIpDesc, peekIpLabel, peekIpUnitId, peekIpModule, peekIpSrcFile, peekIpSrcSpan, peekIpTyDesc :: Ptr InfoProv -> IO CString
-peekIpName p    =  (# peek InfoProv, table_name) p
+peekIpDesc :: Ptr InfoProv -> IO Word32
 peekIpDesc p    =  (# peek InfoProv, closure_desc) p
+
+peekIpName, peekIpLabel, peekIpUnitId, peekIpModule, peekIpSrcFile, peekIpSrcSpan, peekIpTyDesc :: Ptr InfoProv -> IO CString
+peekIpName p    =  (# peek InfoProv, table_name) p
 peekIpLabel p   =  (# peek InfoProv, label) p
 peekIpUnitId p  =  (# peek InfoProv, unit_id) p
 peekIpModule p  =  (# peek InfoProv, module) p
@@ -83,7 +85,7 @@ peekIpTyDesc p  =  (# peek InfoProv, ty_desc) p
 peekInfoProv :: Ptr InfoProv -> IO InfoProv
 peekInfoProv infop = do
   name <- peekCString utf8 =<< peekIpName infop
-  desc <- peekCString utf8 =<< peekIpDesc infop
+  desc <- peekIpDesc infop
   tyDesc <- peekCString utf8 =<< peekIpTyDesc infop
   label <- peekCString utf8 =<< peekIpLabel infop
   unit_id <- peekCString utf8 =<< peekIpUnitId infop
@@ -94,7 +96,7 @@ peekInfoProv infop = do
       ipName = name,
       -- The INVALID_OBJECT case should be impossible as we
       -- control the C code generating these values.
-      ipDesc = maybe INVALID_OBJECT toEnum . readMaybe @Int $ desc,
+      ipDesc = toEnum $ fromIntegral desc,
       ipTyDesc = tyDesc,
       ipLabel = label,
       ipUnitId = unit_id,


=====================================
rts/IPE.c
=====================================
@@ -105,7 +105,7 @@ static InfoProvEnt ipeBufferEntryToIpe(const IpeBufferListNode *node, uint32_t i
             .info = node->tables[idx],
             .prov = {
                 .table_name = &strings[ent->table_name],
-                .closure_desc = &strings[ent->closure_desc],
+                .closure_desc = ent->closure_desc,
                 .ty_desc = &strings[ent->ty_desc],
                 .label = &strings[ent->label],
                 .unit_id = &strings[node->unit_id],


=====================================
rts/Trace.c
=====================================
@@ -689,7 +689,7 @@ void traceIPE(const InfoProvEnt *ipe)
         ACQUIRE_LOCK(&trace_utx);
 
         tracePreface();
-        debugBelch("IPE: table_name %s, closure_desc %s, ty_desc %s, label %s, unit %s, module %s, srcloc %s:%s\n",
+        debugBelch("IPE: table_name %s, closure_desc %d, ty_desc %s, label %s, unit %s, module %s, srcloc %s:%s\n",
                    ipe->prov.table_name, ipe->prov.closure_desc, ipe->prov.ty_desc,
                    ipe->prov.label, ipe->prov.unit_id, ipe->prov.module,
                    ipe->prov.src_file, ipe->prov.src_span);


=====================================
rts/eventlog/EventLog.c
=====================================
@@ -1445,7 +1445,6 @@ void postIPE(const InfoProvEnt *ipe)
     const StgWord MAX_IPE_STRING_LEN = 65535;
     ACQUIRE_LOCK(&eventBufMutex);
     StgWord table_name_len = MIN(strlen(ipe->prov.table_name), MAX_IPE_STRING_LEN);
-    StgWord closure_desc_len = MIN(strlen(ipe->prov.closure_desc), MAX_IPE_STRING_LEN);
     StgWord ty_desc_len = MIN(strlen(ipe->prov.ty_desc), MAX_IPE_STRING_LEN);
     StgWord label_len = MIN(strlen(ipe->prov.label), MAX_IPE_STRING_LEN);
     StgWord module_len = MIN(strlen(ipe->prov.module), MAX_IPE_STRING_LEN);
@@ -1455,14 +1454,15 @@ void postIPE(const InfoProvEnt *ipe)
     // 8 for the info word
     // 1 null after each string
     // 1 colon between src_file and src_span
+    // 8 for the closure_desc
     StgWord extra_comma = 1;
-    StgWord len = 8+table_name_len+1+closure_desc_len+1+ty_desc_len+1+label_len+1+module_len+1+src_file_len+1+extra_comma+src_span_len+1;
+    StgWord len = 8+table_name_len+1+8+1+ty_desc_len+1+label_len+1+module_len+1+src_file_len+1+extra_comma+src_span_len+1;
     CHECK(!ensureRoomForVariableEvent(&eventBuf, len));
     postEventHeader(&eventBuf, EVENT_IPE);
     postPayloadSize(&eventBuf, len);
     postWord64(&eventBuf, (StgWord) INFO_PTR_TO_STRUCT(ipe->info));
     postStringLen(&eventBuf, ipe->prov.table_name, table_name_len);
-    postStringLen(&eventBuf, ipe->prov.closure_desc, closure_desc_len);
+    postWord64(&eventBuf, ipe->prov.closure_desc);
     postStringLen(&eventBuf, ipe->prov.ty_desc, ty_desc_len);
     postStringLen(&eventBuf, ipe->prov.label, label_len);
     postStringLen(&eventBuf, ipe->prov.module, module_len);


=====================================
rts/include/rts/IPE.h
=====================================
@@ -15,7 +15,7 @@
 
 typedef struct InfoProv_ {
     const char *table_name;
-    const char *closure_desc;
+    uint32_t closure_desc; // closure type
     const char *ty_desc;
     const char *label;
     const char *unit_id;
@@ -54,7 +54,7 @@ typedef uint32_t StringIdx;
 // to ensure correct packing.
 typedef struct {
     StringIdx table_name;
-    StringIdx closure_desc;
+    uint32_t closure_desc; // closure type
     StringIdx ty_desc;
     StringIdx label;
     StringIdx src_file;


=====================================
testsuite/tests/codeGen/should_run/T24664a.hs
=====================================
@@ -0,0 +1,27 @@
+-- This program tests the passing of RUBBISH values
+-- with the Int64 representation, which were found
+-- to by mis-handled by the JS backend in #24664.
+
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts (Int64#, intToInt64#)
+
+takesInt64a :: String -> Int64# -> String -> IO ()
+{-# OPAQUE takesInt64a #-}
+-- Idea: This function takes an Int64# but doesn't use it,
+-- so that its argument might be turned into a rubbish literal.
+-- We don't want WW to remove the argument entirely, so OPAQUE
+takesInt64a str1 _ str2 = putStrLn str1 >> putStrLn str2
+
+takesInt64b :: Int64# -> IO ()
+{-# NOINLINE takesInt64b #-}
+-- Idea: This function will get a worker that doesn't take an
+-- Int64# at all, and the body of that worker will pass a
+-- rubbish literal to takesInt64a since no real arg exists.
+takesInt64b x = takesInt64a "first string to print" x "second string to print"
+
+main :: IO ()
+main = do
+  takesInt64b (intToInt64# 12345#)


=====================================
testsuite/tests/codeGen/should_run/T24664a.stdout
=====================================
@@ -0,0 +1,2 @@
+first string to print
+second string to print


=====================================
testsuite/tests/codeGen/should_run/T24664b.hs
=====================================
@@ -0,0 +1,31 @@
+-- This is a variant of T24664a that could reproduce
+-- the compiler crash originally observed in #24664.
+
+{-# LANGUAGE MagicHash #-}
+
+module Main where
+
+import GHC.Exts (Int64#, intToInt64#, uncheckedIShiftRL64#)
+
+takesInt64a :: String -> Int64# -> String -> IO ()
+{-# OPAQUE takesInt64a #-}
+-- Idea: This function takes an Int64# but doesn't use it,
+-- so that its argument might be turned into a rubbish literal.
+-- We don't want WW to remove the argument entirely, so OPAQUE
+takesInt64a str1 _ str2 = putStrLn str1 >> putStrLn str2
+
+takesInt64b :: String -> Int64# -> String -> IO ()
+{-# NOINLINE takesInt64b #-}
+-- Idea: This function will get a worker that doesn't take an
+-- Int64# at all, and the body of that worker will pass a
+-- rubbish literal to takesInt64a since no real arg exists.
+takesInt64b s1 x s2
+  = takesInt64a (s1 ++ t) (x `uncheckedIShiftRL64#` 13#) (s2 ++ t)
+  where t = " string to print"
+
+takesInt64c :: Int64# -> IO ()
+takesInt64c x = takesInt64b "first" x "second"
+
+main :: IO ()
+main = do
+  takesInt64c (intToInt64# 12345#)


=====================================
testsuite/tests/codeGen/should_run/T24664b.stdout
=====================================
@@ -0,0 +1,2 @@
+first string to print
+second string to print


=====================================
testsuite/tests/codeGen/should_run/all.T
=====================================
@@ -243,3 +243,6 @@ test('MulMayOflo_full',
 test('T24264run', normal, compile_and_run, [''])
 test('T24295a', normal, compile_and_run, ['-O -floopification'])
 test('T24295b', normal, compile_and_run, ['-O -floopification -fpedantic-bottoms'])
+test('T24664a', normal, compile_and_run, ['-O'])
+test('T24664b', normal, compile_and_run, ['-O'])
+


=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -866,3 +866,8 @@ Test24755:
 Test24753:
 	$(CHECK_PPR)   $(LIBDIR) Test24753.hs
 	$(CHECK_EXACT) $(LIBDIR) Test24753.hs
+
+.PHONY: Test24771
+Test24771:
+	$(CHECK_PPR)   $(LIBDIR) Test24771.hs
+	$(CHECK_EXACT) $(LIBDIR) Test24771.hs


=====================================
testsuite/tests/printer/Test24755.hs
=====================================
@@ -3,6 +3,6 @@
 module Test24755 where
 
 class
-    a -- Before operator
-    :+
-    b -- After operator
+    a  -- c1
+    :+ -- c2
+    b  -- c3


=====================================
testsuite/tests/printer/Test24771.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24771 where
+
+data Foo
+  =  Int     -- c1
+       :*    -- c2
+     String  -- c3


=====================================
testsuite/tests/printer/all.T
=====================================
@@ -206,3 +206,4 @@ test('Test24749', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24749'])
 test('Test24754', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24754'])
 test('Test24755', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24755'])
 test('Test24753', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24753'])
+test('Test24771', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24771'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b7db94bb5ffe0ff2425117418eba89342037789...1e9948e386cdb423ba8bbf535bb30302dc203299

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7b7db94bb5ffe0ff2425117418eba89342037789...1e9948e386cdb423ba8bbf535bb30302dc203299
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/20240507/27f16417/attachment-0001.html>


More information about the ghc-commits mailing list