[Git][ghc/ghc][wip/marge_bot_batch_merge_job] 4 commits: Fix parsing of module names in CLI arguments

Marge Bot (@marge-bot) gitlab at gitlab.haskell.org
Sun May 5 11:32:45 UTC 2024



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


Commits:
af000532 by Moritz Schuler at 2024-05-05T06:30:58-04:00
Fix parsing of module names in CLI arguments
  closes issue #24732

- - - - -
da74e9c9 by Ben Gamari at 2024-05-05T06:31:34-04:00
ghc-platform: Add Setup.hs

The Hadrian bootstrapping script relies upon `Setup.hs` to drive its
build.

Addresses #24761.

- - - - -
48394a57 by Alan Zimmerman at 2024-05-05T07:32:32-04:00
EPA: preserve comments in class and data decls

Fix checkTyClHdr which was discarding comments.

Closes #24755

- - - - -
5a02a27c by Simon Peyton Jones at 2024-05-05T07:32:32-04:00
Fix a float-out error

Ticket #24768 showed that the Simplifier was accidentally destroying
a join point.  It turned out to be that we were sending a bottoming
join point to the top, accidentally abstracting over /other/ join
points.

Easily fixed.

- - - - -


12 changed files:

- compiler/GHC/Core/Opt/SetLevels.hs
- compiler/GHC/Parser/PostProcess.hs
- compiler/Language/Haskell/Syntax/Module/Name.hs
- + libraries/ghc-platform/Setup.hs
- testsuite/tests/printer/Makefile
- + testsuite/tests/printer/Test24755.hs
- testsuite/tests/printer/all.T
- + testsuite/tests/rename/should_compile/T24732.hs
- + testsuite/tests/rename/should_compile/T24732.stdout
- testsuite/tests/rename/should_compile/all.T
- + testsuite/tests/simplCore/should_compile/T24768.hs
- testsuite/tests/simplCore/should_compile/all.T


Changes:

=====================================
compiler/GHC/Core/Opt/SetLevels.hs
=====================================
@@ -1088,6 +1088,11 @@ But, as ever, we need to be careful:
     as /another/ MFE, so we tell lvlFloatRhs not to do that, via the is_bot
     argument.
 
