Florian Ragwitz pushed to branch wip/rafl/meaningful-main-return at Glasgow Haskell Compiler / GHC Commits: b6355bc9 by Florian Ragwitz at 2026-10-10T12:08:05-07:00 Skip some work for the common IO () case - - - - - 1 changed file: - compiler/GHC/Tc/Module.hs Changes: ===================================== compiler/GHC/Tc/Module.hs ===================================== @@ -2042,35 +2042,36 @@ 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 + main_res_ty <- liftZonkM $ zonkTcType res_ty + if isJust (tcUnifyTy 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] ] + meaningful_main <- xoptM LangExt.MeaningfulMainReturn + void_ty <- mkTyConTy <$> tcLookupKnownOccTyCon voidTyConOcc + exit_code_ty <- mkTyConTy <$> tcLookupKnownOccTyCon exitCodeTyConOcc + + let 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 + (void_valid || exit_code_valid) + (TcRnInvalidMainReturn main_name main_res_ty) + else diagnosticTc + (not void_valid) + (TcRnAmbiguousMainReturn main_name main_res_ty) + + if not meaningful_main || void_valid + 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] ] getIOType :: TcM (TcType, TcType) -- Return (IO alpha, alpha) for fresh alpha View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b6355bc9f2ee58eb3f04382a31502f29... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/b6355bc9f2ee58eb3f04382a31502f29... 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