Rodrigo Mesquita pushed to branch wip/fendor/no-code-output-constr at Glasgow Haskell Compiler / GHC Commits: 2b3ffb19 by Rodrigo Mesquita at 2026-06-24T16:05:48+01:00 Improve by-design documentation of backendCodeOutput `Backend` is **abstract by design**. Make this clearer in `backendCodeOutput` which is incorrectly being used as a proxy for `Backend`. Instead, define the desired property predicates in GHC.Driver.Backend In the process, make `backendCodeOutput` total. - - - - - 5 changed files: - compiler/GHC/Driver/Backend.hs - compiler/GHC/Driver/CodeOutput.hs - compiler/GHC/Driver/Main/Compile.hs - compiler/GHC/Driver/Pipeline.hs - compiler/GHC/Driver/Session.hs Changes: ===================================== compiler/GHC/Driver/Backend.hs ===================================== @@ -118,7 +118,6 @@ import GHC.Driver.Phases import GHC.Utils.Error -import GHC.Utils.Panic import GHC.Driver.Pipeline.Monad import GHC.Platform @@ -369,7 +368,8 @@ data PrimitiveImplementation -- We expect one function per back end—or more precisely, one function -- for each back end that writes code to a file. (The interpreter -- does not write to files; its output lives only in memory.) - +-- +-- See Note [Backend Defunctionalization] data DefunctionalizedCodeOutput = NcgCodeOutput | ViaCCodeOutput @@ -779,20 +779,33 @@ backendCDefs (Named NoBackend) = NoCDefs -- > -> Set UnitId -- ^ dependencies -- > -> Stream IO RawCmmGroup a -- results from `StgToCmm` -- > -> IO a -backendCodeOutput :: Backend -> DefunctionalizedCodeOutput -backendCodeOutput (Named NCG) = NcgCodeOutput -backendCodeOutput (Named LLVM) = LlvmCodeOutput -backendCodeOutput (Named ViaC) = ViaCCodeOutput -backendCodeOutput (Named JavaScript) = JSCodeOutput -backendCodeOutput (Named Bytecode) = panic "backendCodeOutput: bytecodeBackend" -backendCodeOutput (Named NoBackend) = panic "backendCodeOutput: noBackend" +-- +-- See Note [Backend Defunctionalization] +-- +-- === __WARNING__ +-- +-- Do NOT use 'backendCodeOutput' (or other functions in this module) as a +-- proxy for the 'Backend', which is __abstract by design__. +-- +-- If you need to determine some property of the backend, do NOT match on +-- 'DefunctionalizedCodeOutput'; Instead, write a new property predicate in +-- this module. This makes it easier to add new backends because essentially +-- all backend properties depended upon throughout the compiler are all found +-- here. +backendCodeOutput :: Backend -> Maybe DefunctionalizedCodeOutput +backendCodeOutput (Named NCG) = Just NcgCodeOutput +backendCodeOutput (Named LLVM) = Just LlvmCodeOutput +backendCodeOutput (Named ViaC) = Just ViaCCodeOutput +backendCodeOutput (Named JavaScript) = Just JSCodeOutput +backendCodeOutput (Named Bytecode) = Nothing +backendCodeOutput (Named NoBackend) = Nothing backendUseJSLinker :: Backend -> Bool backendUseJSLinker (Named NCG) = False backendUseJSLinker (Named LLVM) = False backendUseJSLinker (Named ViaC) = False backendUseJSLinker (Named JavaScript) = True -backendUseJSLinker (Named Bytecode) = False +backendUseJSLinker (Named Bytecode) = False backendUseJSLinker (Named NoBackend) = False -- | This (defunctionalized) function tells the compiler ===================================== compiler/GHC/Driver/CodeOutput.hs ===================================== @@ -4,7 +4,6 @@ \section{Code output phase} -} - module GHC.Driver.CodeOutput ( codeOutput , outputForeignStubs @@ -50,7 +49,7 @@ import GHC.Utils.Outputable import GHC.Utils.Logger import GHC.Utils.Exception ( bracket ) import GHC.Utils.Ppr (Mode(..)) -import GHC.Utils.Panic.Plain ( pgmError ) +import GHC.Utils.Panic.Plain ( panic, pgmError ) import GHC.Unit import GHC.Unit.Finder ( mkStubPaths ) @@ -63,7 +62,6 @@ import GHC.Types.Unique.Supply ( UniqueTag(..) ) import System.IO import Data.Set (Set) import qualified Data.Set as Set -import GHC.Plugins (panic) {- ************************************************************************ @@ -125,11 +123,12 @@ codeOutput logger tmpfs llvm_config dflags unit_state this_mod filenm location g ; let dus1 = newTagDUniqSupply CodeGenTag dus0 ; (stubs, a) <- case backendCodeOutput (backend dflags) of - NcgCodeOutput -> outputAsm logger dflags this_mod location filenm dus1 - final_stream - ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps - LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream - JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream + Just NcgCodeOutput -> outputAsm logger dflags this_mod location filenm dus1 + final_stream + Just ViaCCodeOutput -> outputC logger dflags filenm dus1 final_stream pkg_deps + Just LlvmCodeOutput -> outputLlvm logger llvm_config dflags filenm dus1 final_stream + Just JSCodeOutput -> outputJS logger llvm_config dflags filenm final_stream + Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output" ; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs ; return (filenm, stubs_exist, foreign_fps, a) } ===================================== compiler/GHC/Driver/Main/Compile.hs ===================================== @@ -2,6 +2,7 @@ {-# LANGUAGE MultiWayIf #-} {-# OPTIONS_GHC -fprof-auto-top #-} +{-# OPTIONS_GHC -Wno-x-backend #-} -- we do use backendCodeOutput for defunctionalization ------------------------------------------------------------------------------- -- @@ -670,7 +671,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do -- next withTiming after this will be "Assembler" (hard code only). withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ()) $ case backendCodeOutput (backend dflags) of - JSCodeOutput -> + Just JSCodeOutput -> do let js_config = initStgToJSConfig dflags @@ -696,7 +697,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs0 cost_centre_info output_filename return (output_filename, stub_c_exists, foreign_fps, Just stg_cg_infos, Just cmm_cg_infos) - _ -> + Just _ -> do cmms <- {-# SCC "StgToCmm" #-} doCodeGen hsc_env this_mod denv tycons @@ -724,6 +725,7 @@ hscGenHardCode hsc_env cgguts mod_loc output_filename = do foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1 return ( output_filename, stub_c_exists, foreign_fps , Just stg_cg_infos, Just cmm_cg_infos) + Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output" -- The part of CgGuts that we need for HscInteractive ===================================== compiler/GHC/Driver/Pipeline.hs ===================================== @@ -743,7 +743,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do let home_unit = hsc_home_unit hsc_env case backendCodeOutput (backend dflags) of - JSCodeOutput -> do + Just JSCodeOutput -> do empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "js" let src = ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode src)) @@ -752,7 +752,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do _ <- runPipeline (hsc_hooks hsc_env) pipeline pure () - _ -> do + Just _ -> do empty_stub <- newTempName logger tmpfs (tmpDir dflags) TFL_CurrentModule "c" let src = text "int" <+> ppr (mkHomeModule home_unit mod_name) <+> text "= 0;" writeFile empty_stub (showSDoc dflags (pprCode src)) @@ -760,6 +760,7 @@ compileEmptyStub dflags hsc_env basename location mod_name = do pipeline = viaCPipeline HCc pipe_env hsc_env (Just location) empty_stub _ <- runPipeline (hsc_hooks hsc_env) pipeline pure () + Nothing -> panic $ "backendCodeOutput: " ++ show (backend dflags) ++ " doesn't support code output" ===================================== compiler/GHC/Driver/Session.hs ===================================== @@ -3856,8 +3856,8 @@ makeDynFlagsConsistent dflags && os == OSMinGW32 && arch == ArchAArch64 = case backendCodeOutput (backend dflags) of - LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64" - NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64" + Just LlvmCodeOutput -> pgmError "-fllvm is incompatible with enabled TablesNextToCode at Windows Aarch64" + Just NcgCodeOutput -> pgmError "-fasm is incompatible with enabled TablesNextToCode at Windows Aarch64" _ -> (dflags, mempty, mempty) -- When we do ghci, force using dyn ways if the target RTS linker View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b3ffb19c154d5b2a72e57698296e642... -- View it on GitLab: https://gitlab.haskell.org/ghc/ghc/-/commit/2b3ffb19c154d5b2a72e57698296e642... You're receiving this email because of your account on gitlab.haskell.org.