Marge Bot pushed to branch wip/marge_bot_batch_merge_job at Glasgow Haskell Compiler / GHC Commits: f8b2bd8f by Alan Zimmerman at 2026-09-08T09:39:12-04:00 EPA Fix HsCmdDo exact print with comments Exact printing of HsCmdDo was ignoring the location for the do statements, and this is an annotation that can have comments in it. Update it so we print the statements as a unit, including any comments. Also add the result of auditing that we capture comments in all needed places, noting that the remaining Anno SrcSpan instances are benign. - - - - - c358ef9d by Simon Jakobi at 2026-09-09T03:32:34-04:00 FastString: Drop mkFastStringWith's constructor callback All three callers passed the same callback, a partial application of mkNewFastStringShortByteString to the string being interned. That partial application is allocated as a closure before the table lookup, on the common hit path too, although the callback is needed only after a miss. Drop the parameter and call mkNewFastStringShortByteString directly after a miss. Since nothing is passed "with" anymore, rename the function to internSB. Suggested by Simon PJ in #27528: https://gitlab.haskell.org/ghc/ghc/-/work_items/27528#note_687031 Assisted-by: Claude Fable 5 - - - - - 04fcdddb by Alan Zimmerman at 2026-09-09T03:32:35-04:00 EPA: Exact print ConDeclGADT without custom enterAnn !16321 brought in explicit capture of parens in a ConDeclGADT. The ExactPrint update introduced a modification of the fundamental function in exact printing, `enterAnn`, by splitting it into a version allowing injection of functionality normally handled by the ExactPrint class methods. This commit refactors that code, to restore the prior `enterAnn` version, by following the convention in ExactPrint of introducing a helper data structure with its own `ExactPrint` instance to achieve the same effect. - - - - - 4 changed files: - compiler/GHC/Data/FastString.hs - compiler/GHC/Hs/Doc.hs - compiler/GHC/Hs/Extension/Pass.hs - utils/check-exact/ExactPrint.hs Changes: ===================================== compiler/GHC/Data/FastString.hs ===================================== @@ -320,7 +320,7 @@ data FastStringTable = FastStringTable -- ^ Number of computed z-encodings for all buckets. -- -- We mark this as 'NOUNPACK' as this 'FastMutInt' is retained by a thunk - -- in 'mkFastStringWith' and needs to be boxed any way. + -- in 'internSB' and needs to be boxed any way. -- If this is unpacked, then we box this single 'FastMutInt' once for each -- allocated FastString. (Array# (IORef FastStringTableSegment)) -- ^ concurrent segments @@ -474,9 +474,10 @@ The procedure goes like this: * Otherwise, insert and return the string we created. -} -mkFastStringWith - :: (Int -> FastMutInt-> IO FastString) -> ShortByteString -> IO FastString -mkFastStringWith mk_fs sbs = do +-- | Return the interned 'FastString' for the given bytes, creating and +-- inserting one on a table miss. +internSB :: ShortByteString -> IO FastString +internSB sbs = do FastStringTableSegment lock _ buckets# <- readIORef segmentRef let idx# = hashToIndex# buckets# hash# bucket <- IO $ readArray# buckets# idx# @@ -487,7 +488,7 @@ mkFastStringWith mk_fs sbs = do -- only run partially and putMVar is not called after takeMVar. noDuplicate n <- get_uid - new_fs <- mk_fs n n_zencs + new_fs <- mkNewFastStringShortByteString sbs n n_zencs withMVar lock $ \_ -> insert new_fs where !(FastStringTable uid n_zencs segments#) = stringTable @@ -523,11 +524,11 @@ bucket_match fs sbs = go fs mkFastStringBytes :: Ptr Word8 -> Int -> FastString mkFastStringBytes !ptr !len = - -- NB: Might as well use unsafeDupablePerformIO, since mkFastStringWith is + -- NB: Might as well use unsafeDupablePerformIO, since internSB is -- idempotent. unsafeDupablePerformIO $ do sbs <- newSBSFromPtr ptr len - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + internSB sbs newSBSFromPtr :: Ptr a -> Int -> IO ShortByteString newSBSFromPtr (Ptr src#) (I# len#) = @@ -541,14 +542,13 @@ newSBSFromPtr (Ptr src#) (I# len#) = mkFastStringByteString :: ByteString -> FastString mkFastStringByteString bs = let sbs = SBS.toShort bs in - inlinePerformIO $ - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + inlinePerformIO $ internSB sbs -- | Create a 'FastString' from an existing 'ShortByteString' without -- copying. mkFastStringShortByteString :: ShortByteString -> FastString mkFastStringShortByteString sbs = - inlinePerformIO $ mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + inlinePerformIO $ internSB sbs -- | Create a 'FastString' from an 'HText' mkFastStringShortText :: ShortText -> FastString @@ -560,7 +560,7 @@ mkFastString :: String -> FastString mkFastString str = inlinePerformIO $ do let !sbs = utf8EncodeShortByteString str - mkFastStringWith (mkNewFastStringShortByteString sbs) sbs + internSB sbs -- The following rule is used to avoid polluting the non-reclaimable FastString -- table with transient strings when we only want their encoding. ===================================== compiler/GHC/Hs/Doc.hs ===================================== @@ -58,6 +58,7 @@ import Language.Haskell.Syntax.Doc import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Module.Name +-- Exact print annotations ignore LHsDoc, so bare SrcSpan is fine type instance Anno (WithHsDocIdentifiers (HsDocString (GhcPass pass)) (GhcPass pass)) = SrcSpan deriving instance (Data pass, Data (LIdP pass), Data a) => Data (WithHsDocIdentifiers a pass) ===================================== compiler/GHC/Hs/Extension/Pass.hs ===================================== @@ -46,6 +46,7 @@ type instance XRec (GhcPass p) a = XRecGhc a -- but pass-independent, source location type XRecGhc a = GenLocated (Anno a) a +-- Exact print annotations ignore LHsDoc, so bare SrcSpan is fine type instance Anno (HsDocString (GhcPass _)) = SrcSpan type instance Anno HsDocStringChunk = SrcSpan ===================================== utils/check-exact/ExactPrint.hs ===================================== @@ -370,10 +370,6 @@ cua CanUpdateAnchor f = f cua CanUpdateAnchorOnly _ = return [] cua NoCanUpdateAnchor _ = return [] -enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a -enterAnn = enterAnnWith exact setAnnotationAnchor - -{-# INLINE enterAnnWith #-} -- | "Enter" an annotation, by using the associated 'anchor' field as -- the new reference point for calculating all DeltaPos positions. -- This is the heart of the exact printing process. @@ -381,17 +377,14 @@ enterAnn = enterAnnWith exact setAnnotationAnchor -- This is combination of the ghc=exactprint Delta.withAST and -- Print.exactPC functions and effectively does the delta processing -- immediately followed by the print processing. JIT ghc-exactprint. -enterAnnWith :: (Monad m, Monoid w, Typeable a, Typeable b) => - (a -> EP w m b) -> -- exact - (b -> EpaLocation -> [TrailingAnn] -> EpAnnComments -> b) -> -- setAnnotationAnchor - Entry -> a -> EP w m b -enterAnnWith exactVia _ NoEntryVal a = do +enterAnn :: (Monad m, Monoid w, ExactPrint a) => Entry -> a -> EP w m a +enterAnn NoEntryVal a = do p <- getPosP debugM $ "enterAnn:starting:NO ANN:(p,a) =" ++ show (p, astId a) - r <- exactVia a + r <- exact a debugM $ "enterAnn:done:NO ANN:p =" ++ show (p, astId a) return r -enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do +enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do acceptSpan <- getAcceptSpan setAcceptSpan False case anchor' of @@ -502,7 +495,7 @@ enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpd advance edp debugM $ "enterAnn:exact a starting:" ++ show (showAst anchor') - a' <- exactVia a + a' <- exact a debugM $ "enterAnn:exact a done:" ++ show (showAst anchor') -- Core recursive exactprint done, start end of Entry processing @@ -556,8 +549,8 @@ enterAnnWith exactVia setAnnAnchor !(Entry anchor' trailing_anns cs flush canUpd EpaSpan s -> EpaDelta s edp [] _ -> EpaDelta noSrcSpan edp [] let r = case canUpdateAnchor of - CanUpdateAnchor -> setAnnAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) - CanUpdateAnchorOnly -> setAnnAnchor a' newAnchor [] emptyComments + CanUpdateAnchor -> setAnnotationAnchor a' newAnchor trailing' (mkEpaComments priorCs postCs) + CanUpdateAnchorOnly -> setAnnotationAnchor a' newAnchor [] emptyComments NoCanUpdateAnchor -> a' return r @@ -3404,13 +3397,13 @@ instance ExactPrint (HsCmd GhcPs) where e' <- markAnnotated e return (HsCmdLet (tkLet', tkIn') binds' e') - exact (HsCmdDo (an0,loc) (L l es)) = do + exact (HsCmdDo (an0,loc) es) = do debugM $ "HsCmdDo" loc' <- printStringAtAA loc "do" (an1,es') <- markAnnList' an0 $ do - ee <- mapM markAnnotated es + ee <- markAnnotated es return ee - return (HsCmdDo (an1,loc') (L l es')) + return (HsCmdDo (an1,loc') es') -- --------------------------------------------------------------------- @@ -4264,26 +4257,13 @@ instance ExactPrint (ConDecl GhcPs) where epTokensToComments "(" ops epTokensToComments ")" cps - -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 outer_bndrs' <- case outer_bndrs of L _ (HsOuterImplicit _) -> return outer_bndrs _ -> markAnnotated outer_bndrs - (inner_bndrs', (mcxt', args', res_ty')) <- markGadtArgs inner_bndrs $ do - mcxt' <- markAnnotated mcxt - args' <- - case args of - (PrefixConGADT x args0) -> do - args0' <- mapM markAnnotated args0 - return (PrefixConGADT x args0') - (RecConGADT (oc,cc,rarr) fields) -> do - oc' <- markEpToken oc - fields' <- markAnnotated fields - cc' <- markEpToken cc - rarr' <- markEpUniToken rarr - return (RecConGADT (oc',cc',rarr') fields') - res_ty' <- markAnnotated res_ty - return (mcxt', args', res_ty') + let ib = toInnerBindings inner_bndrs (mcxt, args, res_ty) + ib' <- markAnnotated ib + let (inner_bndrs', (mcxt', args', res_ty')) = fromInnerBindings ib' return (ConDeclGADT { con_g_ext = AnnConDeclGADT [] [] dcol' , con_names = cons' @@ -4293,43 +4273,54 @@ instance ExactPrint (ConDecl GhcPs) where , con_modifiers = mods' , con_res_ty = res_ty', con_doc = doc }) --- | Exact print the inner binders of a GADT signature. --- --- It's that complicated because we need to mark comments/trailing anns --- stored inside `L` and mark closing parenthesis _after_ we mark inner --- type: --- --- data T a b where --- MkT :: --- forall a. ( -- mark inside `markGadtArgs` --- forall b. some type -> T a b -- mark everything there --- ) -- mark inside `markGadtArgs` --- --- We don't have the same problem for `HsArgPar` because we ignore it --- during exact-print, "Does not appear in original source" -markGadtArgs :: (Monad m, Monoid w, Typeable a) - => [LHsGadtTelescope GhcPs] -> EP w m a - -> EP w m ([LHsGadtTelescope GhcPs], a) -markGadtArgs args inner_action = go args +-- --------------------------------------------------------------------- + +data InnerBindings + = InnerMore (LHsGadtTelescope GhcPs) InnerBindings + | InnerDone (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) + +toInnerBindings :: [LHsGadtTelescope GhcPs] + -> (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs) -> InnerBindings +toInnerBindings [] inner = InnerDone inner +toInnerBindings (b:bs) inner = InnerMore b (toInnerBindings bs inner) + +fromInnerBindings :: InnerBindings -> ([LHsGadtTelescope GhcPs], (Maybe (LHsContext GhcPs), HsConDeclGADTDetails GhcPs, LHsType GhcPs)) +fromInnerBindings = go [] where - go [] = do - r <- inner_action - return ([], r) - go (arg:xs) = enterAnnWith (exact_arg xs) setAnchor (entryFromLocatedA arg) arg + go acc (InnerMore b n) = go (b:acc) n + go acc (InnerDone x) = (acc,x) - exact_arg xs (L l (HsGadtForAll _ tele)) = do - tele' <- markAnnotated tele - (xs', r) <- go xs - return (L l (HsGadtForAll noExtField tele') : xs', r) - exact_arg xs (L l (HsGadtPar (lp, rp))) = do - lp' <- markEpToken lp - (xs', r) <- go xs - rp' <- markEpToken rp - return (L l (HsGadtPar (lp',rp')) : xs', r) +instance ExactPrint InnerBindings where + getAnnotationEntry (InnerMore (L li _) _) = fromAnn li + getAnnotationEntry (InnerDone _) = NoEntryVal - -- The binder just entered is the head of the returned list - setAnchor (arg':xs', r) anc ts cs = (setAnchorAn arg' anc ts cs : xs', r) - setAnchor ([], r) _ _ _ = ([], r) + setAnnotationAnchor (InnerMore li n) anc ts cs = InnerMore (setAnchorAn li anc ts cs) n + setAnnotationAnchor (InnerDone x) _ _ _ = InnerDone x + + exact (InnerMore (L li (HsGadtForAll x tele)) n) = do + tele' <- markAnnotated tele + n' <- markAnnotated n + return (InnerMore (L li (HsGadtForAll x tele')) n') + exact (InnerMore (L l (HsGadtPar (lp, rp))) xs) = do + lp' <- markEpToken lp + xs' <- markAnnotated xs + rp' <- markEpToken rp + return (InnerMore (L l (HsGadtPar (lp',rp'))) xs') + exact (InnerDone (mcxt, args, res_ty)) = do + mcxt' <- markAnnotated mcxt + args' <- + case args of + (PrefixConGADT x args0) -> do + args0' <- mapM markAnnotated args0 + return (PrefixConGADT x args0') + (RecConGADT (oc,cc,rarr) fields) -> do + oc' <- markEpToken oc + fields' <- markAnnotated fields + cc' <- markEpToken cc + rarr' <- markEpUniToken rarr + return (RecConGADT (oc',cc',rarr') fields') + res_ty' <- markAnnotated res_ty + return (InnerDone (mcxt', args', res_ty')) -- --------------------------------------------------------------------- @@ -4508,10 +4499,10 @@ instance ExactPrint [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))] whe Just (initStmts, ls@(L _ (LastStmt _ _body _ _))) -> do debugM $ "LocatedL [ExprLStmt: snocView" ls' <- markAnnotated ls - initStmts' <- markAnnotated initStmts + initStmts' <- mapM markAnnotated initStmts return (initStmts' ++ [ls']) _ -> do - stmts' <- markAnnotated stmts + stmts' <- mapM markAnnotated stmts return stmts' instance ExactPrint [Located HsDocStringChunk] where View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ab270a20d1152aaf89c17c70cdf8c2... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/compare/7ab270a20d1152aaf89c17c70cdf8c2... You're receiving this email because of your account on gitlab.haskell.org. Manage all notifications: https://gitlab.haskell.org/-/profile/notifications | Help: https://gitlab.haskell.org/help