summaryrefslogtreecommitdiff
path: root/compiler/main
diff options
context:
space:
mode:
authorJosh Meredith <joshmeredith2008@gmail.com>2019-12-04 23:39:28 +1100
committerJosh Meredith <joshmeredith2008@gmail.com>2019-12-04 23:39:28 +1100
commita8435165b84c32fd2ebdd1281dd6ee077e07ad5a (patch)
tree791936d014aeaa26174c2dcbef34c14f3329dd04 /compiler/main
parent7805441b4d5e22eb63a501e1e40383d10380dc92 (diff)
parentf03a41d4bf9418ee028ecb51654c928b2da74edd (diff)
downloadhaskell-wip/binary-readerT.tar.gz
Merge branch 'master' into wip/binary-readerTwip/binary-readerT
Diffstat (limited to 'compiler/main')
-rw-r--r--compiler/main/Annotations.hs62
-rw-r--r--compiler/main/DriverPipeline.hs44
-rw-r--r--compiler/main/DynFlags.hs5
-rw-r--r--compiler/main/Elf.hs16
-rw-r--r--compiler/main/ErrUtils.hs2
-rw-r--r--compiler/main/GHC.hs7
-rw-r--r--compiler/main/GhcMake.hs2
-rw-r--r--compiler/main/HeaderInfo.hs63
-rw-r--r--compiler/main/HscMain.hs36
-rw-r--r--compiler/main/HscStats.hs16
-rw-r--r--compiler/main/HscTypes.hs11
-rw-r--r--compiler/main/Packages.hs2
-rw-r--r--compiler/main/PipelineMonad.hs8
-rw-r--r--compiler/main/SysTools/Tasks.hs2
-rw-r--r--compiler/main/TidyPgm.hs2
-rw-r--r--compiler/main/ToolSettings.hs2
16 files changed, 145 insertions, 135 deletions
diff --git a/compiler/main/Annotations.hs b/compiler/main/Annotations.hs
index f8637e506a..e4320b7cc9 100644
--- a/compiler/main/Annotations.hs
+++ b/compiler/main/Annotations.hs
@@ -21,12 +21,14 @@ module Annotations (
import GhcPrelude
import Binary
-import Module ( Module )
+import Module ( Module
+ , ModuleEnv, emptyModuleEnv, extendModuleEnvWith
+ , plusModuleEnv_C, lookupWithDefaultModuleEnv
+ , mapModuleEnv )
+import NameEnv
import Name
import Outputable
import GHC.Serialized
-import UniqFM
-import Unique
import Control.Monad
import Data.Maybe
@@ -60,11 +62,6 @@ getAnnTargetName_maybe :: AnnTarget name -> Maybe name
getAnnTargetName_maybe (NamedTarget nm) = Just nm
getAnnTargetName_maybe _ = Nothing
-instance Uniquable name => Uniquable (AnnTarget name) where
- getUnique (NamedTarget nm) = getUnique nm
- getUnique (ModuleTarget mod) = deriveUnique (getUnique mod) 0
- -- deriveUnique prevents OccName uniques clashing with NamedTarget
-
instance Outputable name => Outputable (AnnTarget name) where
ppr (NamedTarget nm) = text "Named target" <+> ppr nm
ppr (ModuleTarget mod) = text "Module target" <+> ppr mod
@@ -86,12 +83,13 @@ instance Outputable Annotation where
ppr ann = ppr (ann_target ann)
-- | A collection of annotations
--- Can't use a type synonym or we hit bug #2412 due to source import
-newtype AnnEnv = MkAnnEnv (UniqFM [AnnPayload])
+data AnnEnv = MkAnnEnv { ann_mod_env :: !(ModuleEnv [AnnPayload])
+ , ann_name_env :: !(NameEnv [AnnPayload])
+ }
-- | An empty annotation environment.
emptyAnnEnv :: AnnEnv
-emptyAnnEnv = MkAnnEnv emptyUFM
+emptyAnnEnv = MkAnnEnv emptyModuleEnv emptyNameEnv
-- | Construct a new annotation environment that contains the list of
-- annotations provided.
@@ -100,33 +98,51 @@ mkAnnEnv = extendAnnEnvList emptyAnnEnv
-- | Add the given annotation to the environment.
extendAnnEnvList :: AnnEnv -> [Annotation] -> AnnEnv
-extendAnnEnvList (MkAnnEnv env) anns
- = MkAnnEnv $ addListToUFM_C (++) env $
- map (\ann -> (getUnique (ann_target ann), [ann_value ann])) anns
+extendAnnEnvList env =
+ foldl' extendAnnEnv env
+
+extendAnnEnv :: AnnEnv -> Annotation -> AnnEnv
+extendAnnEnv (MkAnnEnv mod_env name_env) (Annotation tgt payload) =
+ case tgt of
+ NamedTarget name -> MkAnnEnv mod_env (extendNameEnv_C (++) name_env name [payload])
+ ModuleTarget mod -> MkAnnEnv (extendModuleEnvWith (++) mod_env mod [payload]) name_env
-- | Union two annotation environments.
plusAnnEnv :: AnnEnv -> AnnEnv -> AnnEnv
-plusAnnEnv (MkAnnEnv env1) (MkAnnEnv env2) = MkAnnEnv $ plusUFM_C (++) env1 env2
+plusAnnEnv a b =
+ MkAnnEnv { ann_mod_env = plusModuleEnv_C (++) (ann_mod_env a) (ann_mod_env b)
+ , ann_name_env = plusNameEnv_C (++) (ann_name_env a) (ann_name_env b)
+ }
-- | Find the annotations attached to the given target as 'Typeable'
-- values of your choice. If no deserializer is specified,
-- only transient annotations will be returned.
findAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> CoreAnnTarget -> [a]
-findAnns deserialize (MkAnnEnv ann_env)
- = (mapMaybe (fromSerialized deserialize))
- . (lookupWithDefaultUFM ann_env [])
+findAnns deserialize env
+ = mapMaybe (fromSerialized deserialize) . findAnnPayloads env
-- | Find the annotations attached to the given target as 'Typeable'
-- values of your choice. If no deserializer is specified,
-- only transient annotations will be returned.
findAnnsByTypeRep :: AnnEnv -> CoreAnnTarget -> TypeRep -> [[Word8]]
-findAnnsByTypeRep (MkAnnEnv ann_env) target tyrep
- = [ ws | Serialized tyrep' ws <- lookupWithDefaultUFM ann_env [] target
+findAnnsByTypeRep env target tyrep
+ = [ ws | Serialized tyrep' ws <- findAnnPayloads env target
, tyrep' == tyrep ]
+-- | Find payloads for the given 'CoreAnnTarget' in an 'AnnEnv'.
+findAnnPayloads :: AnnEnv -> CoreAnnTarget -> [AnnPayload]
+findAnnPayloads env target =
+ case target of
+ ModuleTarget mod -> lookupWithDefaultModuleEnv (ann_mod_env env) [] mod
+ NamedTarget name -> fromMaybe [] $ lookupNameEnv (ann_name_env env) name
+
-- | Deserialize all annotations of a given type. This happens lazily, that is
-- no deserialization will take place until the [a] is actually demanded and
-- the [a] can also be empty (the UniqFM is not filtered).
-deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
-deserializeAnns deserialize (MkAnnEnv ann_env)
- = mapUFM (mapMaybe (fromSerialized deserialize)) ann_env
+deserializeAnns :: Typeable a => ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
+deserializeAnns deserialize env
+ = ( mapModuleEnv deserAnns (ann_mod_env env)
+ , mapNameEnv deserAnns (ann_name_env env)
+ )
+ where deserAnns = mapMaybe (fromSerialized deserialize)
+
diff --git a/compiler/main/DriverPipeline.hs b/compiler/main/DriverPipeline.hs
index ff0186a56b..62a4826edb 100644
--- a/compiler/main/DriverPipeline.hs
+++ b/compiler/main/DriverPipeline.hs
@@ -160,7 +160,7 @@ compileOne' m_tc_result mHscMessage
debugTraceMsg dflags1 2 (text "compile: input file" <+> text input_fnpp)
-- Run the pipeline up to codeGen (so everything up to, but not including, STG)
- (status, hmi_details, plugin_dflags) <- hscIncrementalCompile
+ (status, plugin_dflags) <- hscIncrementalCompile
always_do_basic_recompilation_check
m_tc_result mHscMessage
hsc_env summary source_modified mb_old_iface (mod_index, nmods)
@@ -178,27 +178,27 @@ compileOne' m_tc_result mHscMessage
let hsc_env' = hsc_env{ hsc_dflags = plugin_dflags }
case (status, hsc_lang) of
- (HscUpToDate iface, _) ->
+ (HscUpToDate iface hmi_details, _) ->
-- TODO recomp014 triggers this assert. What's going on?!
-- ASSERT( isJust mb_old_linkable || isNoLink (ghcLink dflags) )
return $! HomeModInfo iface hmi_details mb_old_linkable
- (HscNotGeneratingCode iface, HscNothing) ->
+ (HscNotGeneratingCode iface hmi_details, HscNothing) ->
let mb_linkable = if isHsBootOrSig src_flavour
then Nothing
-- TODO: Questionable.
else Just (LM (ms_hs_date summary) this_mod [])
in return $! HomeModInfo iface hmi_details mb_linkable
- (HscNotGeneratingCode _, _) -> panic "compileOne HscNotGeneratingCode"
+ (HscNotGeneratingCode _ _, _) -> panic "compileOne HscNotGeneratingCode"
(_, HscNothing) -> panic "compileOne HscNothing"
- (HscUpdateBoot iface, HscInterpreted) -> do
+ (HscUpdateBoot iface hmi_details, HscInterpreted) -> do
return $! HomeModInfo iface hmi_details Nothing
- (HscUpdateBoot iface, _) -> do
+ (HscUpdateBoot iface hmi_details, _) -> do
touchObjectFile dflags object_filename
return $! HomeModInfo iface hmi_details Nothing
- (HscUpdateSig iface, HscInterpreted) -> do
+ (HscUpdateSig iface hmi_details, HscInterpreted) -> do
let !linkable = LM (ms_hs_date summary) this_mod []
return $! HomeModInfo iface hmi_details (Just linkable)
- (HscUpdateSig iface, _) -> do
+ (HscUpdateSig iface hmi_details, _) -> do
output_fn <- getOutputFilename next_phase
(Temporary TFL_CurrentModule) basename dflags
next_phase (Just location)
@@ -210,7 +210,7 @@ compileOne' m_tc_result mHscMessage
(output_fn,
Nothing,
Just (HscOut src_flavour
- mod_name (HscUpdateSig iface)))
+ mod_name (HscUpdateSig iface hmi_details)))
(Just basename)
Persistent
(Just location)
@@ -220,6 +220,7 @@ compileOne' m_tc_result mHscMessage
return $! HomeModInfo iface hmi_details (Just linkable)
(HscRecomp { hscs_guts = cgguts,
hscs_mod_location = mod_location,
+ hscs_mod_details = hmi_details,
hscs_partial_iface = partial_iface,
hscs_old_iface_hash = mb_old_iface_hash,
hscs_iface_dflags = iface_dflags }, HscInterpreted) -> do
@@ -252,7 +253,7 @@ compileOne' m_tc_result mHscMessage
(Temporary TFL_CurrentModule)
basename dflags next_phase (Just location)
-- We're in --make mode: finish the compilation pipeline.
- (_, _, Just iface) <- runPipeline StopLn hsc_env'
+ (_, _, Just (iface, details)) <- runPipeline StopLn hsc_env'
(output_fn,
Nothing,
Just (HscOut src_flavour mod_name status))
@@ -263,7 +264,7 @@ compileOne' m_tc_result mHscMessage
-- The object filename comes from the ModLocation
o_time <- getModificationUTCTime object_filename
let !linkable = LM o_time this_mod [DotO object_filename]
- return $! HomeModInfo iface hmi_details (Just linkable)
+ return $! HomeModInfo iface details (Just linkable)
where dflags0 = ms_hspp_opts summary
this_mod = ms_mod summary
@@ -602,7 +603,7 @@ runPipeline
-> PipelineOutput -- ^ Output filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> [FilePath] -- ^ foreign objects
- -> IO (DynFlags, FilePath, Maybe ModIface)
+ -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
-- ^ (final flags, output filename, interface)
runPipeline stop_phase hsc_env0 (input_fn, mb_input_buf, mb_phase)
mb_basename output maybe_loc foreign_os
@@ -697,7 +698,7 @@ runPipeline'
-> FilePath -- ^ Input filename
-> Maybe ModLocation -- ^ A ModLocation, if this is a Haskell module
-> [FilePath] -- ^ foreign objects, if we have one
- -> IO (DynFlags, FilePath, Maybe ModIface)
+ -> IO (DynFlags, FilePath, Maybe (ModIface, ModDetails))
-- ^ (final flags, output filename, interface)
runPipeline' start_phase hsc_env env input_fn
maybe_loc foreign_os
@@ -1134,7 +1135,7 @@ runPhase (RealPhase (Hsc src_flavour)) input_fn dflags0
-- run the compiler!
let msg hsc_env _ what _ = oneShotMsg hsc_env what
- (result, _mod_details, plugin_dflags) <-
+ (result, plugin_dflags) <-
liftIO $ hscIncrementalCompile True Nothing (Just msg) hsc_env'
mod_summary source_unchanged Nothing (1,1)
@@ -1153,21 +1154,21 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
next_phase = hscPostBackendPhase src_flavour hsc_lang
case result of
- HscNotGeneratingCode _ ->
+ HscNotGeneratingCode _ _ ->
return (RealPhase StopLn,
panic "No output filename from Hsc when no-code")
- HscUpToDate _ ->
+ HscUpToDate _ _ ->
do liftIO $ touchObjectFile dflags o_file
-- The .o file must have a later modification date
-- than the source file (else we wouldn't get Nothing)
-- but we touch it anyway, to keep 'make' happy (we think).
return (RealPhase StopLn, o_file)
- HscUpdateBoot _ ->
+ HscUpdateBoot _ _ ->
do -- In the case of hs-boot files, generate a dummy .o-boot
-- stamp file for the benefit of Make
liftIO $ touchObjectFile dflags o_file
return (RealPhase StopLn, o_file)
- HscUpdateSig _ ->
+ HscUpdateSig _ _ ->
do -- We need to create a REAL but empty .o file
-- because we are going to attempt to put it in a library
PipeState{hsc_env=hsc_env'} <- getPipeState
@@ -1177,6 +1178,7 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
return (RealPhase StopLn, o_file)
HscRecomp { hscs_guts = cgguts,
hscs_mod_location = mod_location,
+ hscs_mod_details = mod_details,
hscs_partial_iface = partial_iface,
hscs_old_iface_hash = mb_old_iface_hash,
hscs_iface_dflags = iface_dflags }
@@ -1188,7 +1190,11 @@ runPhase (HscOut src_flavour mod_name result) _ dflags = do
hscGenHardCode hsc_env' cgguts mod_location output_fn
final_iface <- liftIO (mkFullIface hsc_env'{hsc_dflags=iface_dflags} partial_iface)
- setIface final_iface
+ -- TODO(osa): ModIface and ModDetails need to be in sync,
+ -- but we only generate ModIface with the backend info. See
+ -- !2100 for more discussion on this. This will be fixed
+ -- with !1304 or !2100.
+ setIface final_iface mod_details
-- See Note [Writing interface files]
let if_dflags = dflags `gopt_unset` Opt_BuildDynamicToo
diff --git a/compiler/main/DynFlags.hs b/compiler/main/DynFlags.hs
index 70f50f2a8b..d3cd6577ab 100644
--- a/compiler/main/DynFlags.hs
+++ b/compiler/main/DynFlags.hs
@@ -557,6 +557,7 @@ data GeneralFlag
| Opt_UnboxSmallStrictFields
| Opt_DictsCheap
| Opt_EnableRewriteRules -- Apply rewrite rules during simplification
+ | Opt_EnableThSpliceWarnings -- Enable warnings for TH splices
| Opt_RegsGraph -- do graph coloring register allocation
| Opt_RegsIterative -- do iterative coalescing graph coloring register allocation
| Opt_PedanticBottoms -- Be picky about how we treat bottom
@@ -4136,7 +4137,8 @@ wWarningFlagsDeps = [
flagSpec "unrecognised-warning-flags" Opt_WarnUnrecognisedWarningFlags,
flagSpec "star-binder" Opt_WarnStarBinder,
flagSpec "star-is-type" Opt_WarnStarIsType,
- flagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang,
+ depFlagSpec "missing-space-after-bang" Opt_WarnSpaceAfterBang
+ "bang patterns can no longer be written with a space",
flagSpec "partial-fields" Opt_WarnPartialFields,
flagSpec "prepositive-qualified-module"
Opt_WarnPrepositiveQualifiedModule,
@@ -4208,6 +4210,7 @@ fFlagsDeps = [
flagSpec "eager-blackholing" Opt_EagerBlackHoling,
flagSpec "embed-manifest" Opt_EmbedManifest,
flagSpec "enable-rewrite-rules" Opt_EnableRewriteRules,
+ flagSpec "enable-th-splice-warnings" Opt_EnableThSpliceWarnings,
flagSpec "error-spans" Opt_ErrorSpans,
flagSpec "excess-precision" Opt_ExcessPrecision,
flagSpec "expose-all-unfoldings" Opt_ExposeAllUnfoldings,
diff --git a/compiler/main/Elf.hs b/compiler/main/Elf.hs
index 648f20aad9..9e19de12dd 100644
--- a/compiler/main/Elf.hs
+++ b/compiler/main/Elf.hs
@@ -408,15 +408,6 @@ readElfNoteAsString dflags path sectionName noteId = action `catchIO` \_ -> do
-- | Generate the GAS code to create a Note section
--
-- Header fields for notes are 32-bit long (see Note [ELF specification]).
---
--- It seems there is no easy way to force GNU AS to generate a 32-bit word in
--- every case. Hence we use .int directive to create them: however "The byte
--- order and bit size of the number depends on what kind of target the assembly
--- is for." (https://sourceware.org/binutils/docs/as/Int.html#Int)
---
--- If we add new target platforms, we need to check that the generated words
--- are 32-bit long, otherwise we need to use platform specific directives to
--- force 32-bit .int in asWord32.
makeElfNote :: String -> String -> Word32 -> String -> SDoc
makeElfNote sectionName noteName typ contents = hcat [
text "\t.section ",
@@ -424,6 +415,7 @@ makeElfNote sectionName noteName typ contents = hcat [
text ",\"\",",
sectionType "note",
text "\n",
+ text "\t.balign 4\n",
-- note name length (+ 1 for ending \0)
asWord32 (length noteName + 1),
@@ -438,20 +430,20 @@ makeElfNote sectionName noteName typ contents = hcat [
text "\t.asciz \"",
text noteName,
text "\"\n",
- text "\t.align 4\n",
+ text "\t.balign 4\n",
-- note contents (.ascii to avoid ending \0) + padding
text "\t.ascii \"",
text (escape contents),
text "\"\n",
- text "\t.align 4\n"]
+ text "\t.balign 4\n"]
where
escape :: String -> String
escape = concatMap (charToC.fromIntegral.ord)
asWord32 :: Show a => a -> SDoc
asWord32 x = hcat [
- text "\t.int ",
+ text "\t.4byte ",
text (show x),
text "\n"]
diff --git a/compiler/main/ErrUtils.hs b/compiler/main/ErrUtils.hs
index f0fa1441f9..c66496bc61 100644
--- a/compiler/main/ErrUtils.hs
+++ b/compiler/main/ErrUtils.hs
@@ -879,7 +879,7 @@ the whole thing with 'withTiming'. Instead we wrap the processing of each
individual stream element, all along the codegen pipeline, using the appropriate
label for the pass to which this processing belongs. That generates a lot more
data but allows us to get fine-grained timings about all the passes and we can
-easily compute totals withh tools like ghc-events-analyze (see below).
+easily compute totals with tools like ghc-events-analyze (see below).
Producing an eventlog for GHC
diff --git a/compiler/main/GHC.hs b/compiler/main/GHC.hs
index 53c7680302..80131c6329 100644
--- a/compiler/main/GHC.hs
+++ b/compiler/main/GHC.hs
@@ -257,9 +257,6 @@ module GHC (
getLoc, unLoc,
getRealSrcSpan, unRealSrcSpan,
- -- ** HasSrcSpan
- HasSrcSpan(..), SrcSpanLess, dL, cL,
-
-- *** Combining and comparing Located values
eqLocated, cmpLocated, combineLocs, addCLoc,
leftmost_smallest, leftmost_largest, rightmost,
@@ -1392,7 +1389,7 @@ getRichTokenStream mod = do
addSourceToTokens :: RealSrcLoc -> StringBuffer -> [Located Token]
-> [(Located Token, String)]
addSourceToTokens _ _ [] = []
-addSourceToTokens loc buf (t@(dL->L span _) : ts)
+addSourceToTokens loc buf (t@(L span _) : ts)
= case span of
UnhelpfulSpan _ -> (t,"") : addSourceToTokens loc buf ts
RealSrcSpan s -> (t,str) : addSourceToTokens newLoc newBuf ts
@@ -1418,7 +1415,7 @@ showRichTokenStream ts = go startLoc ts ""
getFile (RealSrcSpan s : _) = srcSpanFile s
startLoc = mkRealSrcLoc sourceFile 1 1
go _ [] = id
- go loc ((dL->L span _, str):ts)
+ go loc ((L span _, str):ts)
= case span of
UnhelpfulSpan _ -> go loc ts
RealSrcSpan s
diff --git a/compiler/main/GhcMake.hs b/compiler/main/GhcMake.hs
index 6599da07f4..93bdb85f19 100644
--- a/compiler/main/GhcMake.hs
+++ b/compiler/main/GhcMake.hs
@@ -730,7 +730,7 @@ findPartiallyCompletedCycles modsDone theGraph
--
-- | Unloading
unload :: HscEnv -> [Linkable] -> IO ()
-unload hsc_env stable_linkables -- Unload everthing *except* 'stable_linkables'
+unload hsc_env stable_linkables -- Unload everything *except* 'stable_linkables'
= case ghcLink (hsc_dflags hsc_env) of
LinkInMemory -> Linker.unload hsc_env stable_linkables
_other -> return ()
diff --git a/compiler/main/HeaderInfo.hs b/compiler/main/HeaderInfo.hs
index bd984618a4..96361591e9 100644
--- a/compiler/main/HeaderInfo.hs
+++ b/compiler/main/HeaderInfo.hs
@@ -85,7 +85,7 @@ getImports dflags buf filename source_filename = do
imps = hsmodImports hsmod
main_loc = srcLocSpan (mkSrcLoc (mkFastString source_filename)
1 1)
- mod = mb_mod `orElse` cL main_loc mAIN_NAME
+ mod = mb_mod `orElse` L main_loc mAIN_NAME
(src_idecls, ord_idecls) = partition (ideclSource.unLoc) imps
-- GHC.Prim doesn't exist physically, so don't go looking for it.
@@ -96,8 +96,7 @@ getImports dflags buf filename source_filename = do
implicit_prelude = xopt LangExt.ImplicitPrelude dflags
implicit_imports = mkPrelImports (unLoc mod) main_loc
implicit_prelude imps
- convImport (dL->L _ i) = (fmap sl_fs (ideclPkgQual i)
- , ideclName i)
+ convImport (L _ i) = (fmap sl_fs (ideclPkgQual i), ideclName i)
in
return (map convImport src_idecls,
map convImport (implicit_imports ++ ordinary_imps),
@@ -120,23 +119,23 @@ mkPrelImports this_mod loc implicit_prelude import_decls
| otherwise = [preludeImportDecl]
where
explicit_prelude_import
- = notNull [ () | (dL->L _ (ImportDecl { ideclName = mod
- , ideclPkgQual = Nothing }))
+ = notNull [ () | L _ (ImportDecl { ideclName = mod
+ , ideclPkgQual = Nothing })
<- import_decls
, unLoc mod == pRELUDE_NAME ]
preludeImportDecl :: LImportDecl GhcPs
preludeImportDecl
- = cL loc $ ImportDecl { ideclExt = noExtField,
- ideclSourceSrc = NoSourceText,
- ideclName = cL loc pRELUDE_NAME,
- ideclPkgQual = Nothing,
- ideclSource = False,
- ideclSafe = False, -- Not a safe import
- ideclQualified = NotQualified,
- ideclImplicit = True, -- Implicit!
- ideclAs = Nothing,
- ideclHiding = Nothing }
+ = L loc $ ImportDecl { ideclExt = noExtField,
+ ideclSourceSrc = NoSourceText,
+ ideclName = L loc pRELUDE_NAME,
+ ideclPkgQual = Nothing,
+ ideclSource = False,
+ ideclSafe = False, -- Not a safe import
+ ideclQualified = NotQualified,
+ ideclImplicit = True, -- Implicit!
+ ideclAs = Nothing,
+ ideclHiding = Nothing }
--------------------------------------------------------------
-- Get options
@@ -192,7 +191,7 @@ lazyGetToks dflags filename handle = do
_other -> do rest <- lazyLexBuf handle state' eof size
return (t : rest)
_ | not eof -> getMore handle state size
- | otherwise -> return [cL (RealSrcSpan (last_loc state)) ITeof]
+ | otherwise -> return [L (RealSrcSpan (last_loc state)) ITeof]
-- parser assumes an ITeof sentinel at the end
getMore :: Handle -> PState -> Int -> IO [Located Token]
@@ -214,9 +213,9 @@ getToks dflags filename buf = lexAll (pragState dflags buf loc)
loc = mkRealSrcLoc (mkFastString filename) 1 1
lexAll state = case unP (lexer False return) state of
- POk _ t@(dL->L _ ITeof) -> [t]
+ POk _ t@(L _ ITeof) -> [t]
POk state' t -> t : lexAll state'
- _ -> [cL (RealSrcSpan (last_loc state)) ITeof]
+ _ -> [L (RealSrcSpan (last_loc state)) ITeof]
-- | Parse OPTIONS and LANGUAGE pragmas of the source file.
@@ -245,16 +244,16 @@ getOptions' dflags toks
= case toArgs str of
Left _err -> optionsParseError str dflags $ -- #15053
combineSrcSpans (getLoc open) (getLoc close)
- Right args -> map (cL (getLoc open)) args ++ parseToks xs
+ Right args -> map (L (getLoc open)) args ++ parseToks xs
parseToks (open:close:xs)
| ITinclude_prag str <- unLoc open
, ITclose_prag <- unLoc close
- = map (cL (getLoc open)) ["-#include",removeSpaces str] ++
+ = map (L (getLoc open)) ["-#include",removeSpaces str] ++
parseToks xs
parseToks (open:close:xs)
| ITdocOptions str <- unLoc open
, ITclose_prag <- unLoc close
- = map (cL (getLoc open)) ["-haddock-opts", removeSpaces str]
+ = map (L (getLoc open)) ["-haddock-opts", removeSpaces str]
++ parseToks xs
parseToks (open:xs)
| ITlanguage_prag <- unLoc open
@@ -263,12 +262,12 @@ getOptions' dflags toks
| isComment (unLoc comment)
= parseToks xs
parseToks _ = []
- parseLanguage ((dL->L loc (ITconid fs)):rest)
- = checkExtension dflags (cL loc fs) :
+ parseLanguage ((L loc (ITconid fs)):rest)
+ = checkExtension dflags (L loc fs) :
case rest of
- (dL->L _loc ITcomma):more -> parseLanguage more
- (dL->L _loc ITclose_prag):more -> parseToks more
- (dL->L loc _):_ -> languagePragParseError dflags loc
+ (L _loc ITcomma):more -> parseLanguage more
+ (L _loc ITclose_prag):more -> parseToks more
+ (L loc _):_ -> languagePragParseError dflags loc
[] -> panic "getOptions'.parseLanguage(1) went past eof token"
parseLanguage (tok:_)
= languagePragParseError dflags (getLoc tok)
@@ -296,7 +295,7 @@ checkProcessArgsResult :: MonadIO m => DynFlags -> [Located String] -> m ()
checkProcessArgsResult dflags flags
= when (notNull flags) $
liftIO $ throwIO $ mkSrcErr $ listToBag $ map mkMsg flags
- where mkMsg (dL->L loc flag)
+ where mkMsg (L loc flag)
= mkPlainErrMsg dflags loc $
(text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+>
text flag)
@@ -304,11 +303,11 @@ checkProcessArgsResult dflags flags
-----------------------------------------------------------------------------
checkExtension :: DynFlags -> Located FastString -> Located String
-checkExtension dflags (dL->L l ext)
+checkExtension dflags (L l ext)
-- Checks if a given extension is valid, and if so returns
-- its corresponding flag. Otherwise it throws an exception.
= if ext' `elem` supported
- then cL l ("-X"++ext')
+ then L l ("-X"++ext')
else unsupportedExtnError dflags l ext'
where
ext' = unpackFS ext
@@ -336,11 +335,11 @@ optionsErrorMsgs :: DynFlags -> [String] -> [Located String] -> FilePath -> Mess
optionsErrorMsgs dflags unhandled_flags flags_lines _filename
= (emptyBag, listToBag (map mkMsg unhandled_flags_lines))
where unhandled_flags_lines :: [Located String]
- unhandled_flags_lines = [ cL l f
+ unhandled_flags_lines = [ L l f
| f <- unhandled_flags
- , (dL->L l f') <- flags_lines
+ , L l f' <- flags_lines
, f == f' ]
- mkMsg (dL->L flagSpan flag) =
+ mkMsg (L flagSpan flag) =
ErrUtils.mkPlainErrMsg dflags flagSpan $
text "unknown flag in {-# OPTIONS_GHC #-} pragma:" <+> text flag
diff --git a/compiler/main/HscMain.hs b/compiler/main/HscMain.hs
index 3d2ac983a4..9daecdb550 100644
--- a/compiler/main/HscMain.hs
+++ b/compiler/main/HscMain.hs
@@ -727,7 +727,7 @@ hscIncrementalCompile :: Bool
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
- -> IO (HscStatus, ModDetails, DynFlags)
+ -> IO (HscStatus, DynFlags)
hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
mHscMessage hsc_env' mod_summary source_modified mb_old_iface mod_index
= do
@@ -768,14 +768,14 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
-- in make mode, since this HMI will go into the HPT.
details <- genModDetails hsc_env' iface
return details
- return (HscUpToDate iface, details, dflags)
+ return (HscUpToDate iface details, dflags)
-- We finished type checking. (mb_old_hash is the hash of
-- the interface that existed on disk; it's possible we had
-- to retypecheck but the resulting interface is exactly
-- the same.)
Right (FrontendTypecheck tc_result, mb_old_hash) -> do
- (status, mb_old_hash) <- finish mod_summary tc_result mb_old_hash
- return (status, mb_old_hash, dflags)
+ status <- finish mod_summary tc_result mb_old_hash
+ return (status, dflags)
-- Runs the post-typechecking frontend (desugar and simplify). We want to
-- generate most of the interface as late as possible. This gets us up-to-date
@@ -792,7 +792,7 @@ hscIncrementalCompile always_do_basic_recompilation_check m_tc_result
finish :: ModSummary
-> TcGblEnv
-> Maybe Fingerprint
- -> Hsc (HscStatus, ModDetails)
+ -> Hsc HscStatus
finish summary tc_result mb_old_hash = do
hsc_env <- getHscEnv
let dflags = hsc_dflags hsc_env
@@ -800,20 +800,18 @@ finish summary tc_result mb_old_hash = do
hsc_src = ms_hsc_src summary
should_desugar =
ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
- mk_simple_iface :: Hsc (HscStatus, ModDetails)
+ mk_simple_iface :: Hsc HscStatus
mk_simple_iface = do
(iface, mb_old_iface_hash, details) <- liftIO $
hscSimpleIface hsc_env tc_result mb_old_hash
liftIO $ hscMaybeWriteIface dflags iface mb_old_iface_hash (ms_location summary)
- let hsc_status =
- case (target, hsc_src) of
- (HscNothing, _) -> HscNotGeneratingCode iface
- (_, HsBootFile) -> HscUpdateBoot iface
- (_, HsigFile) -> HscUpdateSig iface
- _ -> panic "finish"
- return (hsc_status, details)
+ return $ case (target, hsc_src) of
+ (HscNothing, _) -> HscNotGeneratingCode iface details
+ (_, HsBootFile) -> HscUpdateBoot iface details
+ (_, HsigFile) -> HscUpdateSig iface details
+ _ -> panic "finish"
if should_desugar
then do
@@ -839,12 +837,12 @@ finish summary tc_result mb_old_hash = do
-- See Note [Avoiding space leaks in toIface*] for details.
force (mkPartialIface hsc_env details desugared_guts)
- return ( HscRecomp { hscs_guts = cg_guts,
- hscs_mod_location = ms_location summary,
- hscs_partial_iface = partial_iface,
- hscs_old_iface_hash = mb_old_hash,
- hscs_iface_dflags = dflags },
- details )
+ return HscRecomp { hscs_guts = cg_guts,
+ hscs_mod_location = ms_location summary,
+ hscs_mod_details = details,
+ hscs_partial_iface = partial_iface,
+ hscs_old_iface_hash = mb_old_hash,
+ hscs_iface_dflags = dflags }
else mk_simple_iface
diff --git a/compiler/main/HscStats.hs b/compiler/main/HscStats.hs
index 27f192227f..a5072a7690 100644
--- a/compiler/main/HscStats.hs
+++ b/compiler/main/HscStats.hs
@@ -22,7 +22,7 @@ import Data.Char
-- | Source Statistics
ppSourceStats :: Bool -> Located (HsModule GhcPs) -> SDoc
-ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
+ppSourceStats short (L _ (HsModule _ exports imports ldecls _ _))
= (if short then hcat else vcat)
(map pp_val
[("ExportAll ", export_all), -- 1 if no export list
@@ -84,7 +84,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
default_ds = count (\ x -> case x of { DefD{} -> True; _ -> False}) decls
val_decls = [d | ValD _ d <- decls]
- real_exports = case exports of { Nothing -> []; Just (dL->L _ es) -> es }
+ real_exports = case exports of { Nothing -> []; Just (L _ es) -> es }
n_exports = length real_exports
export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True
; _ -> False})
@@ -104,7 +104,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
(inst_method_ds, method_specs, method_inlines, inst_type_ds, inst_data_ds)
= sum5 (map inst_info inst_decls)
- count_bind (PatBind { pat_lhs = (dL->L _ (VarPat{})) }) = (1,0,0)
+ count_bind (PatBind { pat_lhs = L _ (VarPat{}) }) = (1,0,0)
count_bind (PatBind {}) = (0,1,0)
count_bind (FunBind {}) = (0,1,0)
count_bind (PatSynBind {}) = (0,0,1)
@@ -119,12 +119,10 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
sig_info (ClassOpSig {}) = (0,0,0,0,1)
sig_info _ = (0,0,0,0,0)
- import_info (dL->L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
- , ideclAs = as, ideclHiding = spec }))
+ import_info (L _ (ImportDecl { ideclSafe = safe, ideclQualified = qual
+ , ideclAs = as, ideclHiding = spec }))
= add7 (1, safe_info safe, qual_info qual, as_info as, 0,0,0) (spec_info spec)
- import_info (dL->L _ (XImportDecl nec)) = noExtCon nec
- import_info _ = panic " import_info: Impossible Match"
- -- due to #15884
+ import_info (L _ (XImportDecl nec)) = noExtCon nec
safe_info False = 0
safe_info True = 1
@@ -138,7 +136,7 @@ ppSourceStats short (dL->L _ (HsModule _ exports imports ldecls _ _))
data_info (DataDecl { tcdDataDefn = HsDataDefn
{ dd_cons = cs
- , dd_derivs = (dL->L _ derivs)}})
+ , dd_derivs = L _ derivs}})
= ( length cs
, foldl' (\s dc -> length (deriv_clause_tys $ unLoc dc) + s)
0 derivs )
diff --git a/compiler/main/HscTypes.hs b/compiler/main/HscTypes.hs
index 67510d851c..0ce14369fd 100644
--- a/compiler/main/HscTypes.hs
+++ b/compiler/main/HscTypes.hs
@@ -232,19 +232,20 @@ import Control.DeepSeq
-- | Status of a compilation to hard-code
data HscStatus
-- | Nothing to do.
- = HscNotGeneratingCode ModIface
+ = HscNotGeneratingCode ModIface ModDetails
-- | Nothing to do because code already exists.
- | HscUpToDate ModIface
+ | HscUpToDate ModIface ModDetails
-- | Update boot file result.
- | HscUpdateBoot ModIface
+ | HscUpdateBoot ModIface ModDetails
-- | Generate signature file (backpack)
- | HscUpdateSig ModIface
+ | HscUpdateSig ModIface ModDetails
-- | Recompile this module.
| HscRecomp
{ hscs_guts :: CgGuts
-- ^ Information for the code generator.
, hscs_mod_location :: !ModLocation
-- ^ Module info
+ , hscs_mod_details :: !ModDetails
, hscs_partial_iface :: !PartialModIface
-- ^ Partial interface
, hscs_old_iface_hash :: !(Maybe Fingerprint)
@@ -385,7 +386,7 @@ handleFlagWarnings dflags warns = do
-- It would be nicer if warns :: [Located MsgDoc], but that
-- has circular import problems.
bag = listToBag [ mkPlainWarnMsg dflags loc (text warn)
- | Warn _ (dL->L loc warn) <- warns' ]
+ | Warn _ (L loc warn) <- warns' ]
printOrThrowWarnings dflags bag
diff --git a/compiler/main/Packages.hs b/compiler/main/Packages.hs
index baed7f5ec1..b3ee7f5e6c 100644
--- a/compiler/main/Packages.hs
+++ b/compiler/main/Packages.hs
@@ -2135,7 +2135,7 @@ isDllName dflags this_mod name
-- On Windows the hack for #8696 makes it unlinkable.
-- As the entire setup of the code from Cmm down to the RTS expects
-- the use of trampolines for the imported functions only when
- -- doing intra-package linking, e.g. refering to a symbol defined in the same
+ -- doing intra-package linking, e.g. referring to a symbol defined in the same
-- package should not use a trampoline.
-- I much rather have dynamic TH not supported than the entire Dynamic linking
-- not due to a hack.
diff --git a/compiler/main/PipelineMonad.hs b/compiler/main/PipelineMonad.hs
index bdda19ceac..a3608ac4cd 100644
--- a/compiler/main/PipelineMonad.hs
+++ b/compiler/main/PipelineMonad.hs
@@ -72,7 +72,7 @@ data PipeState = PipeState {
-- ^ additional object files resulting from compiling foreign
-- code. They come from two sources: foreign stubs, and
-- add{C,Cxx,Objc,Objcxx}File from template haskell
- iface :: Maybe ModIface
+ iface :: Maybe (ModIface, ModDetails)
-- ^ Interface generated by HscOut phase. Only available after the
-- phase runs.
}
@@ -80,7 +80,7 @@ data PipeState = PipeState {
pipeStateDynFlags :: PipeState -> DynFlags
pipeStateDynFlags = hsc_dflags . hsc_env
-pipeStateModIface :: PipeState -> Maybe ModIface
+pipeStateModIface :: PipeState -> Maybe (ModIface, ModDetails)
pipeStateModIface = iface
data PipelineOutput
@@ -118,5 +118,5 @@ setForeignOs :: [FilePath] -> CompPipeline ()
setForeignOs os = P $ \_env state ->
return (state{ foreign_os = os }, ())
-setIface :: ModIface -> CompPipeline ()
-setIface iface = P $ \_env state -> return (state{ iface = Just iface }, ())
+setIface :: ModIface -> ModDetails -> CompPipeline ()
+setIface iface details = P $ \_env state -> return (state{ iface = Just (iface, details) }, ())
diff --git a/compiler/main/SysTools/Tasks.hs b/compiler/main/SysTools/Tasks.hs
index 96a5b291da..ee6824327a 100644
--- a/compiler/main/SysTools/Tasks.hs
+++ b/compiler/main/SysTools/Tasks.hs
@@ -242,7 +242,7 @@ runLink dflags args = traceToolCommand dflags "linker" $ do
--
-- `-optl` args come at the end, so that later `-l` options
-- given there manually can fill in symbols needed by
- -- Haskell libaries coming in via `args`.
+ -- Haskell libraries coming in via `args`.
linkargs <- neededLinkArgs `fmap` getLinkerInfo dflags
let (p,args0) = pgm_l dflags
optl_args = map Option (getOpts dflags opt_l)
diff --git a/compiler/main/TidyPgm.hs b/compiler/main/TidyPgm.hs
index ae491ac02d..f087d96bca 100644
--- a/compiler/main/TidyPgm.hs
+++ b/compiler/main/TidyPgm.hs
@@ -1280,7 +1280,7 @@ So we have to *predict* the result here, which is revolting.
In particular CorePrep expands Integer and Natural literals. So in the
prediction code here we resort to applying the same expansion (cvt_literal).
-There are also numberous other ways in which we can introduce inconsistencies
+There are also numerous other ways in which we can introduce inconsistencies
between CorePrep and TidyPgm. See Note [CAFfyness inconsistencies due to eta
expansion in TidyPgm] for one such example.
diff --git a/compiler/main/ToolSettings.hs b/compiler/main/ToolSettings.hs
index 952e5869fc..82d125b5f6 100644
--- a/compiler/main/ToolSettings.hs
+++ b/compiler/main/ToolSettings.hs
@@ -9,7 +9,7 @@ import Fingerprint
-- | Settings for other executables GHC calls.
--
--- Probably should futher split down by phase, or split between
+-- Probably should further split down by phase, or split between
-- platform-specific and platform-agnostic.
data ToolSettings = ToolSettings
{ toolSettings_ldSupportsCompactUnwind :: Bool