summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC.hs3
-rw-r--r--compiler/GHC/Cmm/Switch.hs6
-rw-r--r--compiler/GHC/Driver/Backend.hs56
-rw-r--r--compiler/GHC/Driver/CodeOutput.hs3
-rw-r--r--compiler/GHC/Driver/Config/Cmm.hs2
-rw-r--r--compiler/GHC/Driver/Config/StgToCmm.hs8
-rw-r--r--compiler/GHC/Driver/Main.hs6
-rw-r--r--compiler/GHC/Driver/Make.hs2
-rw-r--r--compiler/GHC/Driver/Pipeline.hs21
-rw-r--r--compiler/GHC/Driver/Pipeline/Execute.hs18
-rw-r--r--compiler/GHC/Driver/Session.hs40
-rw-r--r--compiler/GHC/HsToCore/Coverage.hs2
-rw-r--r--compiler/GHC/Iface/Tidy.hs2
-rw-r--r--compiler/GHC/Tc/Gen/Foreign.hs25
-rw-r--r--compiler/GHC/Tc/Gen/Sig.hs6
-rw-r--r--compiler/GHC/Unit/Module/Graph.hs6
16 files changed, 107 insertions, 99 deletions
diff --git a/compiler/GHC.hs b/compiler/GHC.hs
index 770cdf62b8..e8c81cb8f2 100644
--- a/compiler/GHC.hs
+++ b/compiler/GHC.hs
@@ -2,6 +2,7 @@
{-# LANGUAGE NondecreasingIndentation, ScopedTypeVariables #-}
{-# LANGUAGE TupleSections, NamedFieldPuns #-}
{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE PatternSynonyms #-}
{-# LANGUAGE TypeFamilies #-}
-- -----------------------------------------------------------------------------
@@ -28,7 +29,7 @@ module GHC (
needsTemplateHaskellOrQQ,
-- * Flags and settings
- DynFlags(..), GeneralFlag(..), Severity(..), Backend(..), gopt,
+ DynFlags(..), GeneralFlag(..), Severity(..), Backend, pattern NoBackend, ActualBackend(..), gopt,
GhcMode(..), GhcLink(..),
parseDynamicFlags, parseTargetFiles,
getSessionDynFlags,
diff --git a/compiler/GHC/Cmm/Switch.hs b/compiler/GHC/Cmm/Switch.hs
index f8c6c674ef..c7e11fea1e 100644
--- a/compiler/GHC/Cmm/Switch.hs
+++ b/compiler/GHC/Cmm/Switch.hs
@@ -315,9 +315,9 @@ and slowed down all other cases making it not worthwhile.
-- | Does the backend support switch out of the box? Then leave this to the
-- backend!
backendSupportsSwitch :: Backend -> Bool
-backendSupportsSwitch ViaC = True
-backendSupportsSwitch LLVM = True
-backendSupportsSwitch _ = False
+backendSupportsSwitch (Just ViaC) = True
+backendSupportsSwitch (Just LLVM) = True
+backendSupportsSwitch _ = False
-- | This function creates a SwitchPlan from a SwitchTargets value, breaking it
-- down into smaller pieces suitable for code generation.
diff --git a/compiler/GHC/Driver/Backend.hs b/compiler/GHC/Driver/Backend.hs
index 2642a2a9af..9f37f6c62a 100644
--- a/compiler/GHC/Driver/Backend.hs
+++ b/compiler/GHC/Driver/Backend.hs
@@ -1,8 +1,11 @@
{-# LANGUAGE MultiWayIf #-}
+{-# LANGUAGE PatternSynonyms #-}
-- | Code generation backends
module GHC.Driver.Backend
- ( Backend (..)
+ ( Backend
+ , pattern NoBackend
+ , ActualBackend (..)
, platformDefaultBackend
, platformNcgSupported
, backendProducesObject
@@ -19,7 +22,7 @@ import GHC.Platform
-- (producing machine code, producing ByteCode for the interpreter) and
-- supporting different platforms.
--
-data Backend
+data ActualBackend
= NCG -- ^ Native code generator backend.
--
-- Compiles Cmm code into textual assembler, then relies on
@@ -72,19 +75,30 @@ data Backend
--
-- See "GHC.StgToByteCode"
+ deriving (Eq,Ord,Show,Read)
- | NoBackend -- ^ No code generated.
- --
- -- Use this to disable code generation. It is particularly
- -- useful when GHC is used as a library for other purpose
- -- than generating code (e.g. to generate documentation with
- -- Haddock) or when the user requested it (via -fno-code) for
- -- some reason.
+-- | Sometimes we have a backend, and sometimes we do not.
+--
+-- Not inlining 'Nothing' into 'ActualBackend' will help lead towards things
+-- like e.g.
+--
+-- - Building for multiple backends at once, where we would switch from
+-- 'Maybe ActualBackend' to 'Set ActualBackend', not 'Set (Maybe
+-- ActualBackend)'.
+--
+-- - Ensuring all backends can write to files. That would mean byte code can be
+-- written to a file (#21034), which makes 'ActualBackend' much more uniform.
+-- Conversely it's hard to imagine it would ever make sense for 'NoBackend' to
+-- write to a file!
+type Backend = Maybe ActualBackend
- deriving (Eq,Ord,Show,Read)
+{-# COMPLETE NoBackend, Just #-}
+
+pattern NoBackend :: Backend
+pattern NoBackend = Nothing
-- | Default backend to use for the given platform.
-platformDefaultBackend :: Platform -> Backend
+platformDefaultBackend :: Platform -> ActualBackend
platformDefaultBackend platform = if
| platformUnregisterised platform -> ViaC
| platformNcgSupported platform -> NCG
@@ -108,11 +122,11 @@ platformNcgSupported platform = if
-- | Will this backend produce an object file on the disk?
backendProducesObject :: Backend -> Bool
-backendProducesObject ViaC = True
-backendProducesObject NCG = True
-backendProducesObject LLVM = True
-backendProducesObject Interpreter = False
-backendProducesObject NoBackend = False
+backendProducesObject (Just ViaC) = True
+backendProducesObject (Just NCG) = True
+backendProducesObject (Just LLVM) = True
+backendProducesObject (Just Interpreter) = False
+backendProducesObject NoBackend = False
-- | Does this backend retain *all* top-level bindings for a module,
-- rather than just the exported bindings, in the TypeEnv and compiled
@@ -124,8 +138,8 @@ backendProducesObject NoBackend = False
-- When no backend is used we also do it, so that Haddock can get access to the
-- GlobalRdrEnv for a module after typechecking it.
backendRetainsAllBindings :: Backend -> Bool
-backendRetainsAllBindings Interpreter = True
-backendRetainsAllBindings NoBackend = True
-backendRetainsAllBindings ViaC = False
-backendRetainsAllBindings NCG = False
-backendRetainsAllBindings LLVM = False
+backendRetainsAllBindings NoBackend = True
+backendRetainsAllBindings (Just Interpreter) = True
+backendRetainsAllBindings (Just ViaC) = False
+backendRetainsAllBindings (Just NCG) = False
+backendRetainsAllBindings (Just LLVM) = False
diff --git a/compiler/GHC/Driver/CodeOutput.hs b/compiler/GHC/Driver/CodeOutput.hs
index 80a8277283..f4b8b95aab 100644
--- a/compiler/GHC/Driver/CodeOutput.hs
+++ b/compiler/GHC/Driver/CodeOutput.hs
@@ -111,12 +111,13 @@ codeOutput logger tmpfs dflags unit_state this_mod filenm location genForeignStu
}
; a <- case backend dflags of
+ NoBackend -> panic "codeOutput: NoBackend"
+ Just b -> case b of
NCG -> outputAsm logger dflags this_mod location filenm
linted_cmm_stream
ViaC -> outputC logger dflags filenm linted_cmm_stream pkg_deps
LLVM -> outputLlvm logger dflags filenm linted_cmm_stream
Interpreter -> panic "codeOutput: Interpreter"
- NoBackend -> panic "codeOutput: NoBackend"
; let stubs = genForeignStubs a
; stubs_exist <- outputForeignStubs logger tmpfs dflags unit_state this_mod location stubs
; return (filenm, stubs_exist, foreign_fps, a)
diff --git a/compiler/GHC/Driver/Config/Cmm.hs b/compiler/GHC/Driver/Config/Cmm.hs
index 38bab62048..d7280b0e60 100644
--- a/compiler/GHC/Driver/Config/Cmm.hs
+++ b/compiler/GHC/Driver/Config/Cmm.hs
@@ -22,7 +22,7 @@ initCmmConfig dflags = CmmConfig
, cmmGenStackUnwindInstr = debugLevel dflags > 0
, cmmExternalDynamicRefs = gopt Opt_ExternalDynamicRefs dflags
, cmmDoCmmSwitchPlans = not . backendSupportsSwitch . backend $ dflags
- , cmmSplitProcPoints = (backend dflags /= NCG)
+ , cmmSplitProcPoints = (backend dflags /= Just NCG)
|| not (platformTablesNextToCode platform)
|| usingInconsistentPicReg
}
diff --git a/compiler/GHC/Driver/Config/StgToCmm.hs b/compiler/GHC/Driver/Config/StgToCmm.hs
index ae59e41fdf..0476c0e684 100644
--- a/compiler/GHC/Driver/Config/StgToCmm.hs
+++ b/compiler/GHC/Driver/Config/StgToCmm.hs
@@ -58,8 +58,8 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
} where profile = targetProfile dflags
platform = profilePlatform profile
bk_end = backend dflags
- ncg = bk_end == NCG
- llvm = bk_end == LLVM
+ ncg = bk_end == Just NCG
+ llvm = bk_end == Just LLVM
x86ish = case platformArch platform of
ArchX86 -> True
ArchX86_64 -> True
@@ -70,5 +70,5 @@ initStgToCmmConfig dflags mod = StgToCmmConfig
_ -> False
aarch64 = platformArch platform == ArchAArch64
vec_err = case backend dflags of
- LLVM -> Nothing
- _ -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."])
+ Just LLVM -> Nothing
+ _ -> Just (unlines ["SIMD vector instructions require the LLVM back-end.", "Please use -fllvm."])
diff --git a/compiler/GHC/Driver/Main.hs b/compiler/GHC/Driver/Main.hs
index 3e48771ace..bdbc65670f 100644
--- a/compiler/GHC/Driver/Main.hs
+++ b/compiler/GHC/Driver/Main.hs
@@ -1001,9 +1001,9 @@ hscMaybeWriteIface :: Logger -> DynFlags -> Bool -> ModIface -> Maybe Fingerprin
hscMaybeWriteIface logger dflags is_simple iface old_iface mod_location = do
let force_write_interface = gopt Opt_WriteInterface dflags
write_interface = case backend dflags of
- NoBackend -> False
- Interpreter -> False
- _ -> True
+ NoBackend -> False
+ Just Interpreter -> False
+ Just _ -> True
write_iface dflags' iface =
let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location
diff --git a/compiler/GHC/Driver/Make.hs b/compiler/GHC/Driver/Make.hs
index 4ec6d13348..a8c087bbc3 100644
--- a/compiler/GHC/Driver/Make.hs
+++ b/compiler/GHC/Driver/Make.hs
@@ -1711,7 +1711,7 @@ enableCodeGenWhen logger tmpfs condition should_modify staticLife dynLife unit_e
, ml_obj_file = o_file
, ml_dyn_hi_file = dyn_hi_file
, ml_dyn_obj_file = dyn_o_file }
- , ms_hspp_opts = updOptLevel 0 $ dflags {backend = defaultBackendOf ms}
+ , ms_hspp_opts = updOptLevel 0 $ dflags { backend = Just $ defaultBackendOf ms }
}
pure (ModuleNode deps ms')
enable_code_gen ms = return ms
diff --git a/compiler/GHC/Driver/Pipeline.hs b/compiler/GHC/Driver/Pipeline.hs
index 56e188395e..d96ee2daf0 100644
--- a/compiler/GHC/Driver/Pipeline.hs
+++ b/compiler/GHC/Driver/Pipeline.hs
@@ -259,9 +259,9 @@ compileOne' mHscMessage
internalInterpreter = not (gopt Opt_ExternalInterpreter lcl_dflags)
pipelineOutput = case bcknd of
- Interpreter -> NoOutputFile
NoBackend -> NoOutputFile
- _ -> Persistent
+ Just Interpreter -> NoOutputFile
+ Just _ -> Persistent
logger = hsc_logger hsc_env0
tmpfs = hsc_tmpfs hsc_env0
@@ -294,15 +294,16 @@ compileOne' mHscMessage
= True
| otherwise = False
-- Figure out which backend we're using
- (bcknd, dflags3)
+ dflags3
-- #8042: When module was loaded with `*` prefix in ghci, but DynFlags
-- suggest to generate object code (which may happen in case -fobject-code
-- was set), force it to generate byte-code. This is NOT transitive and
-- only applies to direct targets.
| loadAsByteCode
- = (Interpreter, gopt_set (dflags2 { backend = Interpreter }) Opt_ForceRecomp)
+ = gopt_set (dflags2 { backend = Just Interpreter }) Opt_ForceRecomp
| otherwise
- = (backend dflags, dflags2)
+ = dflags2
+ bcknd = backend dflags3
-- See Note [Filepaths and Multiple Home Units]
dflags = dflags3 { includePaths = offsetIncludePaths dflags3 $ addImplicitQuoteInclude old_paths [current_dir] }
upd_summary = summary { ms_hspp_opts = dflags }
@@ -835,11 +836,11 @@ hscPostBackendPipeline _ _ HsBootFile _ _ _ = return Nothing
hscPostBackendPipeline _ _ HsigFile _ _ _ = return Nothing
hscPostBackendPipeline pipe_env hsc_env _ bcknd ml input_fn =
case bcknd of
- ViaC -> viaCPipeline HCc pipe_env hsc_env ml input_fn
- NCG -> Just <$> asPipeline False pipe_env hsc_env ml input_fn
- LLVM -> Just <$> llvmPipeline pipe_env hsc_env ml input_fn
- NoBackend -> return Nothing
- Interpreter -> return Nothing
+ NoBackend -> return Nothing
+ Just Interpreter -> return Nothing
+ Just ViaC -> viaCPipeline HCc pipe_env hsc_env ml input_fn
+ Just NCG -> Just <$> asPipeline False pipe_env hsc_env ml input_fn
+ Just LLVM -> Just <$> llvmPipeline pipe_env hsc_env ml input_fn
-- Pipeline from a given suffix
pipelineStart :: P m => PipeEnv -> HscEnv -> FilePath -> m (Maybe FilePath)
diff --git a/compiler/GHC/Driver/Pipeline/Execute.hs b/compiler/GHC/Driver/Pipeline/Execute.hs
index 6bc9df7c6f..6250837996 100644
--- a/compiler/GHC/Driver/Pipeline/Execute.hs
+++ b/compiler/GHC/Driver/Pipeline/Execute.hs
@@ -284,7 +284,7 @@ runAsPhase with_cpp pipe_env hsc_env location input_fn = do
-- LLVM from version 3.0 onwards doesn't support the OS X system
-- assembler, so we use clang as the assembler instead. (#5636)
- let (as_prog, get_asm_info) | backend dflags == LLVM
+ let (as_prog, get_asm_info) | backend dflags == Just LLVM
, platformOS platform == OSDarwin
= (GHC.SysTools.runClang, pure Clang)
| otherwise
@@ -500,7 +500,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
}
-> case backend dflags of
NoBackend -> panic "HscRecomp not relevant for NoBackend"
- Interpreter -> do
+ Just Interpreter -> do
-- In interpreted mode the regular codeGen backend is not run so we
-- generate a interface without codeGen info.
final_iface <- mkFullIface hsc_env partial_iface Nothing
@@ -519,7 +519,7 @@ runHscBackendPhase pipe_env hsc_env mod_name src_flavour location result = do
let !linkable = LM unlinked_time (mkHomeModule (hsc_home_unit hsc_env) mod_name)
(hs_unlinked ++ stub_o)
return ([], final_iface, Just linkable, panic "interpreter")
- _ -> do
+ Just _ -> do
output_fn <- phaseOutputFilenameNew next_phase pipe_env hsc_env (Just location)
(outputFilename, mStub, foreign_files, cg_infos) <-
hscGenHardCode hsc_env cgguts mod_location output_fn
@@ -1040,7 +1040,7 @@ doCpp logger tmpfs dflags unit_env raw input_fn output_fn = do
])
getBackendDefs :: Logger -> DynFlags -> IO [String]
-getBackendDefs logger dflags | backend dflags == LLVM = do
+getBackendDefs logger dflags | backend dflags == Just LLVM = do
llvmVer <- figureLlvmVersion logger dflags
return $ case fmap llvmVersionList llvmVer of
Just [m] -> [ "-D__GLASGOW_HASKELL_LLVM__=" ++ format (m,0) ]
@@ -1060,11 +1060,11 @@ hscPostBackendPhase HsBootFile _ = StopLn
hscPostBackendPhase HsigFile _ = StopLn
hscPostBackendPhase _ bcknd =
case bcknd of
- ViaC -> HCc
- NCG -> As False
- LLVM -> LlvmOpt
- NoBackend -> StopLn
- Interpreter -> StopLn
+ NoBackend -> StopLn
+ Just Interpreter -> StopLn
+ Just ViaC -> HCc
+ Just NCG -> As False
+ Just LLVM -> LlvmOpt
compileStub :: HscEnv -> FilePath -> IO FilePath
diff --git a/compiler/GHC/Driver/Session.hs b/compiler/GHC/Driver/Session.hs
index 838f0bf3b7..51440d187c 100644
--- a/compiler/GHC/Driver/Session.hs
+++ b/compiler/GHC/Driver/Session.hs
@@ -1117,7 +1117,7 @@ defaultDynFlags mySettings llvmConfig =
DynFlags {
ghcMode = CompManager,
ghcLink = LinkBinary,
- backend = platformDefaultBackend (sTargetPlatform mySettings),
+ backend = Just $ platformDefaultBackend $ sTargetPlatform mySettings,
verbosity = 0,
debugLevel = 0,
simplPhases = 2,
@@ -2268,9 +2268,13 @@ dynamic_flags_deps = [
, make_ord_flag defGhcFlag "keep-s-files"
(NoArg (setGeneralFlag Opt_KeepSFiles))
, make_ord_flag defGhcFlag "keep-llvm-file"
- (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles)
+ $ NoArg $ do
+ setObjBackend $ Just LLVM
+ setGeneralFlag Opt_KeepLlvmFiles
, make_ord_flag defGhcFlag "keep-llvm-files"
- (NoArg $ setObjBackend LLVM >> setGeneralFlag Opt_KeepLlvmFiles)
+ $ NoArg $ do
+ setObjBackend $ Just LLVM
+ setGeneralFlag Opt_KeepLlvmFiles
-- This only makes sense as plural
, make_ord_flag defGhcFlag "keep-tmp-files"
(NoArg (setGeneralFlag Opt_KeepTmpFiles))
@@ -2442,7 +2446,9 @@ dynamic_flags_deps = [
, make_ord_flag defGhcFlag "ddump-asm-stats"
(setDumpFlag Opt_D_dump_asm_stats)
, make_ord_flag defGhcFlag "ddump-llvm"
- (NoArg $ setObjBackend LLVM >> setDumpFlag' Opt_D_dump_llvm)
+ $ NoArg $ do
+ setObjBackend $ Just LLVM
+ setDumpFlag' Opt_D_dump_llvm
, make_ord_flag defGhcFlag "ddump-c-backend"
(NoArg $ setDumpFlag' Opt_D_dump_c_backend)
, make_ord_flag defGhcFlag "ddump-deriv"
@@ -2862,24 +2868,24 @@ dynamic_flags_deps = [
(NoArg (setGeneralFlag Opt_InfoTableMap))
------ Compiler flags -----------------------------------------------
- , make_ord_flag defGhcFlag "fasm" (NoArg (setObjBackend NCG))
+ , make_ord_flag defGhcFlag "fasm" (NoArg $ setObjBackend $ Just NCG)
, make_ord_flag defGhcFlag "fvia-c" (NoArg
(deprecate $ "The -fvia-c flag does nothing; " ++
"it will be removed in a future GHC release"))
, make_ord_flag defGhcFlag "fvia-C" (NoArg
(deprecate $ "The -fvia-C flag does nothing; " ++
"it will be removed in a future GHC release"))
- , make_ord_flag defGhcFlag "fllvm" (NoArg (setObjBackend LLVM))
+ , make_ord_flag defGhcFlag "fllvm" (NoArg $ setObjBackend $ Just LLVM)
, make_ord_flag defFlag "fno-code" (NoArg ((upd $ \d ->
d { ghcLink=NoLink }) >> setBackend NoBackend))
, make_ord_flag defFlag "fbyte-code"
(noArgM $ \dflags -> do
- setBackend Interpreter
+ setBackend $ Just Interpreter
pure $ gopt_set dflags Opt_ByteCode)
, make_ord_flag defFlag "fobject-code" $ NoArg $ do
dflags <- liftEwM getCmdLineState
- setBackend $ platformDefaultBackend (targetPlatform dflags)
+ setBackend $ Just $ platformDefaultBackend $ targetPlatform dflags
, make_dep_flag defFlag "fglasgow-exts"
(NoArg enableGlasgowExts) "Use individual extensions instead"
@@ -4720,30 +4726,30 @@ makeDynFlagsConsistent dflags
-- Via-C backend only supports unregisterised ABI. Switch to a backend
-- supporting it if possible.
- | backend dflags == ViaC &&
+ | backend dflags == Just ViaC &&
not (platformUnregisterised (targetPlatform dflags))
= case platformDefaultBackend (targetPlatform dflags) of
- NCG -> let dflags' = dflags { backend = NCG }
+ NCG -> let dflags' = dflags { backend = Just NCG }
warn = "Target platform doesn't use unregisterised ABI, so using native code generator rather than compiling via C"
in loop dflags' warn
- LLVM -> let dflags' = dflags { backend = LLVM }
+ LLVM -> let dflags' = dflags { backend = Just LLVM }
warn = "Target platform doesn't use unregisterised ABI, so using LLVM rather than compiling via C"
in loop dflags' warn
_ -> pgmError "Compiling via C only supports unregisterised ABI but target platform doesn't use it."
- | gopt Opt_Hpc dflags && backend dflags == Interpreter
+ | gopt Opt_Hpc dflags && backend dflags == Just Interpreter
= let dflags' = gopt_unset dflags Opt_Hpc
warn = "Hpc can't be used with byte-code interpreter. Ignoring -fhpc."
in loop dflags' warn
- | backend dflags `elem` [NCG, LLVM] &&
+ | backend dflags `elem` (fmap Just [NCG, LLVM]) &&
platformUnregisterised (targetPlatform dflags)
- = loop (dflags { backend = ViaC })
+ = loop (dflags { backend = Just ViaC })
"Target platform uses unregisterised ABI, so compiling via C"
- | backend dflags == NCG &&
+ | backend dflags == Just NCG &&
not (platformNcgSupported $ targetPlatform dflags)
- = let dflags' = dflags { backend = LLVM }
+ = let dflags' = dflags { backend = Just LLVM }
warn = "Native code generator doesn't support target platform, so using LLVM"
in loop dflags' warn
@@ -4756,7 +4762,7 @@ makeDynFlagsConsistent dflags
= loop (gopt_set dflags Opt_PIC)
"Enabling -fPIC as it is always on for this platform"
- | backend dflags == Interpreter
+ | backend dflags == Just Interpreter
, let (dflags', changed) = updOptLevelChanged 0 dflags
, changed
= loop dflags' "Optimization flags conflict with --interactive; optimization flags ignored."
diff --git a/compiler/GHC/HsToCore/Coverage.hs b/compiler/GHC/HsToCore/Coverage.hs
index 20086620e5..da033244f5 100644
--- a/compiler/GHC/HsToCore/Coverage.hs
+++ b/compiler/GHC/HsToCore/Coverage.hs
@@ -1066,7 +1066,7 @@ coveragePasses dflags =
-- | Should we produce 'Breakpoint' ticks?
breakpointsEnabled :: DynFlags -> Bool
-breakpointsEnabled dflags = backend dflags == Interpreter
+breakpointsEnabled dflags = backend dflags == Just Interpreter
-- | Tickishs that only make sense when their source code location
-- refers to the current file. This might not always be true due to
diff --git a/compiler/GHC/Iface/Tidy.hs b/compiler/GHC/Iface/Tidy.hs
index 28c2cbc54d..8f3c15e508 100644
--- a/compiler/GHC/Iface/Tidy.hs
+++ b/compiler/GHC/Iface/Tidy.hs
@@ -395,7 +395,7 @@ tidyProgram hsc_env (ModGuts { mg_module = mod
case backend dflags of
-- If we are compiling for the interpreter we will insert
-- any necessary SPT entries dynamically
- Interpreter -> id
+ Just Interpreter -> id
-- otherwise add a C stub to do so
_ -> (`appendStubC` spt_init_code)
diff --git a/compiler/GHC/Tc/Gen/Foreign.hs b/compiler/GHC/Tc/Gen/Foreign.hs
index b1c38a7166..372c39358c 100644
--- a/compiler/GHC/Tc/Gen/Foreign.hs
+++ b/compiler/GHC/Tc/Gen/Foreign.hs
@@ -268,8 +268,7 @@ tcCheckFIType :: [Scaled Type] -> Type -> ForeignImport -> TcM ForeignImport
tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh l@(CLabel _) src)
-- Foreign import label
- = do checkCg checkCOrAsmOrLlvmOrInterp
- -- NB check res_ty not sig_ty!
+ = do -- NB check res_ty not sig_ty!
-- In case sig_ty is (forall a. ForeignPtr a)
check (isFFILabelTy (mkVisFunTys arg_tys res_ty)) (illegalForeignTyErr Outputable.empty)
cconv' <- checkCConv cconv
@@ -280,7 +279,6 @@ tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
-- The type must be of the form ft -> IO (FunPtr ft), where ft is a valid
-- foreign type. For legacy reasons ft -> IO (Ptr ft) is accepted, too.
-- The use of the latter form is DEPRECATED, though.
- checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
case arg_tys of
[Scaled arg1_mult arg1_ty] -> do
@@ -296,7 +294,6 @@ tcCheckFIType arg_tys res_ty (CImport (L lc cconv) safety mh CWrapper src) = do
tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
(CFunction target) src)
| isDynamicTarget target = do -- Foreign import dynamic
- checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
case arg_tys of -- The first arg must be Ptr or FunPtr
[] ->
@@ -315,7 +312,6 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
checkTc (xopt LangExt.GHCForeignImportPrim dflags)
(TcRnUnknownMessage $ mkPlainError noHints $
text "Use GHCForeignImportPrim to allow `foreign import prim'.")
- checkCg checkCOrAsmOrLlvmOrInterp
checkCTarget target
checkTc (playSafe safety)
(TcRnUnknownMessage $ mkPlainError noHints $
@@ -325,7 +321,6 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
checkForeignRes nonIOok checkSafe (isFFIPrimResultTy dflags) res_ty
return idecl
| otherwise = do -- Normal foreign import
- checkCg checkCOrAsmOrLlvmOrInterp
cconv' <- checkCConv cconv
checkCTarget target
dflags <- getDynFlags
@@ -345,7 +340,6 @@ tcCheckFIType arg_tys res_ty idecl@(CImport (L lc cconv) (L ls safety) mh
-- that the C identifier is valid for C
checkCTarget :: CCallTarget -> TcM ()
checkCTarget (StaticTarget _ str _ _) = do
- checkCg checkCOrAsmOrLlvmOrInterp
checkTc (isCLabelString str) (badCName str)
checkCTarget DynamicTarget = panic "checkCTarget DynamicTarget"
@@ -506,30 +500,21 @@ checkSafe = True
noCheckSafe = False
-- | Checking a supported backend is in use
-checkCOrAsmOrLlvm :: Backend -> Validity
+checkCOrAsmOrLlvm :: ActualBackend -> Validity
checkCOrAsmOrLlvm ViaC = IsValid
checkCOrAsmOrLlvm NCG = IsValid
checkCOrAsmOrLlvm LLVM = IsValid
checkCOrAsmOrLlvm _
= NotValid (text "requires unregisterised, llvm (-fllvm) or native code generation (-fasm)")
--- | Checking a supported backend is in use
-checkCOrAsmOrLlvmOrInterp :: Backend -> Validity
-checkCOrAsmOrLlvmOrInterp ViaC = IsValid
-checkCOrAsmOrLlvmOrInterp NCG = IsValid
-checkCOrAsmOrLlvmOrInterp LLVM = IsValid
-checkCOrAsmOrLlvmOrInterp Interpreter = IsValid
-checkCOrAsmOrLlvmOrInterp _
- = NotValid (text "requires interpreted, unregisterised, llvm or native code generation")
-
-checkCg :: (Backend -> Validity) -> TcM ()
+checkCg :: (ActualBackend -> Validity) -> TcM ()
checkCg check = do
dflags <- getDynFlags
let bcknd = backend dflags
case bcknd of
NoBackend -> return ()
- _ ->
- case check bcknd of
+ Just bcknd' ->
+ case check bcknd' of
IsValid -> return ()
NotValid err ->
addErrTc (TcRnUnknownMessage $ mkPlainError noHints $ text "Illegal foreign declaration:" <+> err)
diff --git a/compiler/GHC/Tc/Gen/Sig.hs b/compiler/GHC/Tc/Gen/Sig.hs
index 82a3290e4c..2fba3a4be1 100644
--- a/compiler/GHC/Tc/Gen/Sig.hs
+++ b/compiler/GHC/Tc/Gen/Sig.hs
@@ -839,9 +839,9 @@ tcImpPrags prags
not_specialising dflags
| not (gopt Opt_Specialise dflags) = True
| otherwise = case backend dflags of
- NoBackend -> True
- Interpreter -> True
- _other -> False
+ NoBackend -> True
+ Just Interpreter -> True
+ Just _other -> False
tcImpSpec :: (Name, Sig GhcRn) -> TcM [TcSpecPrag]
tcImpSpec (name, prag)
diff --git a/compiler/GHC/Unit/Module/Graph.hs b/compiler/GHC/Unit/Module/Graph.hs
index a225c50f27..cb3df65322 100644
--- a/compiler/GHC/Unit/Module/Graph.hs
+++ b/compiler/GHC/Unit/Module/Graph.hs
@@ -276,9 +276,9 @@ showModMsg dflags recomp (ModuleNode _ mod_summary) =
dyn_file = op $ msDynObjFilePath mod_summary
obj_file = op $ msObjFilePath mod_summary
message = case backend dflags of
- Interpreter | recomp -> text "interpreted"
- NoBackend -> text "nothing"
- _ ->
+ Just Interpreter | recomp -> text "interpreted"
+ NoBackend -> text "nothing"
+ _ ->
if gopt Opt_BuildDynamicToo dflags
then text obj_file <> comma <+> text dyn_file
else text obj_file
View Lorry Controller Status