module GHC.Driver.Main
(
newHscEnv
, newHscEnvWithHUG
, Messager, batchMsg, batchMultiMsg
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
, hscMaybeWriteIface
, hscCompileCmmFile
, hscGenHardCode
, hscInteractive
, hscRecompStatus
, hscParse
, hscTypecheckRename
, hscTypecheckAndGetWarnings
, hscDesugar
, makeSimpleDetails
, hscSimplify
, hscDesugarAndSimplify
, hscCheckSafe
, hscGetSafe
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
, hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
, hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
, hscParseModuleWithLocation
, hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
, hscParseExpr
, hscParseType
, hscCompileCoreExpr
, hscTidy
, hscCompileCoreExpr'
, hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen
, getHscEnv
, hscSimpleIface'
, oneShotMsg
, dumpIfaceStats
, ioMsgMaybe
, showModuleIndex
, hscAddSptEntries
, writeInterfaceOnlyMode
) where
import GHC.Prelude
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.CodeOutput
import GHC.Driver.Config.Logger (initLogFlags)
import GHC.Driver.Config.Parser (initParserOpts)
import GHC.Driver.Config.Stg.Ppr (initStgPprOpts)
import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)
import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Tidy
import GHC.Driver.Hooks
import GHC.Runtime.Context
import GHC.Runtime.Interpreter ( addSptEntry )
import GHC.Runtime.Loader ( initializePlugins )
import GHCi.RemoteTypes ( ForeignHValue )
import GHC.ByteCode.Types
import GHC.Linker.Loader
import GHC.Linker.Types
import GHC.Hs
import GHC.Hs.Dump
import GHC.Hs.Stats ( ppSourceStats )
import GHC.HsToCore
import GHC.StgToByteCode ( byteCodeGen )
import GHC.IfaceToCore ( typecheckIface )
import GHC.Iface.Load ( ifaceStats, writeIface )
import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
import GHC.Iface.Ext.Ast ( mkHieFile )
import GHC.Iface.Ext.Types ( getAsts, hie_asts, hie_module )
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
import GHC.Core
import GHC.Core.Tidy ( tidyExpr )
import GHC.Core.Type ( Type, Kind )
import GHC.Core.Lint ( lintInteractiveExpr, endPassIO )
import GHC.Core.Multiplicity
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike
import GHC.Core.Opt.Monad ( CoreToDo (..))
import GHC.Core.Opt.Pipeline
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Core.Rules
import GHC.Core.Stats
import GHC.Core.LateCC (addLateCostCentresPgm)
import GHC.CoreToStg.Prep
import GHC.CoreToStg ( coreToStg )
import GHC.Parser.Errors.Types
import GHC.Parser
import GHC.Parser.Lexer as Lexer
import GHC.Tc.Module
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk ( ZonkFlexi (DefaultFlexi) )
import GHC.Stg.Syntax
import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )
import GHC.Builtin.Utils
import GHC.Builtin.Names
import GHC.Builtin.Uniques ( mkPseudoUniqueE )
import qualified GHC.StgToCmm as StgToCmm ( codeGen )
import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
import GHC.Cmm
import GHC.Cmm.Parser ( parseCmmFile )
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.External
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Module.Status
import GHC.Unit.Home.ModInfo
import GHC.Types.Id
import GHC.Types.SourceError
import GHC.Types.SafeHaskell
import GHC.Types.ForeignStubs
import GHC.Types.Var.Env ( emptyTidyEnv )
import GHC.Types.Error
import GHC.Types.Fixity.Env
import GHC.Types.CostCentre
import GHC.Types.IPE
import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Cache ( initNameCache )
import GHC.Types.Name.Reader
import GHC.Types.Name.Ppr
import GHC.Types.TyThing
import GHC.Types.HpcInfo
import GHC.Utils.Fingerprint ( Fingerprint )
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Utils.TmpFs
import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
import qualified GHC.SysTools
import Data.Data hiding (Fixity, TyCon)
import Data.List ( nub, isPrefixOf, partition )
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Set as S
import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
import Data.Bifunctor (first)
import GHC.Data.Maybe
import GHC.Driver.Env.KnotVars
import GHC.Types.Name.Set (NonCaffySet)
import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)
import Data.List.NonEmpty (NonEmpty ((:|)))
import GHC.Stg.InferTags.TagSig (seqTagSig)
import GHC.Types.Unique.FM
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv dflags = newHscEnvWithHUG dflags (homeUnitId_ dflags) home_unit_graph
where
home_unit_graph = unitEnv_singleton
(homeUnitId_ dflags)
(mkHomeUnitEnv dflags emptyHomePackageTable Nothing)
newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG top_dynflags cur_unit home_unit_graph = do
nc_var <- initNameCache 'r' knownKeyNames
fc_var <- initFinderCache
logger <- initLogger
tmpfs <- initTmpFs
let dflags = homeUnitEnv_dflags $ unitEnv_lookup cur_unit home_unit_graph
unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)
return HscEnv { hsc_dflags = top_dynflags
, hsc_logger = setLogFlags logger (initLogFlags top_dynflags)
, hsc_targets = []
, hsc_mod_graph = emptyMG
, hsc_IC = emptyInteractiveContext dflags
, hsc_NC = nc_var
, hsc_FC = fc_var
, hsc_type_env_vars = emptyKnotVars
, hsc_interp = Nothing
, hsc_unit_env = unit_env
, hsc_plugins = emptyPlugins
, hsc_hooks = emptyHooks
, hsc_tmpfs = tmpfs
}
getDiagnostics :: Hsc (Messages GhcMessage)
getDiagnostics = Hsc $ \_ w -> return (w, w)
clearDiagnostics :: Hsc ()
clearDiagnostics = Hsc $ \_ _ -> return ((), emptyMessages)
logDiagnostics :: Messages GhcMessage -> Hsc ()
logDiagnostics w = Hsc $ \_ w0 -> return ((), w0 `unionMessages` w)
getHscEnv :: Hsc HscEnv
getHscEnv = Hsc $ \e w -> return (e, w)
handleWarnings :: Hsc ()
handleWarnings = do
diag_opts <- initDiagOpts <$> getDynFlags
logger <- getLogger
w <- getDiagnostics
liftIO $ printOrThrowDiagnostics logger diag_opts w
clearDiagnostics
logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()
logWarningsReportErrors (warnings,errors) = do
logDiagnostics (GhcPsMessage <$> warnings)
when (not $ isEmptyMessages errors) $ throwErrors (GhcPsMessage <$> errors)
handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a
handleWarningsThrowErrors (warnings, errors) = do
diag_opts <- initDiagOpts <$> getDynFlags
logDiagnostics (GhcPsMessage <$> warnings)
logger <- getLogger
let (wWarns, wErrs) = partitionMessages warnings
liftIO $ printMessages logger diag_opts wWarns
throwErrors $ fmap GhcPsMessage $ errors `unionMessages` wErrs
ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe ioA = do
(msgs, mb_r) <- liftIO ioA
let (warns, errs) = partitionMessages msgs
logDiagnostics warns
case mb_r of
Nothing -> throwErrors errs
Just r -> assert (isEmptyMessages errs ) return r
ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' ioA = do
(msgs, mb_r) <- liftIO $ ioA
logDiagnostics (mkMessages $ getWarningMessages msgs)
return mb_r
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
hscTcRnLookupRdrName hsc_env0 rdr_name
= runInteractiveHsc hsc_env0 $
do { hsc_env <- getHscEnv
; ioMsgMaybe $ hoistTcRnMessage $ tcRnLookupRdrName hsc_env rdr_name }
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName hsc_env0 name = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env name
hscTcRnGetInfo :: HscEnv -> Name
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo hsc_env0 name
= runInteractiveHsc hsc_env0 $
do { hsc_env <- getHscEnv
; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name }
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad hsc_env name
= runHsc hsc_env $ ioMsgMaybe $ hoistTcRnMessage $ isGHCiMonad hsc_env name
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface hsc_env0 mod = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env mod
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls hsc_env0 import_decls = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env import_decls
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse hsc_env mod_summary = runHsc hsc_env $ hscParse' mod_summary
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' mod_summary
| Just r <- ms_parsed_mod mod_summary = return r
| otherwise = do
dflags <- getDynFlags
logger <- getLogger
withTiming logger
(text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
(const ()) $ do
let src_filename = ms_hspp_file mod_summary
maybe_src_buf = ms_hspp_buf mod_summary
buf <- case maybe_src_buf of
Just b -> return b
Nothing -> liftIO $ hGetStringBuffer src_filename
let loc = mkRealSrcLoc (mkFastString src_filename) 1 1
let diag_opts = initDiagOpts dflags
when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do
case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of
Nothing -> pure ()
Just chars@((eloc,chr,_) :| _) ->
let span = mkSrcSpanPs $ mkPsSpan eloc (advancePsLoc eloc chr)
in logDiagnostics $ singleMessage $
mkPlainMsgEnvelope diag_opts span $
GhcPsMessage $ PsWarnBidirectionalFormatChars chars
let parseMod | HsigFile == ms_hsc_src mod_summary
= parseSignature
| otherwise = parseModule
case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
handleWarningsThrowErrors (getPsMessages pst)
POk pst rdr_module -> do
liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"
FormatHaskell (ppr rdr_module)
liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"
FormatHaskell (showAstData NoBlankSrcSpan
NoBlankEpAnnotations
rdr_module)
liftIO $ putDumpFileMaybe logger Opt_D_source_stats "Source Statistics"
FormatText (ppSourceStats False rdr_module)
let n_hspp = FilePath.normalise src_filename
TempDir tmp_dir = tmpDir dflags
srcs0 = nub $ filter (not . (tmp_dir `isPrefixOf`))
$ filter (not . (== n_hspp))
$ map FilePath.normalise
$ filter (not . isPrefixOf "<")
$ map unpackFS
$ srcfiles pst
srcs1 = case ml_hs_file (ms_location mod_summary) of
Just f -> filter (/= FilePath.normalise f) srcs0
Nothing -> srcs0
srcs2 <- liftIO $ filterM doesFileExist srcs1
let res = HsParsedModule {
hpm_module = rdr_module,
hpm_src_files = srcs2
}
let applyPluginAction p opts
= parsedResultAction p opts mod_summary
hsc_env <- getHscEnv
(ParsedResult transformed (PsMessages warns errs)) <-
withPlugins (hsc_plugins hsc_env) applyPluginAction
(ParsedResult res (uncurry PsMessages $ getPsMessages pst))
logDiagnostics (GhcPsMessage <$> warns)
unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)
return transformed
checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))
checkBidirectionFormatChars start_loc sb
| containsBidirectionalFormatChar sb = Just $ go start_loc sb
| otherwise = Nothing
where
go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)
go loc sb
| atEnd sb = panic "checkBidirectionFormatChars: no char found"
| otherwise = case nextChar sb of
(chr, sb)
| Just desc <- lookup chr bidirectionalFormatChars ->
(loc, chr, desc) :| go1 (advancePsLoc loc chr) sb
| otherwise -> go (advancePsLoc loc chr) sb
go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]
go1 loc sb
| atEnd sb = []
| otherwise = case nextChar sb of
(chr, sb)
| Just desc <- lookup chr bidirectionalFormatChars ->
(loc, chr, desc) : go1 (advancePsLoc loc chr) sb
| otherwise -> go1 (advancePsLoc loc chr) sb
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff mod_summary tc_result = do
let rn_info = getRenamedStuff tc_result
dflags <- getDynFlags
logger <- getLogger
liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"
FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)
when (gopt Opt_WriteHie dflags) $ do
hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
let out_file = ml_hie_file $ ms_location mod_summary
liftIO $ writeHieFile out_file hieFile
liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)
when (gopt Opt_ValidateHie dflags) $ do
hs_env <- Hsc $ \e w -> return (e, w)
liftIO $ do
case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
[] -> putMsg logger $ text "Got valid scopes"
xs -> do
putMsg logger $ text "Got invalid scopes"
mapM_ (putMsg logger) xs
file' <- readHieFile (hsc_NC hs_env) out_file
case diffFile hieFile (hie_file_result file') of
[] ->
putMsg logger $ text "Got no roundtrip errors"
xs -> do
putMsg logger $ text "Got roundtrip errors"
let logger' = updateLogFlags logger (log_set_dopt Opt_D_ppr_debug)
mapM_ (putMsg logger') xs
return rn_info
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename hsc_env mod_summary rdr_module = runHsc hsc_env $
hsc_typecheck True mod_summary (Just rdr_module)
hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, WarningMessages)
hscTypecheckAndGetWarnings hsc_env summary = runHsc' hsc_env $ do
case hscFrontendHook (hsc_hooks hsc_env) of
Nothing -> FrontendTypecheck . fst <$> hsc_typecheck False summary Nothing
Just h -> h summary
hsc_typecheck :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck keep_rn mod_summary mb_rdr_module = do
hsc_env <- getHscEnv
let hsc_src = ms_hsc_src mod_summary
dflags = hsc_dflags hsc_env
home_unit = hsc_home_unit hsc_env
outer_mod = ms_mod mod_summary
mod_name = moduleName outer_mod
outer_mod' = mkHomeModule home_unit mod_name
inner_mod = homeModuleNameInstantiation home_unit mod_name
src_filename = ms_hspp_file mod_summary
real_loc = realSrcLocSpan $ mkRealSrcLoc (mkFastString src_filename) 1 1
keep_rn' = gopt Opt_WriteHie dflags || keep_rn
massert (isHomeModule home_unit outer_mod)
tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
else
do hpm <- case mb_rdr_module of
Just hpm -> return hpm
Nothing -> hscParse' mod_summary
tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
if hsc_src == HsigFile
then do (iface, _) <- liftIO $ hscSimpleIface hsc_env tc_result0 mod_summary
ioMsgMaybe $ hoistTcRnMessage $
tcRnMergeSignatures hsc_env hpm tc_result0 iface
else return tc_result0
rn_info <- extract_renamed_stuff mod_summary tc_result
return (tc_result, rn_info)
tcRnModule' :: ModSummary -> Bool -> HsParsedModule
-> Hsc TcGblEnv
tcRnModule' sum save_rn_syntax mod = do
hsc_env <- getHscEnv
dflags <- getDynFlags
let diag_opts = initDiagOpts dflags
when (not (safeHaskellModeEnabled dflags)
&& wopt Opt_WarnMissingSafeHaskellMode dflags) $
logDiagnostics $ singleMessage $
mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $
GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum)
tcg_res <-
ioMsgMaybe $ hoistTcRnMessage $
tcRnModule hsc_env sum
save_rn_syntax mod
tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)
whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)
let allSafeOK = safeInferred dflags && tcSafeOK
if not (safeHaskellOn dflags)
|| (safeInferOn dflags && not allSafeOK)
then markUnsafeInfer tcg_res whyUnsafe
else do
tcg_res' <- hscCheckSafeImports tcg_res
safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')
when safe $
case wopt Opt_WarnSafe dflags of
True
| safeHaskell dflags == Sf_Safe -> return ()
| otherwise -> (logDiagnostics $ singleMessage $
mkPlainMsgEnvelope diag_opts (warnSafeOnLoc dflags) $
GhcDriverMessage $ DriverInferredSafeModule (tcg_mod tcg_res'))
False | safeHaskell dflags == Sf_Trustworthy &&
wopt Opt_WarnTrustworthySafe dflags ->
(logDiagnostics $ singleMessage $
mkPlainMsgEnvelope diag_opts (trustworthyOnLoc dflags) $
GhcDriverMessage $ DriverMarkedTrustworthyButInferredSafe (tcg_mod tcg_res'))
False -> return ()
return tcg_res'
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar hsc_env mod_summary tc_result =
runHsc hsc_env $ hscDesugar' (ms_location mod_summary) tc_result
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' mod_location tc_result = do
hsc_env <- getHscEnv
ioMsgMaybe $ hoistDsMessage $
deSugar hsc_env mod_location tc_result
makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails
makeSimpleDetails logger tc_result = mkBootModDetailsTc logger tc_result
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()
hscRecompStatus :: Maybe Messager
-> HscEnv
-> ModSummary
-> Maybe ModIface
-> Maybe Linkable
-> (Int,Int)
-> IO HscRecompStatus
hscRecompStatus
mHscMessage hsc_env mod_summary mb_old_iface old_linkable mod_index
= do
let
msg what = case mHscMessage of
Just hscMessage -> hscMessage hsc_env mod_index what (ModuleNode [] mod_summary)
Nothing -> return ()
recomp_if_result
<-
liftIO $ checkOldIface hsc_env mod_summary mb_old_iface
case recomp_if_result of
OutOfDateItem reason mb_checked_iface -> do
msg $ NeedsRecompile reason
return $ HscRecompNeeded $ fmap (mi_iface_hash . mi_final_exts) mb_checked_iface
UpToDateItem checked_iface -> do
let lcl_dflags = ms_hspp_opts mod_summary
case backend lcl_dflags of
NoBackend -> do
msg $ UpToDate
return $ HscUpToDate checked_iface Nothing
backend
| not (backendProducesObject backend)
, IsBoot <- isBootSummary mod_summary
-> do
msg $ UpToDate
return $ HscUpToDate checked_iface Nothing
_ -> do
recomp_linkable_result <- case () of
_ | Interpreter <- backend lcl_dflags -> do
let res = checkByteCode old_linkable
case res of
UpToDateItem _ -> pure res
_ -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary
| backendProducesObject (backend lcl_dflags) -> liftIO $ checkObjects lcl_dflags old_linkable mod_summary
| otherwise -> pprPanic "hscRecompStatus" (text $ show $ backend lcl_dflags)
case recomp_linkable_result of
UpToDateItem linkable -> do
msg $ UpToDate
return $ HscUpToDate checked_iface $ Just linkable
OutOfDateItem reason _ -> do
msg $ NeedsRecompile reason
return $ HscRecompNeeded $ Just $ mi_iface_hash $ mi_final_exts $ checked_iface
checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
checkObjects dflags mb_old_linkable summary = do
let
dt_enabled = gopt Opt_BuildDynamicToo dflags
this_mod = ms_mod summary
mb_obj_date = ms_obj_date summary
mb_dyn_obj_date = ms_dyn_obj_date summary
mb_if_date = ms_iface_date summary
obj_fn = ml_obj_file (ms_location summary)
checkDynamicObj k = if dt_enabled
then case (>=) <$> mb_dyn_obj_date <*> mb_if_date of
Just True -> k
_ -> return $ outOfDateItemBecause MissingDynObjectFile Nothing
else k
checkDynamicObj $
case (,) <$> mb_obj_date <*> mb_if_date of
Just (obj_date, if_date)
| obj_date >= if_date ->
case mb_old_linkable of
Just old_linkable
| isObjectLinkable old_linkable, linkableTime old_linkable == obj_date
-> return $ UpToDateItem old_linkable
_ -> UpToDateItem <$> findObjectLinkable this_mod obj_fn obj_date
_ -> return $ outOfDateItemBecause MissingObjectFile Nothing
checkByteCode :: Maybe Linkable -> MaybeValidated Linkable
checkByteCode mb_old_linkable =
case mb_old_linkable of
Just old_linkable
| not (isObjectLinkable old_linkable)
-> UpToDateItem old_linkable
_ -> outOfDateItemBecause MissingBytecode Nothing
initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails hsc_env mod_summary iface =
fixIO $ \details' -> do
let act hpt = addToHpt hpt (ms_mod_name mod_summary)
(HomeModInfo iface details' Nothing)
let hsc_env' = hscUpdateHPT act hsc_env
genModDetails hsc_env' iface
hscDesugarAndSimplify :: ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> Hsc HscBackendAction
hscDesugarAndSimplify summary (FrontendTypecheck tc_result) tc_warnings mb_old_hash = do
hsc_env <- getHscEnv
dflags <- getDynFlags
logger <- getLogger
let bcknd = backend dflags
hsc_src = ms_hsc_src summary
diag_opts = initDiagOpts dflags
mb_desugar <-
if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
then Just <$> hscDesugar' (ms_location summary) tc_result
else pure Nothing
w <- getDiagnostics
liftIO $ printOrThrowDiagnostics logger diag_opts (unionMessages tc_warnings w)
clearDiagnostics
case mb_desugar of
Just desugared_guts | bcknd /= NoBackend -> do
plugins <- liftIO $ readIORef (tcg_th_coreplugins tc_result)
simplified_guts <- hscSimplify' plugins desugared_guts
(cg_guts, details) <-
liftIO $ hscTidy hsc_env simplified_guts
let !partial_iface =
force (mkPartialIface hsc_env details summary simplified_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
}
_ -> do
(iface, _details) <- liftIO $
hscSimpleIface hsc_env tc_result summary
liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)
return $ HscUpdate iface
hscMaybeWriteIface
:: Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
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
write_iface dflags' iface =
let !iface_name = if dynamicNow dflags' then ml_dyn_hi_file mod_location else ml_hi_file mod_location
profile = targetProfile dflags'
in
withTiming logger
(text "WriteIface"<+>brackets (text iface_name))
(const ())
(writeIface logger profile iface_name iface)
if (write_interface || force_write_interface) then do
let change = old_iface /= Just (mi_iface_hash (mi_final_exts iface))
let dt = dynamicTooState dflags
when (logHasDumpFlag logger Opt_D_dump_if_trace) $ putMsg logger $
hang (text "Writing interface(s):") 2 $ vcat
[ text "Kind:" <+> if is_simple then text "simple" else text "full"
, text "Hash change:" <+> ppr change
, text "DynamicToo state:" <+> text (show dt)
]
if is_simple
then when change $ do
write_iface dflags iface
case dt of
DT_Dont -> return ()
DT_Dyn -> panic "Unexpected DT_Dyn state when writing simple interface"
DT_OK -> write_iface (setDynamicNow dflags) iface
else case dt of
DT_Dont | change -> write_iface dflags iface
DT_OK | change -> write_iface dflags iface
DT_Dyn -> write_iface dflags iface
_ -> return ()
when (gopt Opt_WriteHie dflags) $ do
let hie_file = ml_hie_file mod_location
whenM (doesFileExist hie_file) $
GHC.SysTools.touch logger dflags "Touching hie file" hie_file
else
forceModIface iface
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails hsc_env old_iface
= do
new_details <-
initIfaceLoadModule hsc_env (mi_module old_iface) (typecheckIface old_iface)
case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of
Nothing -> return ()
Just te_var -> writeIORef te_var (md_types new_details)
dumpIfaceStats hsc_env
return new_details
oneShotMsg :: Logger -> RecompileRequired -> IO ()
oneShotMsg logger recomp =
case recomp of
UpToDate -> compilationProgressMsg logger $ text "compilation IS NOT required"
NeedsRecompile _ -> return ()
batchMsg :: Messager
batchMsg = batchMsgWith (\_ _ _ _ -> empty)
batchMultiMsg :: Messager
batchMultiMsg = batchMsgWith (\_ _ _ node -> brackets (ppr (moduleGraphNodeUnitId node)))
batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager
batchMsgWith extra hsc_env_start mod_index recomp node =
case recomp of
UpToDate
| logVerbAtLeast logger 2 -> showMsg (text "Skipping") empty
| otherwise -> return ()
NeedsRecompile reason0 -> showMsg (text herald) $ case reason0 of
MustCompile -> empty
(RecompBecause reason) -> text " [" <> pprWithUnitState state (ppr reason) <> text "]"
where
herald = case node of
LinkNode {} -> "Linking"
InstantiationNode {} -> "Instantiating"
ModuleNode {} -> "Compiling"
hsc_env = hscSetActiveUnitId (moduleGraphNodeUnitId node) hsc_env_start
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
state = hsc_units hsc_env
showMsg msg reason =
compilationProgressMsg logger $
(showModuleIndex mod_index <>
msg <+> showModMsg dflags (recompileRequired recomp) node)
<> extra hsc_env mod_index recomp node
<> reason
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports tcg_env = do
dflags <- getDynFlags
tcg_env' <- checkSafeImports tcg_env
checkRULES dflags tcg_env'
where
checkRULES dflags tcg_env' =
let diag_opts = initDiagOpts dflags
in case safeLanguageOn dflags of
True -> do
logDiagnostics $ fmap GhcDriverMessage $ warns diag_opts (tcg_rules tcg_env')
return tcg_env' { tcg_rules = [] }
False
| safeInferOn dflags && not (null $ tcg_rules tcg_env')
-> markUnsafeInfer tcg_env' $ warns diag_opts (tcg_rules tcg_env')
| otherwise
-> return tcg_env'
warns diag_opts rules = mkMessages $ listToBag $ map (warnRules diag_opts) rules
warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules diag_opts (L loc rule) =
mkPlainMsgEnvelope diag_opts (locA loc) $ DriverUserDefinedRuleIgnored rule
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports tcg_env
= do
dflags <- getDynFlags
imps <- mapM condense imports'
let (safeImps, regImps) = partition (\(_,_,s) -> s) imps
oldErrs <- getDiagnostics
clearDiagnostics
safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
safeErrs <- getDiagnostics
clearDiagnostics
(infErrs, infPkgs) <- case (safeInferOn dflags) of
False -> return (emptyMessages, S.empty)
True -> do infPkgs <- S.fromList <$> mapMaybeM checkSafe regImps
infErrs <- getDiagnostics
clearDiagnostics
return (infErrs, infPkgs)
logDiagnostics oldErrs
diag_opts <- initDiagOpts <$> getDynFlags
logger <- getLogger
liftIO $ printOrThrowDiagnostics logger diag_opts safeErrs
let infPassed = isEmptyMessages infErrs
tcg_env' <- case (not infPassed) of
True -> markUnsafeInfer tcg_env infErrs
False -> return tcg_env
when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
let newTrust = pkgTrustReqs dflags safePkgs infPkgs infPassed
return tcg_env' { tcg_imports = impInfo `plusImportAvails` newTrust }
where
impInfo = tcg_imports tcg_env
imports = imp_mods impInfo
imports1 = moduleEnvToList imports
imports' = map (fmap importedByUser) imports1
pkgReqs = imp_trust_pkgs impInfo
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense (_, []) = panic "GHC.Driver.Main.condense: Pattern match failure!"
condense (m, x:xs) = do imv <- foldlM cond' x xs
return (m, imv_span imv, imv_is_safe imv)
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' v1 v2
| imv_is_safe v1 /= imv_is_safe v2
= throwOneError $
mkPlainErrorMsgEnvelope (imv_span v1) $
GhcDriverMessage $ DriverMixedSafetyImport (imv_name v1)
| otherwise
= return v1
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe (m, l, _) = fst `fmap` hscCheckSafe' m l
pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->
Bool -> ImportAvails
pkgTrustReqs dflags req inf infPassed | safeInferOn dflags
&& not (safeHaskellModeEnabled dflags) && infPassed
= emptyImportAvails {
imp_trust_pkgs = req `S.union` inf
}
pkgTrustReqs dflags _ _ _ | safeHaskell dflags == Sf_Unsafe
= emptyImportAvails
pkgTrustReqs _ req _ _ = emptyImportAvails { imp_trust_pkgs = req }
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe hsc_env m l = runHsc hsc_env $ do
dflags <- getDynFlags
pkgs <- snd `fmap` hscCheckSafe' m l
when (packageTrustOn dflags) $ checkPkgTrust pkgs
errs <- getDiagnostics
return $ isEmptyMessages errs
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe hsc_env m l = runHsc hsc_env $ do
(self, pkgs) <- hscCheckSafe' m l
good <- isEmptyMessages `fmap` getDiagnostics
clearDiagnostics
let pkgs' | Just p <- self = S.insert p pkgs
| otherwise = pkgs
return (good, pkgs')
hscCheckSafe' :: Module -> SrcSpan
-> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' m l = do
hsc_env <- getHscEnv
let home_unit = hsc_home_unit hsc_env
(tw, pkgs) <- isModSafe home_unit m l
case tw of
False -> return (Nothing, pkgs)
True | isHomeModule home_unit m -> return (Nothing, pkgs)
| otherwise -> return (Just $ toUnitId (moduleUnit m), pkgs)
where
isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe home_unit m l = do
hsc_env <- getHscEnv
dflags <- getDynFlags
iface <- lookup' m
let diag_opts = initDiagOpts dflags
case iface of
Nothing -> throwOneError $
mkPlainErrorMsgEnvelope l $
GhcDriverMessage $ DriverCannotLoadInterfaceFile m
Just iface' ->
let trust = getSafeMode $ mi_trust iface'
trust_own_pkg = mi_trust_pkg iface'
safeM = trust `elem` [Sf_Safe, Sf_SafeInferred, Sf_Trustworthy]
safeP = packageTrusted dflags (hsc_units hsc_env) home_unit trust trust_own_pkg m
pkgRs = dep_trusted_pkgs $ mi_deps iface'
warns = if wopt Opt_WarnInferredSafeImports dflags
&& safeLanguageOn dflags
&& trust == Sf_SafeInferred
then inferredImportWarn diag_opts
else emptyMessages
errs = case (safeM, safeP) of
(True, True ) -> emptyMessages
(True, False) -> pkgTrustErr
(False, _ ) -> modTrustErr
in do
logDiagnostics warns
logDiagnostics errs
return (trust == Sf_Trustworthy, pkgRs)
where
state = hsc_units hsc_env
inferredImportWarn diag_opts = singleMessage
$ mkMsgEnvelope diag_opts l (pkgQual state)
$ GhcDriverMessage $ DriverInferredSafeImport m
pkgTrustErr = singleMessage
$ mkErrorMsgEnvelope l (pkgQual state)
$ GhcDriverMessage $ DriverCannotImportFromUntrustedPackage state m
modTrustErr = singleMessage
$ mkErrorMsgEnvelope l (pkgQual state)
$ GhcDriverMessage $ DriverCannotImportUnsafeModule m
packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted dflags unit_state home_unit safe_mode trust_own_pkg mod =
case safe_mode of
Sf_None -> False
Sf_Ignore -> False
Sf_Unsafe -> False
_ | not (packageTrustOn dflags) -> True
Sf_Safe | not trust_own_pkg -> True
Sf_SafeInferred | not trust_own_pkg -> True
_ | isHomeModule home_unit mod -> True
_ -> unitIsTrusted $ unsafeLookupUnit unit_state (moduleUnit m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' m = do
hsc_env <- getHscEnv
hsc_eps <- liftIO $ hscEPS hsc_env
let pkgIfaceT = eps_PIT hsc_eps
hug = hsc_HUG hsc_env
iface = lookupIfaceByModule hug pkgIfaceT m
case iface of
Just _ -> return iface
Nothing -> snd `fmap` (liftIO $ getModuleInterface hsc_env m)
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust pkgs = do
hsc_env <- getHscEnv
let errors = S.foldr go emptyBag pkgs
state = hsc_units hsc_env
go pkg acc
| unitIsTrusted $ unsafeLookupUnitId state pkg
= acc
| otherwise
= (`consBag` acc)
$ mkErrorMsgEnvelope noSrcSpan (pkgQual state)
$ GhcDriverMessage
$ DriverPackageNotTrusted state pkg
if isEmptyBag errors
then return ()
else liftIO $ throwErrors $ mkMessages errors
markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer tcg_env whyUnsafe = do
dflags <- getDynFlags
let reason = WarningWithFlag Opt_WarnUnsafe
let diag_opts = initDiagOpts dflags
when (diag_wopt Opt_WarnUnsafe diag_opts)
(logDiagnostics $ singleMessage $
mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $
GhcDriverMessage $ DriverUnknownMessage $
mkPlainDiagnostic reason noHints $
whyUnsafe' dflags)
liftIO $ writeIORef (tcg_safe_infer tcg_env) False
liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) emptyMessages
case not (safeHaskellModeEnabled dflags) of
True -> return $ tcg_env { tcg_imports = wiped_trust }
False -> return tcg_env
where
wiped_trust = (tcg_imports tcg_env) { imp_trust_pkgs = S.empty }
pprMod = ppr $ moduleName $ tcg_mod tcg_env
whyUnsafe' df = vcat [ quotes pprMod <+> text "has been inferred as unsafe!"
, text "Reason:"
, nest 4 $ (vcat $ badFlags df) $+$
(vcat $ pprMsgEnvelopeBagWithLoc (getMessages whyUnsafe)) $+$
(vcat $ badInsts $ tcg_insts tcg_env)
]
badFlags df = concatMap (badFlag df) unsafeFlagsForInfer
badFlag df (str,loc,on,_)
| on df = [mkLocMessage MCOutput (loc df) $
text str <+> text "is not allowed in Safe Haskell"]
| otherwise = []
badInsts insts = concatMap badInst insts
checkOverlap (NoOverlap _) = False
checkOverlap _ = True
badInst ins | checkOverlap (overlapMode (is_flag ins))
= [mkLocMessage MCOutput (nameSrcSpan $ getName $ is_dfun ins) $
ppr (overlapMode $ is_flag ins) <+>
text "overlap mode isn't allowed in Safe Haskell"]
| otherwise = []
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode tcg_env = do
dflags <- getDynFlags
liftIO $ finalSafeMode dflags tcg_env
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify hsc_env plugins modguts =
runHsc hsc_env $ hscSimplify' plugins modguts
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' plugins ds_result = do
hsc_env <- getHscEnv
hsc_env_with_plugins <- if null plugins
then return hsc_env
else liftIO $ initializePlugins
$ hscUpdateFlags (\dflags -> foldr addPluginModuleName dflags plugins)
hsc_env
liftIO $ core2core hsc_env_with_plugins ds_result
hscSimpleIface :: HscEnv
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
hscSimpleIface hsc_env tc_result summary
= runHsc hsc_env $ hscSimpleIface' tc_result summary
hscSimpleIface' :: TcGblEnv
-> ModSummary
-> Hsc (ModIface, ModDetails)
hscSimpleIface' tc_result summary = do
hsc_env <- getHscEnv
logger <- getLogger
details <- liftIO $ mkBootModDetailsTc logger tc_result
safe_mode <- hscGetSafeMode tc_result
new_iface
<-
liftIO $
mkIfaceTc hsc_env safe_mode details summary tc_result
liftIO $ dumpIfaceStats hsc_env
return (new_iface, details)
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
hscGenHardCode hsc_env cgguts location output_filename = do
let CgGuts{
cg_module = this_mod,
cg_binds = core_binds,
cg_ccs = local_ccs,
cg_tycons = tycons,
cg_foreign = foreign_stubs0,
cg_foreign_files = foreign_files,
cg_dep_pkgs = dependencies,
cg_hpc_info = hpc_info } = cgguts
dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
tmpfs = hsc_tmpfs hsc_env
profile = targetProfile dflags
data_tycons = filter isDataTyCon tycons
(late_cc_binds, late_local_ccs) <-
if gopt Opt_ProfLateCcs dflags && not (gopt Opt_ProfLateInlineCcs dflags)
then do
(binds,late_ccs) <- addLateCostCentresPgm dflags logger this_mod core_binds
return ( binds, (S.toList late_ccs `mappend` local_ccs ))
else
return (core_binds, local_ccs)
(prepd_binds) <-
corePrepPgm hsc_env this_mod location
late_cc_binds data_tycons
(stg_binds, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
<-
withTiming logger
(text "CoreToStg"<+>brackets (ppr this_mod))
(\(a, b, (c,d), tag_env) ->
a `seqList`
b `seq`
c `seqList`
d `seqList`
(seqEltsUFM (seqTagSig) tag_env))
(myCoreToStg logger dflags (hsc_IC hsc_env) False this_mod location prepd_binds)
let cost_centre_info =
(late_local_ccs ++ caf_ccs, caf_cc_stacks)
platform = targetPlatform dflags
prof_init
| sccProfilingEnabled dflags = profilingInitCode platform this_mod cost_centre_info
| otherwise = mempty
withTiming logger
(text "CodeGen"<+>brackets (ppr this_mod))
(const ()) $ do
cmms <-
doCodeGen hsc_env this_mod denv data_tycons
cost_centre_info
stg_binds hpc_info
rawcmms0 <-
case cmmToRawCmmHook hooks of
Nothing -> cmmToRawCmm logger profile cmms
Just h -> h dflags (Just this_mod) cmms
let dump a = do
unless (null a) $
putDumpFileMaybe logger Opt_D_dump_cmm_raw "Raw Cmm" FormatCMM (pdoc platform a)
return a
rawcmms1 = Stream.mapM dump rawcmms0
let foreign_stubs st = foreign_stubs0 `appendStubC` prof_init
`appendStubC` cgIPEStub st
(output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)
<-
codeOutput logger tmpfs dflags (hsc_units hsc_env) this_mod output_filename location
foreign_stubs foreign_files dependencies rawcmms1
return ( output_filename, stub_c_exists, foreign_fps
, Just stg_cg_infos, Just cmm_cg_infos)
hscInteractive :: HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive hsc_env cgguts location = do
let dflags = hsc_dflags hsc_env
let logger = hsc_logger hsc_env
let tmpfs = hsc_tmpfs hsc_env
let CgGuts{
cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_foreign = foreign_stubs,
cg_modBreaks = mod_breaks,
cg_spt_entries = spt_entries } = cgguts
data_tycons = filter isDataTyCon tycons
prepd_binds <-
corePrepPgm hsc_env this_mod location core_binds data_tycons
(stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)
<-
myCoreToStg logger dflags (hsc_IC hsc_env) True this_mod location prepd_binds
comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks
(_istub_h_exists, istub_c_exists)
<- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs
return (istub_c_exists, comp_bc, spt_entries)
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
hscCompileCmmFile hsc_env original_filename filename output_filename = runHsc hsc_env $ do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
tmpfs = hsc_tmpfs hsc_env
profile = targetProfile dflags
home_unit = hsc_home_unit hsc_env
platform = targetPlatform dflags
do_info_table = gopt Opt_InfoTableMap dflags
mod_name = mkModuleName $ "Cmm$" ++ original_filename
cmm_mod = mkHomeModule home_unit mod_name
(cmm, ipe_ents) <- ioMsgMaybe
$ do
(warns,errs,cmm) <- withTiming logger (text "ParseCmm"<+>brackets (text filename)) (\_ -> ())
$ parseCmmFile dflags cmm_mod home_unit filename
let msgs = warns `unionMessages` errs
return (GhcPsMessage <$> msgs, cmm)
liftIO $ do
putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform cmm)
cmmgroup <-
concatMapM (\cmm -> snd <$> cmmPipeline hsc_env (emptySRT cmm_mod) [cmm]) cmm
unless (null cmmgroup) $
putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"
FormatCMM (pdoc platform cmmgroup)
rawCmms <- case cmmToRawCmmHook hooks of
Nothing -> cmmToRawCmm logger profile (Stream.yield cmmgroup)
Just h -> h dflags Nothing (Stream.yield cmmgroup)
let foreign_stubs _
| not $ null ipe_ents =
let ip_init = ipInitCode do_info_table platform cmm_mod
in NoStubs `appendStubC` ip_init
| otherwise = NoStubs
(_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
<- codeOutput logger tmpfs dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
rawCmms
return stub_c_exists
where
no_loc = ModLocation{ ml_hs_file = Just filename,
ml_hi_file = panic "hscCompileCmmFile: no hi file",
ml_obj_file = panic "hscCompileCmmFile: no obj file",
ml_dyn_obj_file = panic "hscCompileCmmFile: no dyn obj file",
ml_dyn_hi_file = panic "hscCompileCmmFile: no dyn obj file",
ml_hie_file = panic "hscCompileCmmFile: no hie file"}
doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroupSRTs CmmCgInfos)
doCodeGen hsc_env this_mod denv data_tycons
cost_centre_info stg_binds_w_fvs hpc_info = do
let dflags = hsc_dflags hsc_env
logger = hsc_logger hsc_env
hooks = hsc_hooks hsc_env
tmpfs = hsc_tmpfs hsc_env
platform = targetPlatform dflags
stg_ppr_opts = (initStgPprOpts dflags)
putDumpFileMaybe logger Opt_D_dump_stg_final "Final STG:" FormatSTG
(pprGenStgTopBindings stg_ppr_opts stg_binds_w_fvs)
let stg_to_cmm dflags mod = case stgToCmmHook hooks of
Nothing -> StgToCmm.codeGen logger tmpfs (initStgToCmmConfig dflags mod)
Just h -> h (initStgToCmmConfig dflags mod)
let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
cmm_stream = stg_binds_w_fvs `seqList`
stg_to_cmm dflags this_mod denv data_tycons cost_centre_info stg_binds_w_fvs hpc_info
let dump1 a = do
unless (null a) $
putDumpFileMaybe logger Opt_D_dump_cmm_from_stg
"Cmm produced by codegen" FormatCMM (pdoc platform a)
return a
ppr_stream1 = Stream.mapM dump1 cmm_stream
pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
pipeline_stream = do
(non_cafs, lf_infos) <-
Stream.mapAccumL_ (cmmPipeline hsc_env) (emptySRT this_mod) ppr_stream1
<&> first (srtMapNonCAFs . moduleSRTMap)
return (non_cafs, lf_infos)
dump2 a = do
unless (null a) $
putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm" FormatCMM (pdoc platform a)
return a
return $ Stream.mapM dump2 $ generateCgIPEStub hsc_env this_mod denv pipeline_stream
myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
-> Bool
-> Module -> ModLocation -> CoreExpr
-> IO ( Id
, [CgStgTopBinding]
, InfoTableProvMap
, CollectedCCs
, StgCgInfos )
myCoreToStgExpr logger dflags ictxt for_bytecode this_mod ml prepd_expr = do
let bco_tmp_id = mkSysLocal (fsLit "BCO_toplevel")
(mkPseudoUniqueE 0)
Many
(exprType prepd_expr)
(stg_binds, prov_map, collected_ccs, stg_cg_infos) <-
myCoreToStg logger
dflags
ictxt
for_bytecode
this_mod
ml
[NonRec bco_tmp_id prepd_expr]
return (bco_tmp_id, stg_binds, prov_map, collected_ccs, stg_cg_infos)
myCoreToStg :: Logger -> DynFlags -> InteractiveContext
-> Bool
-> Module -> ModLocation -> CoreProgram
-> IO ( [CgStgTopBinding]
, InfoTableProvMap
, CollectedCCs
, StgCgInfos )
myCoreToStg logger dflags ictxt for_bytecode this_mod ml prepd_binds = do
let (stg_binds, denv, cost_centre_info)
=
coreToStg dflags this_mod ml prepd_binds
(stg_binds_with_fvs,stg_cg_info)
<-
stg2stg logger ictxt (initStgPipelineOpts dflags for_bytecode)
this_mod stg_binds
putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG
(pprGenStgTopBindings (initStgPprOpts dflags) stg_binds_with_fvs)
return (stg_binds_with_fvs, denv, cost_centre_info, stg_cg_info)
hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmt hsc_env stmt = hscStmtWithLocation hsc_env stmt "<interactive>" 1
hscStmtWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscStmtWithLocation hsc_env0 stmt source linenumber =
runInteractiveHsc hsc_env0 $ do
maybe_stmt <- hscParseStmtWithLocation source linenumber stmt
case maybe_stmt of
Nothing -> return Nothing
Just parsed_stmt -> do
hsc_env <- getHscEnv
liftIO $ hscParsedStmt hsc_env parsed_stmt
hscParsedStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscParsedStmt hsc_env stmt = runInteractiveHsc hsc_env $ do
(ids, tc_expr, fix_env) <- ioMsgMaybe $ hoistTcRnMessage $ tcRnStmt hsc_env stmt
ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr
liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)
handleWarnings
let src_span = srcLocSpan interactiveSrcLoc
(hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr
return $ Just (ids, hval, fix_env)
hscDecls :: HscEnv
-> String
-> IO ([TyThing], InteractiveContext)
hscDecls hsc_env str = hscDeclsWithLocation hsc_env str "<interactive>" 1
hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO HsModule
hscParseModuleWithLocation hsc_env source line_num str = do
L _ mod <-
runInteractiveHsc hsc_env $
hscParseThingWithLocation source line_num parseModule str
return mod
hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation hsc_env source line_num str = do
HsModule { hsmodDecls = decls } <- hscParseModuleWithLocation hsc_env source line_num str
return decls
hscDeclsWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation hsc_env str source linenumber = do
L _ (HsModule{ hsmodDecls = decls }) <-
runInteractiveHsc hsc_env $
hscParseThingWithLocation source linenumber parseModule str
hscParsedDecls hsc_env decls
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls hsc_env decls = runInteractiveHsc hsc_env $ do
hsc_env <- getHscEnv
let interp = hscInterp hsc_env
tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env decls
let defaults = tcg_default tc_gblenv
let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
ml_hi_file = panic "hsDeclsWithLocation:ml_hi_file",
ml_obj_file = panic "hsDeclsWithLocation:ml_obj_file",
ml_dyn_obj_file = panic "hsDeclsWithLocation:ml_dyn_obj_file",
ml_dyn_hi_file = panic "hsDeclsWithLocation:ml_dyn_hi_file",
ml_hie_file = panic "hsDeclsWithLocation:ml_hie_file" }
ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv
simpl_mg <- liftIO $ do
plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
hscSimplify hsc_env plugins ds_result
(tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg
let !CgGuts{ cg_module = this_mod,
cg_binds = core_binds,
cg_tycons = tycons,
cg_modBreaks = mod_breaks } = tidy_cg
!ModDetails { md_insts = cls_insts
, md_fam_insts = fam_insts } = mod_details
data_tycons = filter isDataTyCon tycons
prepd_binds <-
liftIO $ corePrepPgm hsc_env this_mod iNTERACTIVELoc core_binds data_tycons
(stg_binds, _infotable_prov, _caf_ccs__caf_cc_stacks, _stg_cg_info)
<-
liftIO $ myCoreToStg (hsc_logger hsc_env)
(hsc_dflags hsc_env)
(hsc_IC hsc_env)
True
this_mod
iNTERACTIVELoc
prepd_binds
cbc <- liftIO $ byteCodeGen hsc_env this_mod
stg_binds data_tycons mod_breaks
let src_span = srcLocSpan interactiveSrcLoc
_ <- liftIO $ loadDecls interp hsc_env src_span cbc
liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)
let tcs = filterOut isImplicitTyCon (mg_tcs simpl_mg)
patsyns = mg_patsyns simpl_mg
ext_ids = [ id | id <- bindersOfBinds core_binds
, isExternalName (idName id)
, not (isDFunId id || isImplicitId id) ]
new_tythings = map AnId ext_ids ++ map ATyCon tcs ++ map (AConLike . PatSynCon) patsyns
ictxt = hsc_IC hsc_env
fix_env = tcg_fix_env tc_gblenv
new_ictxt = extendInteractiveContext ictxt new_tythings cls_insts
fam_insts defaults fix_env
return (new_tythings, new_ictxt)
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries hsc_env entries = do
let interp = hscInterp hsc_env
let add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry i fpr) = do
(val, _, _) <- loadName interp hsc_env (idName i)
addSptEntry interp fpr val
mapM_ add_spt_entry entries
hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport hsc_env str = runInteractiveHsc hsc_env $ do
(L _ (HsModule{hsmodImports=is})) <-
hscParseThing parseModule str
case is of
[L _ i] -> return i
_ -> liftIO $ throwOneError $
mkPlainErrorMsgEnvelope noSrcSpan $
GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $
text "parse error in import declaration"
hscTcExpr :: HscEnv
-> TcRnExprMode
-> String
-> IO Type
hscTcExpr hsc_env0 mode expr = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
parsed_expr <- hscParseExpr expr
ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode parsed_expr
hscKcType
:: HscEnv
-> Bool
-> String
-> IO (Type, Kind)
hscKcType hsc_env0 normalise str = runInteractiveHsc hsc_env0 $ do
hsc_env <- getHscEnv
ty <- hscParseType str
ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr expr = do
maybe_stmt <- hscParseStmt expr
case maybe_stmt of
Just (L _ (BodyStmt _ expr _ _)) -> return expr
_ -> throwOneError $
mkPlainErrorMsgEnvelope noSrcSpan $
GhcPsMessage $ PsUnknownMessage $ mkPlainError noHints $
text "not an expression:" <+> quotes (text expr)
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt = hscParseThing parseStmt
hscParseStmtWithLocation :: String -> Int -> String
-> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation source linenumber stmt =
hscParseThingWithLocation source linenumber parseStmt stmt
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType = hscParseThing parseType
hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)
hscParseIdentifier hsc_env str =
runInteractiveHsc hsc_env $ hscParseThing parseIdentifier str
hscParseThing :: (Outputable thing, Data thing)
=> Lexer.P thing -> String -> Hsc thing
hscParseThing = hscParseThingWithLocation "<interactive>" 1
hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-> Lexer.P thing -> String -> Hsc thing
hscParseThingWithLocation source linenumber parser str = do
dflags <- getDynFlags
logger <- getLogger
withTiming logger
(text "Parser [source]")
(const ()) $ do
let buf = stringToStringBuffer str
loc = mkRealSrcLoc (fsLit source) linenumber 1
case unP parser (initParserState (initParserOpts dflags) buf loc) of
PFailed pst ->
handleWarningsThrowErrors (getPsMessages pst)
POk pst thing -> do
logWarningsReportErrors (getPsMessages pst)
liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed "Parser"
FormatHaskell (ppr thing)
liftIO $ putDumpFileMaybe logger Opt_D_dump_parsed_ast "Parser AST"
FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations thing)
return thing
hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy hsc_env guts = do
let logger = hsc_logger hsc_env
let this_mod = mg_module guts
opts <- initTidyOpts hsc_env
(cgguts, details) <- withTiming logger
(text "CoreTidy"<+>brackets (ppr this_mod))
(const ())
$! tidyProgram opts guts
let tidy_rules = md_rules details
let all_tidy_binds = cg_binds cgguts
let print_unqual = mkPrintUnqualified (hsc_unit_env hsc_env) (mg_rdr_env guts)
endPassIO hsc_env print_unqual CoreTidy all_tidy_binds tidy_rules
unless (logHasDumpFlag logger Opt_D_dump_simpl) $
putDumpFileMaybe logger Opt_D_dump_rules
(renderWithContext defaultSDocContext (ppr CoreTidy <+> text "rules"))
FormatText
(pprRulesForUser tidy_rules)
let cs = coreBindsStats all_tidy_binds
putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"
FormatText
(text "Tidy size (terms,types,coercions)"
<+> ppr (moduleName this_mod) <> colon
<+> int (cs_tm cs)
<+> int (cs_ty cs)
<+> int (cs_co cs))
pure (cgguts, details)
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr hsc_env loc expr =
case hscCompileCoreExprHook (hsc_hooks hsc_env) of
Nothing -> hscCompileCoreExpr' hsc_env loc expr
Just h -> h hsc_env loc expr
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr' hsc_env srcspan ds_expr
= do {
simpl_expr <- simplifyExpr hsc_env ds_expr
; let tidy_expr = tidyExpr emptyTidyEnv simpl_expr
; prepd_expr <- corePrepExpr hsc_env tidy_expr
; lintInteractiveExpr (text "hscCompileExpr") hsc_env prepd_expr
; let iNTERACTIVELoc = ModLocation{ ml_hs_file = Nothing,
ml_hi_file = panic "hscCompileCoreExpr':ml_hi_file",
ml_obj_file = panic "hscCompileCoreExpr':ml_obj_file",
ml_dyn_obj_file = panic "hscCompileCoreExpr': ml_obj_file",
ml_dyn_hi_file = panic "hscCompileCoreExpr': ml_dyn_hi_file",
ml_hie_file = panic "hscCompileCoreExpr':ml_hie_file" }
; let ictxt = hsc_IC hsc_env
; (binding_id, stg_expr, _, _, _stg_cg_info) <-
myCoreToStgExpr (hsc_logger hsc_env)
(hsc_dflags hsc_env)
ictxt
True
(icInteractiveModule ictxt)
iNTERACTIVELoc
prepd_expr
; bcos <- byteCodeGen hsc_env
(icInteractiveModule ictxt)
stg_expr
[] Nothing
; (fv_hvs, mods_needed, units_needed) <- loadDecls (hscInterp hsc_env) hsc_env srcspan bcos
; return (expectJust "hscCompileCoreExpr'"
$ lookup (idName binding_id) fv_hvs, mods_needed, units_needed) }
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats hsc_env = do
eps <- hscEPS hsc_env
let
logger = hsc_logger hsc_env
dump_rn_stats = logHasDumpFlag logger Opt_D_dump_rn_stats
dump_if_trace = logHasDumpFlag logger Opt_D_dump_if_trace
when (dump_if_trace || dump_rn_stats) $
logDumpMsg logger "Interface statistics" (ifaceStats eps)
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex (i,n) = text "[" <> pad <> int i <> text " of " <> int n <> text "] "
where
len x = ceiling (logBase 10 (fromIntegral x+1) :: Float)
pad = text (replicate (len n len i) ' ')
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode dflags =
gopt Opt_WriteInterface dflags &&
NoBackend == backend dflags