+    Do /not/ do this for bottoming /join-point/ bindings.   They may call other
+    join points (#24768), and floating to the top would abstract over those join
+    points, which we should never do.
+
+
 See Maessen's paper 1999 "Bottom extraction: factoring error handling out
 of functional programs" (unpublished I think).
 
@@ -1252,9 +1257,11 @@ lvlBind env (AnnNonRec bndr rhs)
 
     deann_rhs  = deAnnotate rhs
     mb_bot_str = exprBotStrictness_maybe deann_rhs
-    is_bot_lam = isJust mb_bot_str
+    is_bot_lam = not is_join && isJust mb_bot_str
         -- is_bot_lam: looks like (\xy. bot), maybe zero lams
-        -- NB: not isBottomThunk!  See Note [Bottoming floats] point (3)
+        -- NB: not isBottomThunk!
+        -- NB: not is_join: don't send bottoming join points to the top.
+        -- See Note [Bottoming floats] point (3)
 
     is_top_bindable = exprIsTopLevelBindable deann_rhs bndr_ty
     n_extra       = count isId abs_vars


=====================================
compiler/GHC/Parser/PostProcess.hs
=====================================
@@ -204,11 +204,11 @@ mkClassDecl :: SrcSpan
             -> P (LTyClDecl GhcPs)
 
 mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layout annsIn
-  = do { let loc = noAnnSrcSpan loc'
-       ; (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
-       ; (cls, tparams, fixity, ann) <- checkTyClHdr True tycl_hdr
+  = do { (binds, sigs, ats, at_defs, _, docs) <- cvBindsAndSigs where_cls
+       ; (cls, tparams, fixity, ann, cs) <- checkTyClHdr True tycl_hdr
        ; tyvars <- checkTyVars (text "class") whereDots cls tparams
        ; let anns' = annsIn Semi.<> ann
+       ; let loc = EpAnn (spanAsAnchor loc') noAnn cs
        ; return (L loc (ClassDecl { tcdCExt = (anns', layout, NoAnnSortKey)
                                   , tcdCtxt = mcxt
                                   , tcdLName = cls, tcdTyVars = tyvars
@@ -231,12 +231,12 @@ mkTyData :: SrcSpan
          -> P (LTyClDecl GhcPs)
 mkTyData loc' is_type_data new_or_data cType (L _ (mcxt, tycl_hdr))
          ksig data_cons (L _ maybe_deriv) annsIn
-  = do { let loc = noAnnSrcSpan loc'
-       ; (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
        ; tyvars <- checkTyVars (ppr new_or_data) equalsDots tc tparams
        ; let anns' = annsIn Semi.<> ann
-       ; data_cons <- checkNewOrData (locA loc) (unLoc tc) is_type_data new_or_data data_cons
+       ; 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
        ; return (L loc (DataDecl { tcdDExt = anns',
                                    tcdLName = tc, tcdTyVars = tyvars,
                                    tcdFixity = fixity,
@@ -263,14 +263,14 @@ mkTySynonym :: SrcSpan
             -> [AddEpAnn]
             -> P (LTyClDecl GhcPs)
 mkTySynonym loc lhs rhs annsIn
-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
        ; tyvars <- checkTyVars (text "type") equalsDots tc tparams
        ; let anns' = annsIn Semi.<> ann
-       ; return (L (noAnnSrcSpan loc) (SynDecl
-                                { tcdSExt = anns'
-                                , tcdLName = tc, tcdTyVars = tyvars
-                                , tcdFixity = fixity
-                                , tcdRhs = rhs })) }
+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+       ; return (L loc' (SynDecl { tcdSExt = anns'
+                                 , tcdLName = tc, tcdTyVars = tyvars
+                                 , tcdFixity = fixity
+                                 , tcdRhs = rhs })) }
 
 mkStandaloneKindSig
   :: SrcSpan
@@ -303,8 +303,9 @@ mkTyFamInstEqn :: SrcSpan
                -> [AddEpAnn]
                -> P (LTyFamInstEqn GhcPs)
 mkTyFamInstEqn loc bndrs lhs rhs anns
-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
-       ; return (L (noAnnSrcSpan loc) $ FamEqn
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+       ; return (L loc' $ FamEqn
                         { feqn_ext    = anns `mappend` ann
                         , feqn_tycon  = tc
                         , feqn_bndrs  = bndrs
@@ -324,10 +325,11 @@ mkDataFamInst :: SrcSpan
               -> P (LInstDecl GhcPs)
 mkDataFamInst loc new_or_data cType (mcxt, bndrs, tycl_hdr)
               ksig data_cons (L _ maybe_deriv) anns
-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False tycl_hdr
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False tycl_hdr
        ; data_cons <- checkNewOrData loc (unLoc tc) False new_or_data data_cons
        ; defn <- mkDataDefn cType mcxt ksig data_cons maybe_deriv
-       ; return (L (noAnnSrcSpan loc) (DataFamInstD noExtField (DataFamInstDecl
+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+       ; return (L loc' (DataFamInstD noExtField (DataFamInstDecl
                   (FamEqn { feqn_ext    = ann Semi.<> anns
                           , feqn_tycon  = tc
                           , feqn_bndrs  = bndrs
@@ -368,10 +370,10 @@ mkFamDecl :: SrcSpan
           -> [AddEpAnn]
           -> P (LTyClDecl GhcPs)
 mkFamDecl loc info topLevel lhs ksig injAnn annsIn
-  = do { (tc, tparams, fixity, ann) <- checkTyClHdr False lhs
+  = do { (tc, tparams, fixity, ann, cs) <- checkTyClHdr False lhs
        ; tyvars <- checkTyVars (ppr info) equals_or_where tc tparams
-       ; return (L (noAnnSrcSpan loc) (FamDecl noExtField
-                                         (FamilyDecl
+       ; let loc' = EpAnn (spanAsAnchor loc) noAnn cs
+       ; return (L loc' (FamDecl noExtField (FamilyDecl
                                            { fdExt       = annsIn Semi.<> ann
                                            , fdTopLevel  = topLevel
                                            , fdInfo      = info, fdLName = tc
@@ -1040,45 +1042,46 @@ checkTyClHdr :: Bool               -- True  <=> class header
              -> P (LocatedN RdrName,     -- the head symbol (type or class name)
                    [LHsTypeArg GhcPs],   -- parameters of head symbol
                    LexicalFixity,        -- the declaration is in infix format
-                   [AddEpAnn])           -- API Annotation for HsParTy
+                   [AddEpAnn],           -- API Annotation for HsParTy
                                          -- when stripping parens
+                   EpAnnComments)        -- Accumulated comments from re-arranging
 -- Well-formedness check and decomposition of type and class heads.
 -- Decomposes   T ty1 .. tyn   into    (T, [ty1, ..., tyn])
 --              Int :*: Bool   into    (:*:, [Int, Bool])
 -- returning the pieces
 checkTyClHdr is_cls ty
-  = goL ty [] [] [] Prefix
+  = goL emptyComments ty [] [] [] Prefix
   where
-    goL (L l ty) acc ops cps fix = go l ty acc ops cps fix
+    goL cs (L l ty) acc ops cps fix = go cs l ty acc ops cps fix
 
     -- workaround to define '*' despite StarIsType
-    go ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
+    go cs ll (HsParTy an (L l (HsStarTy _ isUni))) acc ops' cps' fix
       = do { addPsMessage (locA l) PsWarnStarBinder
            ; let name = mkOccNameFS tcClsName (starSym isUni)
            ; let a' = newAnns ll l an
            ; return (L a' (Unqual name), acc, fix
-                    , (reverse ops') ++ cps') }
+                    , (reverse ops') ++ cps', cs) }
 
-    go _ (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
-      | isRdrTc tc               = return (ltc, acc, fix, (reverse ops) ++ cps)
-    go _ (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
-      | isRdrTc tc               = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps)
+    go cs l (HsTyVar _ _ ltc@(L _ tc)) acc ops cps fix
+      | isRdrTc tc               = return (ltc, acc, fix, (reverse ops) ++ cps, cs Semi.<> comments l)
+    go cs l (HsOpTy _ _ t1 ltc@(L _ tc) t2) acc ops cps _fix
+      | isRdrTc tc               = return (ltc, lhs:rhs:acc, Infix, (reverse ops) ++ cps, cs Semi.<> comments l)
       where lhs = HsValArg noExtField t1
             rhs = HsValArg noExtField t2
-    go l (HsParTy _ ty)    acc ops cps fix = goL ty acc (o:ops) (c:cps) fix
+    go cs l (HsParTy _ ty)    acc ops cps fix = goL (cs Semi.<> comments l) ty acc (o:ops) (c:cps) fix
       where
         (o,c) = mkParensEpAnn (realSrcSpan (locA l))
-    go _ (HsAppTy _ t1 t2) acc ops cps fix = goL t1 (HsValArg noExtField t2:acc) ops cps fix
-    go _ (HsAppKindTy at ty ki) acc ops cps fix = goL ty (HsTypeArg at ki:acc) ops cps fix
-    go l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
+    go cs l (HsAppTy _ t1 t2) acc ops cps fix = goL (cs Semi.<> comments l) t1 (HsValArg noExtField t2:acc) ops cps fix
+    go cs l (HsAppKindTy at ty ki) acc ops cps fix = goL (cs Semi.<> comments l) ty (HsTypeArg at ki:acc) ops cps fix
+    go cs l (HsTupleTy _ HsBoxedOrConstraintTuple ts) [] ops cps fix
       = return (L (l2l l) (nameRdrName tup_name)
-               , map (HsValArg noExtField) ts, fix, (reverse ops)++cps)
+               , map (HsValArg noExtField) ts, fix, (reverse ops)++cps, cs Semi.<> comments l)
       where
         arity = length ts
         tup_name | is_cls    = cTupleTyConName arity
                  | otherwise = getName (tupleTyCon Boxed arity)
           -- See Note [Unit tuples] in GHC.Hs.Type  (TODO: is this still relevant?)
-    go l _ _ _ _ _
+    go _ l _ _ _ _ _
       = addFatalError $ mkPlainErrorMsgEnvelope (locA l) $
           (PsErrMalformedTyOrClDecl ty)
 


=====================================
compiler/Language/Haskell/Syntax/Module/Name.hs
=====================================
@@ -56,5 +56,5 @@ moduleNameColons = dots_to_colons . moduleNameString
 
 parseModuleName :: Parse.ReadP ModuleName
 parseModuleName = fmap mkModuleName
-                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.")
+                $ Parse.munch1 (\c -> isAlphaNum c || c `elem` "_.'")
 


=====================================
libraries/ghc-platform/Setup.hs
=====================================
@@ -0,0 +1,6 @@
+module Main (main) where
+
+import Distribution.Simple
+
+main :: IO ()
+main = defaultMain


=====================================
testsuite/tests/printer/Makefile
=====================================
@@ -856,3 +856,8 @@ Test24749:
 Test24754:
 	$(CHECK_PPR)   $(LIBDIR) Test24754.hs
 	$(CHECK_EXACT) $(LIBDIR) Test24754.hs
+
+.PHONY: Test24755
+Test24755:
+	$(CHECK_PPR)   $(LIBDIR) Test24755.hs
+	$(CHECK_EXACT) $(LIBDIR) Test24755.hs


=====================================
testsuite/tests/printer/Test24755.hs
=====================================
@@ -0,0 +1,8 @@
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeOperators #-}
+module Test24755 where
+
+class
+    a -- Before operator
+    :+
+    b -- After operator


=====================================
testsuite/tests/printer/all.T
=====================================
@@ -204,3 +204,4 @@ test('Test24748', [ignore_stderr, req_ppr_deps], makefile_test, ['Test24748'])
 test('DataDeclShort', [ignore_stderr, req_ppr_deps], makefile_test, ['DataDeclShort'])
 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'])


=====================================
testsuite/tests/rename/should_compile/T24732.hs
=====================================
@@ -0,0 +1,4 @@
+import P'
+
+main :: IO ()
+main = printf "Hello World\n"
\ No newline at end of file


=====================================
testsuite/tests/rename/should_compile/T24732.stdout
=====================================
@@ -0,0 +1 @@
+Hello World


=====================================
testsuite/tests/rename/should_compile/all.T
=====================================
@@ -223,3 +223,4 @@ test('T22478a', req_th, compile, [''])
 test('RecordWildCardDeprecation', normal, multimod_compile, ['RecordWildCardDeprecation', '-Wno-duplicate-exports'])
 test('T14032b', normal, compile_and_run, [''])
 test('T14032d', normal, compile, [''])
+test('T24732', normal, compile_and_run, ['-package "base(Prelude, Text.Printf as P\')"'])


=====================================
testsuite/tests/simplCore/should_compile/T24768.hs
=====================================
@@ -0,0 +1,56 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TupleSections #-}
+{-# LANGUAGE TypeApplications #-}
+
+-- In this example the simplifer destroyed a join point,
+-- namely the `loop` inside `detectLeaks`
+
+module T24768 (detectLeaks) where
+
+import Control.Monad (zipWithM_)
+import Control.Monad.Reader (ReaderT(..))
+import Control.Monad.State (StateT, evalStateT)
+import qualified Data.Map as M
+import qualified Data.Set as S
+
+data Debuggee
+
+newtype DebugM a = DebugM (ReaderT Debuggee IO a)
+                    deriving (Functor, Applicative, Monad)
+
+runSimple :: Debuggee -> DebugM a -> IO a
+runSimple d (DebugM a) = runReaderT a d
+
+cands :: [a]
+cands = []
+{-# NOINLINE cands #-}
+
+detectLeaks :: Debuggee -> IO ()
+detectLeaks e = loop M.empty
+  where
+    loop :: M.Map () RankInfo -> IO ()
+    loop rm = do
+      gs <- runSimple e $ mapM (findSlice rm) cands
+      zipWithM_ (\n _g -> writeFile
+                            ("slices/" ++ show @Int n ++ ".dot")
+                            "abcd")
+                [0..] gs
+      loop rm
+
+data RankInfo = RankInfo !Double !Int
+
+lookupRM :: () -> M.Map () RankInfo -> [((), RankInfo)]
+lookupRM k m = M.assocs filtered_map
+  where
+    (res_map, _) = M.partitionWithKey (\e _ -> e == k) m
+    filtered_map = M.filter (\(RankInfo r _) -> r > 0) res_map
+
+findSlice :: forall m a. Monad m => M.Map () RankInfo -> () -> m [a]
+findSlice rm _k = evalStateT go S.empty
+  where
+    go :: StateT s m [a]
+    go = do
+      let next_edges = lookupRM () rm
+      _ss <- concat <$> mapM (\_ -> go) next_edges
+      return []


=====================================
testsuite/tests/simplCore/should_compile/all.T
=====================================
@@ -515,3 +515,4 @@ test('T24229b', [ grep_errmsg(r'wfoo') ], compile, ['-O2 -ddump-simpl -dno-typea
 test('T24370', normal, compile, ['-O'])
 test('T24551', normal, compile, ['-O -dcore-lint'])
 test('T24726', normal, compile, ['-dcore-lint -dsuppress-uniques'])
+test('T24768', normal, compile, ['-O'])



View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d772b1b152264ba82bcd73457e63f3bdae0e7e0...5a02a27cf93add1a80ec6404da928848bbae9fb4

-- 
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7d772b1b152264ba82bcd73457e63f3bdae0e7e0...5a02a27cf93add1a80ec6404da928848bbae9fb4
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/20240505/025dbc92/attachment-0001.html>


More information about the ghc-commits mailing list