Florian Ragwitz pushed to branch wip/rafl/meaningful-main-return at Glasgow Haskell Compiler / GHC Commits: 29a91779 by Florian Ragwitz at 2026-10-10T13:37:09-07:00 Skip some work for the common IO () case - - - - - 3 changed files: - compiler/GHC/Tc/Module.hs - testsuite/tests/plugins/T23110.stdout - testsuite/tests/plugins/static-plugins.stdout Changes: ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2042,35 +2042,33 @@ generateMainBinding tcg_env main_name = do -- https://github.com/ghc-proposals/ghc-proposals/pull/771. handleMainReturn :: Name -> TcType -> TcEvBinds -> LHsExpr GhcTc -> TcM (LHsExpr GhcTc) handleMainReturn main_name res_ty ev_binds main_expr = do - meaningful_main <- xoptM LangExt.MeaningfulMainReturn - void_ty <- mkTyConTy <$> tcLookupKnownOccTyCon voidTyConOcc - exit_code_ty <- mkTyConTy <$> tcLookupKnownOccTyCon exitCodeTyConOcc main_res_ty <- liftZonkM $ zonkTcType res_ty - - let unit_valid = isJust (tcUnifyTy main_res_ty unitTy) - void_valid = isJust (tcUnifyTy main_res_ty void_ty) - exit_code_valid = isJust (tcUnifyTy main_res_ty exit_code_ty) - - setSrcSpan (getSrcSpan main_name) $ - if meaningful_main - then checkTc - (unit_valid || void_valid || exit_code_valid) - (TcRnInvalidMainReturn main_name main_res_ty) - else diagnosticTc - (not (unit_valid || void_valid)) - (TcRnAmbiguousMainReturn main_name main_res_ty) - - let main_action = mkHsDictLet ev_binds main_expr - - if not meaningful_main || unit_valid || void_valid + if unifies main_res_ty unitTy then pure main_action else do - massertPpr exit_code_valid (ppr main_res_ty) - bind_io_id <- tcLookupKnownOccId bindIOIdOcc - exit_with_id <- tcLookupKnownOccId exitWithIdOcc - pure $ - nlHsTyApps bind_io_id [exit_code_ty, exit_code_ty] - [ main_action, nlHsTyApp exit_with_id [exit_code_ty] ] + void_ty <- mkTyConTy <$> tcLookupKnownOccTyCon voidTyConOcc + if unifies main_res_ty void_ty + then pure main_action + else do + meaningful_main <- xoptM LangExt.MeaningfulMainReturn + if not meaningful_main + then do + setSrcSpan (getSrcSpan main_name) $ + addDiagnosticTc (TcRnAmbiguousMainReturn main_name main_res_ty) + pure main_action + else wrapExitWith main_res_ty + where + main_action = mkHsDictLet ev_binds main_expr + unifies = (isJust .) . tcUnifyTy + wrapExitWith main_res_ty = do + exit_code_ty <- mkTyConTy <$> tcLookupKnownOccTyCon exitCodeTyConOcc + setSrcSpan (getSrcSpan main_name) $ + checkTc (unifies main_res_ty exit_code_ty) + (TcRnInvalidMainReturn main_name main_res_ty) + bind_io_id <- tcLookupKnownOccId bindIOIdOcc + exit_with_id <- tcLookupKnownOccId exitWithIdOcc + pure $ nlHsTyApps bind_io_id [exit_code_ty, exit_code_ty] + [ main_action, nlHsTyApp exit_with_id [exit_code_ty] ] getIOType :: TcM (TcType, TcType) -- Return (IO alpha, alpha) for fresh alpha ===================================== testsuite/tests/plugins/T23110.stdout ===================================== @@ -3,7 +3,6 @@ typeCheckPlugin (rn) interfacePlugin: GHC.Internal.Tuple interfacePlugin: GHC.Internal.Stack.Types interfacePlugin: GHC.Internal.Exception.Context -interfacePlugin: GHC.Internal.IO.Exception interfacePlugin: GHC.Internal.TopHandler typeCheckPlugin (tc) Collecting type info for 1 module(s) ... ===================================== testsuite/tests/plugins/static-plugins.stdout ===================================== @@ -13,7 +13,6 @@ interfacePlugin: GHC.Internal.Show typeCheckPlugin (rn) interfacePlugin: GHC.Internal.Stack.Types interfacePlugin: GHC.Internal.Exception.Context -interfacePlugin: GHC.Internal.IO.Exception interfacePlugin: GHC.Internal.TopHandler typeCheckPlugin (tc) interfacePlugin: GHC.Internal.Prim View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29a91779a63413b1ae5976a003f32281... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/29a91779a63413b1ae5976a003f32281... 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