GitLab

Cheng Shao pushed to branch wip/fix-cmm-dump-labels at Glasgow Haskell Compiler / GHC

Commits:

f586c885

by Simon Jakobi at 2026-07-24T18:05:00-04:00

ci: Use shallow submodule clones by default

Limit submodule clones to depth one to reduce CI checkout costs. Keep
fetching full submodule history for the submodule lint jobs, which
inspect commits across a range.

Assisted-by: gpt-5.6-sol via Codex CLI

306120d2

by Duncan Coutts at 2026-07-24T18:05:43-04:00

Fix flaky test T3994 on FreeBSD

On current FreeBSD versions, calling getpgid on a zombie process fails.
In T3994, if we're really unlucky with delays and scheduling then we can
end up in exactly that situation.

Just catch that specific exception and ignore it. It's rare, and not our
fault.

7b116a0b

by Cheng Shao at 2026-07-24T18:06:24-04:00

ci: add missing workaround for docker permissions in lint jobs

Some lint jobs use ci-images with default user `ghc`, and the gitlab
ci docker executor requires the `sudo chown` workaround to fix
workspace directory permission issue. This patch adds the missing
workarounds for the lint jobs. Fixes #27554.

Co-authored-by: Codex <codex@openai.com>

27fc2f8a

by Cheng Shao at 2026-07-25T11:20:53+02:00

compiler: fix missing top-level procedure labels in cmm dumps

This patch fixes missing top-level procedure labels in some
intermediate Cmm pass dumps. Fixes #27553.

Co-authored-by: Codex <codex@openai.com>

Changes:

.gitlab-ci.yml

@@ -23,6 +23,10 @@ variables:
    # Always start with a fresh clone to avoid non-hermetic builds
    GIT_STRATEGY: clone
 +  # Shallow submodule clones. Overridden by individual jobs that need deeper
 +  # submodule history.
 +  GIT_SUBMODULE_DEPTH: 1
++
    # Overridden by individual jobs
    CONFIGURE_ARGS: ""
@@ -262,7 +266,8 @@ lint-changelog:
      GIT_SUBMODULE_STRATEGY: none
    before_script:
      - export PATH="/opt/toolchain/bin:$PATH"
 -    - git config --global --add safe.directory "$CI_PROJECT_DIR"
 +    # workaround for docker permissions
 +    - sudo chown ghc:ghc -R .
    script:
      - .gitlab/ci.sh lint_changelog
    dependencies: []
