GitLab

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