@@ -279,6 +284,9 @@ lint-linters:
    variables:
      GIT_DEPTH: 1
      GIT_SUBMODULE_STRATEGY: none
 +  before_script:
 +    # workaround for docker permissions
 +    - sudo chown ghc:ghc -R .
    script:
      - mypy testsuite/tests/linters/regex-linters/*.py
    dependencies: []
@@ -290,6 +298,9 @@ lint-testsuite:
    variables:
      GIT_DEPTH: 1
      GIT_SUBMODULE_STRATEGY: none
 +  before_script:
 +    # workaround for docker permissions
 +    - sudo chown ghc:ghc -R .
    script:
      - make -Ctestsuite list_broken TEST_HC=$GHC
    dependencies: []
@@ -301,6 +312,9 @@ typecheck-testsuite:
    variables:
      GIT_DEPTH: 1
      GIT_SUBMODULE_STRATEGY: none
 +  before_script:
 +    # workaround for docker permissions
 +    - sudo chown ghc:ghc -R .
    script:
      - mypy testsuite/driver/runtests.py
    dependencies: []
@@ -313,6 +327,7 @@ typecheck-testsuite:
    extends: .lint-params
    variables:
      BUILD_FLAVOUR: default
 +    GIT_SUBMODULE_DEPTH: 0 # full history
    script:
      - .gitlab/ci.sh configure
      - .gitlab/ci.sh run_hadrian stage0:exe:lint-submodule-refs
@@ -330,6 +345,9 @@ lint-author:
    extends: .lint
    variables:
      GIT_SUBMODULE_STRATEGY: none
 +  before_script:
 +    # workaround for docker permissions
 +    - sudo chown ghc:ghc -R .
    script:
      - git fetch "$CI_MERGE_REQUEST_PROJECT_URL" $CI_MERGE_REQUEST_TARGET_BRANCH_NAME
      - base="$(git merge-base FETCH_HEAD $CI_COMMIT_SHA)"

changelog.d/fix-cmm-dump-labels

 +section: compiler
 +synopsis: Fix missing top-level procedure labels in some intermediate Cmm pass dumps.
 +issues: #27553
 +mrs: !16406

compiler/GHC/Cmm/Pipeline.hs

@@ -8,6 +8,7 @@ import GHC.Prelude
  import GHC.Driver.Flags
  import GHC.Cmm
 +import GHC.Cmm.CLabel
  import GHC.Cmm.Config
  import GHC.Cmm.ContFlowOpt
  import GHC.Cmm.CommonBlockElim
@@ -80,14 +81,14 @@ cpsTop logger platform cfg dus proc =
        --
        CmmProc h l v g <- {-# SCC "cmmCfgOpts(1)" #-}
             return $ cmmCfgOptsProc splitting_proc_points proc
 -      dump Opt_D_dump_cmm_cfg "Post control-flow optimisations (1)" g
 +      dump l Opt_D_dump_cmm_cfg "Post control-flow optimisations (1)" g
        let !TopInfo {stack_info=StackInfo { arg_space = entry_off
                                           , do_layout = do_layout }} = h
        ----------- Eliminate common blocks -------------------------------------
        g <- {-# SCC "elimCommonBlocks" #-}
 -           condPass (cmmOptElimCommonBlks cfg) elimCommonBlocks g
 +           condPass l (cmmOptElimCommonBlks cfg) elimCommonBlocks g
                           Opt_D_dump_cmm_cbe "Post common block elimination"
        -- Any work storing block Labels must be performed _after_
@@ -98,7 +99,7 @@ cpsTop logger platform cfg dus proc =
               then {-# SCC "createSwitchPlans" #-}
                    pure $ runUniqueDSM dus $ cmmImplementSwitchPlans platform g
               else pure (g, dus)
 -      dump Opt_D_dump_cmm_switch "Post switch plan" g
 +      dump l Opt_D_dump_cmm_switch "Post switch plan" g
        ----------- ThreadSanitizer instrumentation -----------------------------
        g <- {-# SCC "annotateTSAN" #-}
@@ -111,7 +112,7 @@ cpsTop logger platform cfg dus proc =
              return $ initUs_ us $
                annotateTSAN platform g
            else return g
 -      dump Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g
 +      dump l Opt_D_dump_cmm_thread_sanitizer "ThreadSanitizer instrumentation" g
        ----------- Proc points -------------------------------------------------
        let
@@ -134,11 +135,11 @@ cpsTop logger platform cfg dus proc =
           if do_layout
              then runUniqueDSM dus $ cmmLayoutStack cfg proc_points entry_off g
              else ((g, mapEmpty), dus)
 -      dump Opt_D_dump_cmm_sp "Layout Stack" g
 +      dump l Opt_D_dump_cmm_sp "Layout Stack" g
        ----------- Sink and inline assignments  --------------------------------
        g <- {-# SCC "sink" #-} -- See Note [Sinking after stack layout]
 -           condPass (cmmOptSink cfg) (cmmSink platform) g
 +           condPass l (cmmOptSink cfg) (cmmSink platform) g
                      Opt_D_dump_cmm_sink "Sink assignments"
        ------------- CAF analysis ----------------------------------------------
@@ -182,11 +183,11 @@ cpsTop logger platform cfg dus proc =
          dumps flag name
             = mapM_ (dumpWith logger flag name FormatCMM . pdoc platform)
 -        condPass do_opt pass g dumpflag dumpname =
 +        condPass lbl do_opt pass g dumpflag dumpname =
              if do_opt
                 then do
                      g <- return $ pass g
 -                    dump dumpflag dumpname g
 +                    dump lbl dumpflag dumpname g
                      return g
                 else return g
@@ -359,10 +360,10 @@ generator later.
  -}
 -dumpGraph :: Logger -> Platform -> Bool -> DumpFlag -> String -> CmmGraph -> IO ()
 -dumpGraph logger platform do_linting flag name g = do
 +dumpGraph :: Logger -> Platform -> Bool -> CLabel -> DumpFlag -> String -> CmmGraph -> IO ()
 +dumpGraph logger platform do_linting lbl flag name g = do
    when do_linting $ do_lint g
 -  dumpWith logger flag name FormatCMM (pdoc platform g)
 +  dumpWith logger flag name FormatCMM (pdoc platform lbl $$ pdoc platform g)
   where
    do_lint g = case cmmLintGraph platform g of
                   Just err -> do { fatalErrorMsg logger err

testsuite/tests/process/T3994.hs

  module Main where
  import Control.Concurrent
 +import Control.Exception
 +import Control.Monad
  import System.IO
 +import System.IO.Error
  import System.Process
  main :: IO ()
@@ -9,14 +12,24 @@ main = do (_,Just hout,_,p) <- createProcess (proc "./T3994app" ["start", "10000
                              { std_out = CreatePipe, create_group = True }
            start <- hGetLine hout
            putStrLn start
 -          interruptProcessGroupOf p
 -          t <- myThreadId
 -               -- timeout
 -          forkIO $ do
 -            threadDelay 5000000
 -            putStrLn "Interrupting a Running Process Failed"
 -            hFlush stdout
 -            killThread t
 -          waitForProcess p
++
 +          -- On FreeBSD if we're _really_ unlucky with scheduling, then the
 +          -- call to interruptProcessGroupOf can fail due to the process
 +          -- having already terminated (despite it running for at least 10ms!)
 +          -- If so, we just skip doing anything rather than fail the test,
 +          -- since this isn't our fault and is rare and scheduling dependent.
 +          -- See #27512 and https://reviews.freebsd.org/D58393
 +          handleJust (guard . isDoesNotExistError) (\_ -> return ()) $ do
 +            interruptProcessGroupOf p
 +            t <- myThreadId
 +                 -- timeout
 +            forkIO $ do
 +              threadDelay 5000000
 +              putStrLn "Interrupting a Running Process Failed"
 +              hFlush stdout
 +              killThread t
 +            waitForProcess p
 +            return ()
++
            putStrLn "end"
            return ()