{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE MultiWayIf #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
module GHC.Driver.Main
(
newHscEnv
, newHscEnvWithHUG
, initHscEnv
, Messager, batchMsg, batchMultiMsg
, HscBackendAction (..), HscRecompStatus (..)
, initModDetails
, initWholeCoreBindings
, hscMaybeWriteIface
, hscCompileCmmFile
, hscGenHardCode
, hscInteractive
, mkCgInteractiveGuts
, CgInteractiveGuts
, generateByteCode
, generateFreshByteCode
, 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.Platform
import GHC.Platform.Ways
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.CodeOutput
import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)
import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts )
import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )
import GHC.Driver.Config.CoreToStg
import GHC.Driver.Config.CoreToStg.Prep
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.Cmm (initCmmConfig)
import GHC.Driver.LlvmConfigCache (initLlvmConfigCache)
import GHC.Driver.Config.StgToJS (initStgToJSConfig)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Tidy
import GHC.Driver.Hooks
import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)
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.StgToJS ( stgToJS )
import GHC.IfaceToCore ( typecheckIface, typecheckWholeCoreBindings )
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.Lint.Interactive ( interactiveInScope )
import GHC.Core.Tidy ( tidyExpr )
import GHC.Core.Type ( Type, Kind )
import GHC.Core.Multiplicity
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike
import GHC.Core.Opt.Pipeline
import GHC.Core.Opt.Pipeline.Types ( CoreToDo (..))
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.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
import GHC.Cmm.Parser
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.Name.Set (NonCaffySet)
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 GHC.Data.Maybe
import qualified GHC.SysTools
import GHC.SysTools (initSysTools)
import GHC.SysTools.BaseDir (findTopDir)
import Data.Data hiding (Fixity, TyCon)
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import qualified Data.Set as S
import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
import Data.Bifunctor (first)
import Data.List.NonEmpty (NonEmpty ((:|)))
import GHC.Unit.Module.WholeCoreBindings
import GHC.Types.TypeEnv
import System.IO
import {-# SOURCE #-} GHC.Driver.Pipeline
import Data.Time
import System.IO.Unsafe ( unsafeInterleaveIO )
import GHC.Iface.Env ( trace_if )
import GHC.Stg.InferTags.TagSig (seqTagSig)
import GHC.Types.Unique.FM
newHscEnv :: FilePath -> DynFlags -> IO HscEnv
newHscEnv :: [Char] -> DynFlags -> IO HscEnv
newHscEnv [Char]
top_dir DynFlags
dflags = [Char] -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG [Char]
top_dir DynFlags
dflags (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) HomeUnitGraph
home_unit_graph
where
home_unit_graph :: HomeUnitGraph
home_unit_graph = forall v. UnitId -> v -> UnitEnvGraph v
unitEnv_singleton
(DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
(DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
mkHomeUnitEnv DynFlags
dflags HomePackageTable
emptyHomePackageTable forall a. Maybe a
Nothing)
newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG :: [Char] -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG [Char]
top_dir DynFlags
top_dynflags UnitId
cur_unit HomeUnitGraph
home_unit_graph = do
NameCache
nc_var <- Char -> [Name] -> IO NameCache
initNameCache Char
'r' [Name]
knownKeyNames
FinderCache
fc_var <- IO FinderCache
initFinderCache
Logger
logger <- IO Logger
initLogger
TmpFs
tmpfs <- IO TmpFs
initTmpFs
let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags forall a b. (a -> b) -> a -> b
$ forall v. UnitId -> UnitEnvGraph v -> v
unitEnv_lookup UnitId
cur_unit HomeUnitGraph
home_unit_graph
UnitEnv
unit_env <- UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv UnitId
cur_unit HomeUnitGraph
home_unit_graph (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Platform
targetPlatform DynFlags
dflags)
LlvmConfigCache
llvm_config <- [Char] -> IO LlvmConfigCache
initLlvmConfigCache [Char]
top_dir
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
top_dynflags
, hsc_logger :: Logger
hsc_logger = Logger -> LogFlags -> Logger
setLogFlags Logger
logger (DynFlags -> LogFlags
initLogFlags DynFlags
top_dynflags)
, hsc_targets :: [Target]
hsc_targets = []
, hsc_mod_graph :: ModuleGraph
hsc_mod_graph = ModuleGraph
emptyMG
, hsc_IC :: InteractiveContext
hsc_IC = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
, hsc_NC :: NameCache
hsc_NC = NameCache
nc_var
, hsc_FC :: FinderCache
hsc_FC = FinderCache
fc_var
, hsc_type_env_vars :: KnotVars (IORef TypeEnv)
hsc_type_env_vars = forall a. KnotVars a
emptyKnotVars
, hsc_interp :: Maybe Interp
hsc_interp = forall a. Maybe a
Nothing
, hsc_unit_env :: UnitEnv
hsc_unit_env = UnitEnv
unit_env
, hsc_plugins :: Plugins
hsc_plugins = Plugins
emptyPlugins
, hsc_hooks :: Hooks
hsc_hooks = Hooks
emptyHooks
, hsc_tmpfs :: TmpFs
hsc_tmpfs = TmpFs
tmpfs
, hsc_llvm_config :: LlvmConfigCache
hsc_llvm_config = LlvmConfigCache
llvm_config
}
initHscEnv :: Maybe FilePath -> IO HscEnv
initHscEnv :: Maybe [Char] -> IO HscEnv
initHscEnv Maybe [Char]
mb_top_dir = do
[Char]
top_dir <- Maybe [Char] -> IO [Char]
findTopDir Maybe [Char]
mb_top_dir
Settings
mySettings <- [Char] -> IO Settings
initSysTools [Char]
top_dir
DynFlags
dflags <- DynFlags -> IO DynFlags
initDynFlags (Settings -> DynFlags
defaultDynFlags Settings
mySettings)
HscEnv
hsc_env <- [Char] -> DynFlags -> IO HscEnv
newHscEnv [Char]
top_dir DynFlags
dflags
Logger -> DynFlags -> IO ()
checkBrokenTablesNextToCode (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) DynFlags
dflags
DynFlags -> IO ()
setUnsafeGlobalDynFlags DynFlags
dflags
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
checkBrokenTablesNextToCode :: Logger -> DynFlags -> IO ()
checkBrokenTablesNextToCode :: Logger -> DynFlags -> IO ()
checkBrokenTablesNextToCode Logger
logger DynFlags
dflags = do
let invalidLdErr :: [Char]
invalidLdErr = [Char]
"Tables-next-to-code not supported on ARM \
\when using binutils ld (please see: \
\https://sourceware.org/bugzilla/show_bug.cgi?id=16177)"
Bool
broken <- Logger -> DynFlags -> IO Bool
checkBrokenTablesNextToCode' Logger
logger DynFlags
dflags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
broken (forall a. HasCallStack => [Char] -> a
panic [Char]
invalidLdErr)
checkBrokenTablesNextToCode' :: Logger -> DynFlags -> IO Bool
checkBrokenTablesNextToCode' :: Logger -> DynFlags -> IO Bool
checkBrokenTablesNextToCode' Logger
logger DynFlags
dflags
| Bool -> Bool
not (Arch -> Bool
isARM Arch
arch) = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| DynFlags -> Ways
ways DynFlags
dflags Ways -> Way -> Bool
`hasNotWay` Way
WayDyn = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool -> Bool
not Bool
tablesNextToCode = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
| Bool
otherwise = do
LinkerInfo
linkerInfo <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> IO LinkerInfo
GHC.SysTools.getLinkerInfo Logger
logger DynFlags
dflags
case LinkerInfo
linkerInfo of
GnuLD [Option]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
LinkerInfo
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
where platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
arch :: Arch
arch = Platform -> Arch
platformArch Platform
platform
tablesNextToCode :: Bool
tablesNextToCode = Platform -> Bool
platformTablesNextToCode Platform
platform
getDiagnostics :: Hsc (Messages GhcMessage)
getDiagnostics :: Hsc (Messages GhcMessage)
getDiagnostics = forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (Messages GhcMessage
w, Messages GhcMessage
w)
clearDiagnostics :: Hsc ()
clearDiagnostics :: Hsc ()
clearDiagnostics = forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), forall e. Messages e
emptyMessages)
logDiagnostics :: Messages GhcMessage -> Hsc ()
logDiagnostics :: Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
w = forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
w0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), Messages GhcMessage
w0 forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages GhcMessage
w)
getHscEnv :: Hsc HscEnv
getHscEnv :: Hsc HscEnv
getHscEnv = forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
e Messages GhcMessage
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, Messages GhcMessage
w)
handleWarnings :: Hsc ()
handleWarnings :: Hsc ()
handleWarnings = do
DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
GhcMessageOpts
print_config <- DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
Messages GhcMessage
w <- Hsc (Messages GhcMessage)
getDiagnostics
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger GhcMessageOpts
print_config DiagOpts
diag_opts Messages GhcMessage
w
Hsc ()
clearDiagnostics
logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()
logWarningsReportErrors :: (Messages PsWarning, Messages PsWarning) -> Hsc ()
logWarningsReportErrors (Messages PsWarning
warnings,Messages PsWarning
errors) = do
Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warnings)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall e. Messages e -> Bool
isEmptyMessages Messages PsWarning
errors) forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
errors)
handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a
handleWarningsThrowErrors :: forall a. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (Messages PsWarning
warnings, Messages PsWarning
errors) = do
DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warnings)
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
let (Messages PsWarning
wWarns, Messages PsWarning
wErrs) = forall e. Diagnostic e => Messages e -> (Messages e, Messages e)
partitionMessages Messages PsWarning
warnings
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
Diagnostic a =>
Logger -> DiagnosticOpts a -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger NoDiagnosticOpts
NoDiagnosticOpts DiagOpts
diag_opts Messages PsWarning
wWarns
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ Messages PsWarning
errors forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages PsWarning
wErrs
ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe :: forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe IO (Messages GhcMessage, Maybe a)
ioA = do
(Messages GhcMessage
msgs, Maybe a
mb_r) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Messages GhcMessage, Maybe a)
ioA
let (Messages GhcMessage
warns, Messages GhcMessage
errs) = forall e. Diagnostic e => Messages e -> (Messages e, Messages e)
partitionMessages Messages GhcMessage
msgs
Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
warns
case Maybe a
mb_r of
Maybe a
Nothing -> forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors Messages GhcMessage
errs
Just a
r -> forall a. HasCallStack => Bool -> a -> a
assert (forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
errs ) forall (m :: * -> *) a. Monad m => a -> m a
return a
r
ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' :: forall a. IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' IO (Messages GhcMessage, Maybe a)
ioA = do
(Messages GhcMessage
msgs, Maybe a
mb_r) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe a)
ioA
Messages GhcMessage -> Hsc ()
logDiagnostics (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages Messages GhcMessage
msgs)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mb_r
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)
hscTcRnLookupRdrName HscEnv
hsc_env0 LocatedN RdrName
rdr_name
= forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$
do { HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
; forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty)) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$
HscEnv
-> LocatedN RdrName -> IO (Messages TcRnMessage, Maybe [Name])
tcRnLookupRdrName HscEnv
hsc_env LocatedN RdrName
rdr_name }
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName HscEnv
hsc_env0 Name
name = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
tcRnLookupName HscEnv
hsc_env Name
name
hscTcRnGetInfo :: HscEnv -> Name
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo :: HscEnv
-> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo HscEnv
hsc_env0 Name
name
= forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$
do { HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
; forall a. IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name
-> IO
(Messages TcRnMessage,
Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
tcRnGetInfo HscEnv
hsc_env Name
name }
hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad :: HscEnv -> [Char] -> IO Name
hscIsGHCiMonad HscEnv
hsc_env [Char]
name
= forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> [Char] -> IO (Messages TcRnMessage, Maybe Name)
isGHCiMonad HscEnv
hsc_env [Char]
name
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface HscEnv
hsc_env0 Module
mod = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
mod
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls HscEnv
hsc_env0 [LImportDecl GhcPs]
import_decls = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LImportDecl GhcPs]
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
tcRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
import_decls
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse :: HscEnv -> ModSummary -> IO HsParsedModule
hscParse HscEnv
hsc_env ModSummary
mod_summary = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
| Just HsParsedModule
r <- ModSummary -> Maybe HsParsedModule
ms_parsed_mod ModSummary
mod_summary = forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
r
| Bool
otherwise = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
{-# SCC "Parser" #-} forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(forall doc. IsLine doc => [Char] -> doc
text [Char]
"Parser"forall doc. IsLine doc => doc -> doc -> doc
<+>forall doc. IsLine doc => doc -> doc
brackets (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ ModSummary -> Module
ms_mod ModSummary
mod_summary))
(forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ do
let src_filename :: [Char]
src_filename = ModSummary -> [Char]
ms_hspp_file ModSummary
mod_summary
maybe_src_buf :: Maybe StringBuffer
maybe_src_buf = ModSummary -> Maybe StringBuffer
ms_hspp_buf ModSummary
mod_summary
StringBuffer
buf <- case Maybe StringBuffer
maybe_src_buf of
Just StringBuffer
b -> forall (m :: * -> *) a. Monad m => a -> m a
return StringBuffer
b
Maybe StringBuffer
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO StringBuffer
hGetStringBuffer [Char]
src_filename
let loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
mkFastString [Char]
src_filename) Int
1 Int
1
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnicodeBidirectionalFormatCharacters DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ do
case PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, [Char]))
checkBidirectionFormatChars (RealSrcLoc -> BufPos -> PsLoc
PsLoc RealSrcLoc
loc (Int -> BufPos
BufPos Int
0)) StringBuffer
buf of
Maybe (NonEmpty (PsLoc, Char, [Char]))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
Just chars :: NonEmpty (PsLoc, Char, [Char])
chars@((PsLoc
eloc,Char
chr,[Char]
_) :| [(PsLoc, Char, [Char])]
_) ->
let span :: SrcSpan
span = PsSpan -> SrcSpan
mkSrcSpanPs forall a b. (a -> b) -> a -> b
$ PsLoc -> PsLoc -> PsSpan
mkPsSpan PsLoc
eloc (PsLoc -> Char -> PsLoc
advancePsLoc PsLoc
eloc Char
chr)
in Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
span forall a b. (a -> b) -> a -> b
$
PsWarning -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ NonEmpty (PsLoc, Char, [Char]) -> PsWarning
PsWarnBidirectionalFormatChars NonEmpty (PsLoc, Char, [Char])
chars
let parseMod :: P (Located (HsModule GhcPs))
parseMod | HscSource
HsigFile forall a. Eq a => a -> a -> Bool
== ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
= P (Located (HsModule GhcPs))
parseSignature
| Bool
otherwise = P (Located (HsModule GhcPs))
parseModule
case forall a. P a -> PState -> ParseResult a
unP P (Located (HsModule GhcPs))
parseMod (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) StringBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst ->
forall a. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst)
POk PState
pst Located (HsModule GhcPs)
rdr_module -> do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_parsed [Char]
"Parser"
DumpFormat
FormatHaskell (forall a. Outputable a => a -> SDoc
ppr Located (HsModule GhcPs)
rdr_module)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_parsed_ast [Char]
"Parser AST"
DumpFormat
FormatHaskell (forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan
BlankEpAnnotations
NoBlankEpAnnotations
Located (HsModule GhcPs)
rdr_module)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_source_stats [Char]
"Source Statistics"
DumpFormat
FormatText (Bool -> Located (HsModule GhcPs) -> SDoc
ppSourceStats Bool
False Located (HsModule GhcPs)
rdr_module)
let n_hspp :: [Char]
n_hspp = [Char] -> [Char]
FilePath.normalise [Char]
src_filename
TempDir [Char]
tmp_dir = DynFlags -> TempDir
tmpDir DynFlags
dflags
srcs0 :: [[Char]]
srcs0 = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
tmp_dir forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== [Char]
n_hspp))
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
FilePath.normalise
forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"<")
forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FastString -> [Char]
unpackFS
forall a b. (a -> b) -> a -> b
$ PState -> [FastString]
srcfiles PState
pst
srcs1 :: [[Char]]
srcs1 = case ModLocation -> Maybe [Char]
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod_summary) of
Just [Char]
f -> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= [Char] -> [Char]
FilePath.normalise [Char]
f) [[Char]]
srcs0
Maybe [Char]
Nothing -> [[Char]]
srcs0
[[Char]]
srcs2 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist [[Char]]
srcs1
let res :: HsParsedModule
res = HsParsedModule {
hpm_module :: Located (HsModule GhcPs)
hpm_module = Located (HsModule GhcPs)
rdr_module,
hpm_src_files :: [[Char]]
hpm_src_files = [[Char]]
srcs2
}
let applyPluginAction :: Plugin -> [[Char]] -> ParsedResult -> Hsc ParsedResult
applyPluginAction Plugin
p [[Char]]
opts
= Plugin
-> [[Char]] -> ModSummary -> ParsedResult -> Hsc ParsedResult
parsedResultAction Plugin
p [[Char]]
opts ModSummary
mod_summary
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
(ParsedResult HsParsedModule
transformed (PsMessages Messages PsWarning
warns Messages PsWarning
errs)) <-
forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) Plugin -> [[Char]] -> ParsedResult -> Hsc ParsedResult
applyPluginAction
(HsParsedModule -> PsMessages -> ParsedResult
ParsedResult HsParsedModule
res (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Messages PsWarning -> Messages PsWarning -> PsMessages
PsMessages forall a b. (a -> b) -> a -> b
$ PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst))
Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warns)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall e. Messages e -> Bool
isEmptyMessages Messages PsWarning
errs) forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
errs)
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
transformed
checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))
checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, [Char]))
checkBidirectionFormatChars PsLoc
start_loc StringBuffer
sb
| StringBuffer -> Bool
containsBidirectionalFormatChar StringBuffer
sb = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, [Char])
go PsLoc
start_loc StringBuffer
sb
| Bool
otherwise = forall a. Maybe a
Nothing
where
go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)
go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, [Char])
go PsLoc
loc StringBuffer
sb
| StringBuffer -> Bool
atEnd StringBuffer
sb = forall a. HasCallStack => [Char] -> a
panic [Char]
"checkBidirectionFormatChars: no char found"
| Bool
otherwise = case StringBuffer -> (Char, StringBuffer)
nextChar StringBuffer
sb of
(Char
chr, StringBuffer
sb)
| Just [Char]
desc <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
chr [(Char, [Char])]
bidirectionalFormatChars ->
(PsLoc
loc, Char
chr, [Char]
desc) forall a. a -> [a] -> NonEmpty a
:| PsLoc -> StringBuffer -> [(PsLoc, Char, [Char])]
go1 (PsLoc -> Char -> PsLoc
advancePsLoc PsLoc
loc Char
chr) StringBuffer
sb
| Bool
otherwise -> PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, [Char])
go (PsLoc -> Char -> PsLoc
advancePsLoc PsLoc
loc Char
chr) StringBuffer
sb
go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, String)]
go1 :: PsLoc -> StringBuffer -> [(PsLoc, Char, [Char])]
go1 PsLoc
loc StringBuffer
sb
| StringBuffer -> Bool
atEnd StringBuffer
sb = []
| Bool
otherwise = case StringBuffer -> (Char, StringBuffer)
nextChar StringBuffer
sb of
(Char
chr, StringBuffer
sb)
| Just [Char]
desc <- forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
chr [(Char, [Char])]
bidirectionalFormatChars ->
(PsLoc
loc, Char
chr, [Char]
desc) forall a. a -> [a] -> [a]
: PsLoc -> StringBuffer -> [(PsLoc, Char, [Char])]
go1 (PsLoc -> Char -> PsLoc
advancePsLoc PsLoc
loc Char
chr) StringBuffer
sb
| Bool
otherwise -> PsLoc -> StringBuffer -> [(PsLoc, Char, [Char])]
go1 (PsLoc -> Char -> PsLoc
advancePsLoc PsLoc
loc Char
chr) StringBuffer
sb
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
ModSummary
mod_summary TcGblEnv
tc_result = do
let rn_info :: RenamedStuff
rn_info = TcGblEnv -> RenamedStuff
getRenamedStuff TcGblEnv
tc_result
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_rn_ast [Char]
"Renamer"
DumpFormat
FormatHaskell (forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations RenamedStuff
rn_info)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ do
HieFile
hieFile <- forall (m :: * -> *).
MonadIO m =>
ModSummary -> TcGblEnv -> RenamedSource -> m HieFile
mkHieFile ModSummary
mod_summary TcGblEnv
tc_result (forall a. HasCallStack => Maybe a -> a
fromJust RenamedStuff
rn_info)
let out_file :: [Char]
out_file = ModLocation -> [Char]
ml_hie_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
mod_summary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> HieFile -> IO ()
writeHieFile [Char]
out_file HieFile
hieFile
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_hie [Char]
"HIE AST" DumpFormat
FormatHaskell (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hieFile)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ValidateHie DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ do
HscEnv
hs_env <- forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
e Messages GhcMessage
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, Messages GhcMessage
w)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
case forall a. Module -> Map HiePath (HieAST a) -> [SDoc]
validateScopes (HieFile -> Module
hie_module HieFile
hieFile) forall a b. (a -> b) -> a -> b
$ forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hieFile of
[] -> Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [Char] -> doc
text [Char]
"Got valid scopes"
[SDoc]
xs -> do
Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [Char] -> doc
text [Char]
"Got invalid scopes"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> SDoc -> IO ()
putMsg Logger
logger) [SDoc]
xs
HieFileResult
file' <- NameCache -> [Char] -> IO HieFileResult
readHieFile (HscEnv -> NameCache
hsc_NC HscEnv
hs_env) [Char]
out_file
case Diff HieFile
diffFile HieFile
hieFile (HieFileResult -> HieFile
hie_file_result HieFileResult
file') of
[] ->
Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [Char] -> doc
text [Char]
"Got no roundtrip errors"
[SDoc]
xs -> do
Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [Char] -> doc
text [Char]
"Got roundtrip errors"
let logger' :: Logger
logger' = Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags Logger
logger (DumpFlag -> LogFlags -> LogFlags
log_set_dopt DumpFlag
Opt_D_ppr_debug)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> SDoc -> IO ()
putMsg Logger
logger') [SDoc]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return RenamedStuff
rn_info
hscTypecheckRename :: HscEnv -> ModSummary -> HsParsedModule
-> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename :: HscEnv
-> ModSummary -> HsParsedModule -> IO (TcGblEnv, RenamedStuff)
hscTypecheckRename HscEnv
hsc_env ModSummary
mod_summary HsParsedModule
rdr_module = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$
Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
True ModSummary
mod_summary (forall a. a -> Maybe a
Just HsParsedModule
rdr_module)
hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, WarningMessages)
hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage)
hscTypecheckAndGetWarnings HscEnv
hsc_env ModSummary
summary = forall a. HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
case Hooks -> Maybe (ModSummary -> Hsc FrontendResult)
hscFrontendHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) of
Maybe (ModSummary -> Hsc FrontendResult)
Nothing -> TcGblEnv -> FrontendResult
FrontendTypecheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
False ModSummary
summary forall a. Maybe a
Nothing
Just ModSummary -> Hsc FrontendResult
h -> ModSummary -> Hsc FrontendResult
h ModSummary
summary
hsc_typecheck :: Bool
-> ModSummary -> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck :: Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
keep_rn ModSummary
mod_summary Maybe HsParsedModule
mb_rdr_module = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
mod_name :: ModuleName
mod_name = forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod
outer_mod' :: Module
outer_mod' = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
inner_mod :: Module
inner_mod = HomeUnit -> ModuleName -> Module
homeModuleNameInstantiation HomeUnit
home_unit ModuleName
mod_name
src_filename :: [Char]
src_filename = ModSummary -> [Char]
ms_hspp_file ModSummary
mod_summary
real_loc :: RealSrcSpan
real_loc = RealSrcLoc -> RealSrcSpan
realSrcLocSpan forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
mkFastString [Char]
src_filename) Int
1 Int
1
keep_rn' :: Bool
keep_rn' = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags Bool -> Bool -> Bool
|| Bool
keep_rn
forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
outer_mod)
TcGblEnv
tc_result <- if HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Bool -> Bool
not (forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
inner_mod)
then forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> RealSrcSpan
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnInstantiateSignature HscEnv
hsc_env Module
outer_mod' RealSrcSpan
real_loc
else
do HsParsedModule
hpm <- case Maybe HsParsedModule
mb_rdr_module of
Just HsParsedModule
hpm -> forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
hpm
Maybe HsParsedModule
Nothing -> ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
TcGblEnv
tc_result0 <- ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' ModSummary
mod_summary Bool
keep_rn' HsParsedModule
hpm
if HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
then do (ModIface
iface, ModDetails
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env forall a. Maybe a
Nothing TcGblEnv
tc_result0 ModSummary
mod_summary
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$
HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnMergeSignatures HscEnv
hsc_env HsParsedModule
hpm TcGblEnv
tc_result0 ModIface
iface
else forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tc_result0
Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe (LHsDoc GhcRn))
rn_info <- ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tc_result, Maybe
(HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
Maybe (LHsDoc GhcRn))
rn_info)
tcRnModule' :: ModSummary -> Bool -> HsParsedModule
-> Hsc TcGblEnv
tcRnModule' :: ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' ModSummary
sum Bool
save_rn_syntax HsParsedModule
mod = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags)
Bool -> Bool -> Bool
&& WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingSafeHaskellMode DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (forall l e. GenLocated l e -> l
getLoc (HsParsedModule -> Located (HsModule GhcPs)
hpm_module HsParsedModule
mod)) forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverMissingSafeHaskellMode (ModSummary -> Module
ms_mod ModSummary
sum)
TcGblEnv
tcg_res <- {-# SCC "Typecheck-Rename" #-}
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$
HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
sum
Bool
save_rn_syntax HsParsedModule
mod
Bool
tcSafeOK <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef Bool
tcg_safe_infer TcGblEnv
tcg_res)
Messages TcRnMessage
whyUnsafe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef (Messages TcRnMessage)
tcg_safe_infer_reasons TcGblEnv
tcg_res)
let allSafeOK :: Bool
allSafeOK = DynFlags -> Bool
safeInferred DynFlags
dflags Bool -> Bool -> Bool
&& Bool
tcSafeOK
if Bool -> Bool
not (DynFlags -> Bool
safeHaskellOn DynFlags
dflags)
Bool -> Bool -> Bool
|| (DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
allSafeOK)
then forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_res Messages TcRnMessage
whyUnsafe
else do
TcGblEnv
tcg_res' <- TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports TcGblEnv
tcg_res
Bool
safe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef Bool
tcg_safe_infer TcGblEnv
tcg_res')
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
safe forall a b. (a -> b) -> a -> b
$
case WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnSafe DynFlags
dflags of
Bool
True
| DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Safe -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise -> (Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (DynFlags -> SrcSpan
warnSafeOnLoc DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverInferredSafeModule (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_res'))
Bool
False | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy Bool -> Bool -> Bool
&&
WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnTrustworthySafe DynFlags
dflags ->
(Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (DynFlags -> SrcSpan
trustworthyOnLoc DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverMarkedTrustworthyButInferredSafe (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_res'))
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_res'
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
hsc_env ModSummary
mod_summary TcGblEnv
tc_result =
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' (ModSummary -> ModLocation
ms_location ModSummary
mod_summary) TcGblEnv
tc_result
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' ModLocation
mod_location TcGblEnv
tc_result = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages DsMessage, a) -> m (Messages GhcMessage, a)
hoistDsMessage forall a b. (a -> b) -> a -> b
$
{-# SCC "deSugar" #-}
HscEnv
-> ModLocation
-> TcGblEnv
-> IO (Messages DsMessage, Maybe ModGuts)
deSugar HscEnv
hsc_env ModLocation
mod_location TcGblEnv
tc_result
makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails
makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails
makeSimpleDetails Logger
logger TcGblEnv
tc_result = Logger -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc Logger
logger TcGblEnv
tc_result
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()
hscRecompStatus :: Maybe Messager
-> HscEnv
-> ModSummary
-> Maybe ModIface
-> HomeModLinkable
-> (Int,Int)
-> IO HscRecompStatus
hscRecompStatus :: Maybe Messager
-> HscEnv
-> ModSummary
-> Maybe ModIface
-> HomeModLinkable
-> (Int, Int)
-> IO HscRecompStatus
hscRecompStatus
Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
mb_old_iface HomeModLinkable
old_linkable (Int, Int)
mod_index
= do
let
msg :: RecompileRequired -> IO ()
msg RecompileRequired
what = case Maybe Messager
mHscMessage of
Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
what ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [] ModSummary
mod_summary)
Maybe Messager
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
MaybeValidated ModIface
recomp_if_result
<- {-# SCC "checkOldIface" #-}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary -> Maybe ModIface -> IO (MaybeValidated ModIface)
checkOldIface HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
mb_old_iface
case MaybeValidated ModIface
recomp_if_result of
OutOfDateItem CompileReason
reason Maybe ModIface
mb_checked_iface -> do
RecompileRequired -> IO ()
msg forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
reason
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Fingerprint -> HscRecompStatus
HscRecompNeeded forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModIfaceBackend -> Fingerprint
mi_iface_hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts) Maybe ModIface
mb_checked_iface
UpToDateItem ModIface
checked_iface -> do
let lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
mod_summary
if | Bool -> Bool
not (Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend DynFlags
lcl_dflags)) -> do
RecompileRequired -> IO ()
msg RecompileRequired
UpToDate
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModIface -> HomeModLinkable -> HscRecompStatus
HscUpToDate ModIface
checked_iface HomeModLinkable
emptyHomeModInfoLinkable
| Bool -> Bool
not (Backend -> Bool
backendGeneratesCodeForHsBoot (DynFlags -> Backend
backend DynFlags
lcl_dflags))
, IsBootInterface
IsBoot <- ModSummary -> IsBootInterface
isBootSummary ModSummary
mod_summary -> do
RecompileRequired -> IO ()
msg RecompileRequired
UpToDate
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModIface -> HomeModLinkable -> HscRecompStatus
HscUpToDate ModIface
checked_iface HomeModLinkable
emptyHomeModInfoLinkable
| Bool
otherwise -> do
MaybeValidated Linkable
bc_linkable <- ModIface
-> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
checkByteCode ModIface
checked_iface ModSummary
mod_summary (HomeModLinkable -> Maybe Linkable
homeMod_bytecode HomeModLinkable
old_linkable)
MaybeValidated Linkable
obj_linkable <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags
-> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
checkObjects DynFlags
lcl_dflags (HomeModLinkable -> Maybe Linkable
homeMod_object HomeModLinkable
old_linkable) ModSummary
mod_summary
Logger -> SDoc -> IO ()
trace_if (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (forall doc. IsDoc doc => [doc] -> doc
vcat [forall doc. IsLine doc => [Char] -> doc
text [Char]
"BCO linkable", Int -> SDoc -> SDoc
nest Int
2 (forall a. Outputable a => a -> SDoc
ppr MaybeValidated Linkable
bc_linkable), forall doc. IsLine doc => [Char] -> doc
text [Char]
"Object Linkable", forall a. Outputable a => a -> SDoc
ppr MaybeValidated Linkable
obj_linkable])
let just_bc :: MaybeValidated HomeModLinkable
just_bc = Linkable -> HomeModLinkable
justBytecode forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeValidated Linkable
bc_linkable
just_o :: MaybeValidated HomeModLinkable
just_o = Linkable -> HomeModLinkable
justObjects forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeValidated Linkable
obj_linkable
_maybe_both_os :: MaybeValidated HomeModLinkable
_maybe_both_os = case (MaybeValidated Linkable
bc_linkable, MaybeValidated Linkable
obj_linkable) of
(UpToDateItem Linkable
bc, UpToDateItem Linkable
o) -> forall a. a -> MaybeValidated a
UpToDateItem (Linkable -> Linkable -> HomeModLinkable
bytecodeAndObjects Linkable
bc Linkable
o)
(MaybeValidated Linkable
_, OutOfDateItem CompileReason
reason Maybe Linkable
_) -> forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason forall a. Maybe a
Nothing
(MaybeValidated Linkable
_, UpToDateItem {} ) -> MaybeValidated HomeModLinkable
just_o
definitely_both_os :: MaybeValidated HomeModLinkable
definitely_both_os = case (MaybeValidated Linkable
bc_linkable, MaybeValidated Linkable
obj_linkable) of
(UpToDateItem Linkable
bc, UpToDateItem Linkable
o) -> forall a. a -> MaybeValidated a
UpToDateItem (Linkable -> Linkable -> HomeModLinkable
bytecodeAndObjects Linkable
bc Linkable
o)
(MaybeValidated Linkable
_, OutOfDateItem CompileReason
reason Maybe Linkable
_) -> forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason forall a. Maybe a
Nothing
(OutOfDateItem CompileReason
reason Maybe Linkable
_, MaybeValidated Linkable
_ ) -> forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason forall a. Maybe a
Nothing
let recomp_linkable_result :: MaybeValidated HomeModLinkable
recomp_linkable_result = case () of
()
_ | Backend -> Bool
backendCanReuseLoadedCode (DynFlags -> Backend
backend DynFlags
lcl_dflags) ->
case MaybeValidated Linkable
bc_linkable of
UpToDateItem Linkable
_ -> MaybeValidated HomeModLinkable
just_bc
MaybeValidated Linkable
_ -> case MaybeValidated Linkable
obj_linkable of
UpToDateItem Linkable
_ -> MaybeValidated HomeModLinkable
just_o
MaybeValidated Linkable
_ -> forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingBytecode forall a. Maybe a
Nothing
| Backend -> Bool
backendWritesFiles (DynFlags -> Backend
backend DynFlags
lcl_dflags) ->
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ByteCodeAndObjectCode DynFlags
lcl_dflags
then MaybeValidated HomeModLinkable
definitely_both_os
else MaybeValidated HomeModLinkable
just_o
| Bool
otherwise -> forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"hscRecompStatus" (forall doc. IsLine doc => [Char] -> doc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
backend DynFlags
lcl_dflags)
case MaybeValidated HomeModLinkable
recomp_linkable_result of
UpToDateItem HomeModLinkable
linkable -> do
RecompileRequired -> IO ()
msg forall a b. (a -> b) -> a -> b
$ RecompileRequired
UpToDate
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModIface -> HomeModLinkable -> HscRecompStatus
HscUpToDate ModIface
checked_iface forall a b. (a -> b) -> a -> b
$ HomeModLinkable
linkable
OutOfDateItem CompileReason
reason Maybe HomeModLinkable
_ -> do
RecompileRequired -> IO ()
msg forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
reason
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Fingerprint -> HscRecompStatus
HscRecompNeeded forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ModIfaceBackend -> Fingerprint
mi_iface_hash forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts forall a b. (a -> b) -> a -> b
$ ModIface
checked_iface
checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
checkObjects :: DynFlags
-> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
checkObjects DynFlags
dflags Maybe Linkable
mb_old_linkable ModSummary
summary = do
let
dt_enabled :: Bool
dt_enabled = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
dflags
this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
summary
mb_obj_date :: Maybe UTCTime
mb_obj_date = ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
summary
mb_dyn_obj_date :: Maybe UTCTime
mb_dyn_obj_date = ModSummary -> Maybe UTCTime
ms_dyn_obj_date ModSummary
summary
mb_if_date :: Maybe UTCTime
mb_if_date = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
summary
obj_fn :: [Char]
obj_fn = ModLocation -> [Char]
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
checkDynamicObj :: IO (MaybeValidated Linkable) -> IO (MaybeValidated Linkable)
checkDynamicObj IO (MaybeValidated Linkable)
k = if Bool
dt_enabled
then case forall a. Ord a => a -> a -> Bool
(>=) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb_dyn_obj_date forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
mb_if_date of
Just Bool
True -> IO (MaybeValidated Linkable)
k
Maybe Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingDynObjectFile forall a. Maybe a
Nothing
else IO (MaybeValidated Linkable)
k
IO (MaybeValidated Linkable) -> IO (MaybeValidated Linkable)
checkDynamicObj forall a b. (a -> b) -> a -> b
$
case (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb_obj_date forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
mb_if_date of
Just (UTCTime
obj_date, UTCTime
if_date)
| UTCTime
obj_date forall a. Ord a => a -> a -> Bool
>= UTCTime
if_date ->
case Maybe Linkable
mb_old_linkable of
Just Linkable
old_linkable
| Linkable -> Bool
isObjectLinkable Linkable
old_linkable, Linkable -> UTCTime
linkableTime Linkable
old_linkable forall a. Eq a => a -> a -> Bool
== UTCTime
obj_date
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> MaybeValidated a
UpToDateItem Linkable
old_linkable
Maybe Linkable
_ -> forall a. a -> MaybeValidated a
UpToDateItem forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> [Char] -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod [Char]
obj_fn UTCTime
obj_date
Maybe (UTCTime, UTCTime)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingObjectFile forall a. Maybe a
Nothing
checkByteCode :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
checkByteCode :: ModIface
-> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
checkByteCode ModIface
iface ModSummary
mod_sum Maybe Linkable
mb_old_linkable =
case Maybe Linkable
mb_old_linkable of
Just Linkable
old_linkable
| Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
old_linkable)
-> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. a -> MaybeValidated a
UpToDateItem Linkable
old_linkable)
Maybe Linkable
_ -> ModIface -> ModSummary -> IO (MaybeValidated Linkable)
loadByteCode ModIface
iface ModSummary
mod_sum
loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
loadByteCode ModIface
iface ModSummary
mod_sum = do
let
this_mod :: Module
this_mod = ModSummary -> Module
ms_mod ModSummary
mod_sum
if_date :: UTCTime
if_date = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
mod_sum
case forall (phase :: ModIfacePhase).
ModIface_ phase
-> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
mi_extra_decls ModIface
iface of
Just [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
extra_decls -> do
let fi :: WholeCoreBindings
fi = [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> Module -> ModLocation -> WholeCoreBindings
WholeCoreBindings [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
extra_decls Module
this_mod (ModSummary -> ModLocation
ms_location ModSummary
mod_sum)
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> MaybeValidated a
UpToDateItem (UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
if_date Module
this_mod [WholeCoreBindings -> Unlinked
CoreBindings WholeCoreBindings
fi]))
Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingBytecode forall a. Maybe a
Nothing
initModDetails :: HscEnv -> ModIface -> IO ModDetails
initModDetails :: HscEnv -> ModIface -> IO ModDetails
initModDetails HscEnv
hsc_env ModIface
iface =
forall a. (a -> IO a) -> IO a
fixIO forall a b. (a -> b) -> a -> b
$ \ModDetails
details' -> do
let act :: HomePackageTable -> HomePackageTable
act HomePackageTable
hpt = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface)
(ModIface -> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details' HomeModLinkable
emptyHomeModInfoLinkable)
let !hsc_env' :: HscEnv
hsc_env' = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT HomePackageTable -> HomePackageTable
act HscEnv
hsc_env
HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env' ModIface
iface
initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
initWholeCoreBindings HscEnv
hsc_env ModIface
mod_iface ModDetails
details (LM UTCTime
utc_time Module
this_mod [Unlinked]
uls) = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
utc_time Module
this_mod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Unlinked -> IO Unlinked
go [Unlinked]
uls
where
go :: Unlinked -> IO Unlinked
go (CoreBindings WholeCoreBindings
fi) = do
let act :: HomePackageTable -> HomePackageTable
act HomePackageTable
hpt = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
mod_iface)
(ModIface -> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
mod_iface ModDetails
details HomeModLinkable
emptyHomeModInfoLinkable)
IORef TypeEnv
types_var <- forall a. a -> IO (IORef a)
newIORef (ModDetails -> TypeEnv
md_types ModDetails
details)
let kv :: KnotVars (IORef TypeEnv)
kv = forall a. ModuleEnv a -> KnotVars a
knotVarsFromModuleEnv (forall a. [(Module, a)] -> ModuleEnv a
mkModuleEnv [(Module
this_mod, IORef TypeEnv
types_var)])
let hsc_env' :: HscEnv
hsc_env' = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT HomePackageTable -> HomePackageTable
act HscEnv
hsc_env { hsc_type_env_vars :: KnotVars (IORef TypeEnv)
hsc_type_env_vars = KnotVars (IORef TypeEnv)
kv }
CoreProgram
core_binds <- forall a. SDoc -> HscEnv -> IfG a -> IO a
initIfaceCheck (forall doc. IsLine doc => [Char] -> doc
text [Char]
"l") HscEnv
hsc_env' forall a b. (a -> b) -> a -> b
$ IORef TypeEnv -> WholeCoreBindings -> IfG CoreProgram
typecheckWholeCoreBindings IORef TypeEnv
types_var WholeCoreBindings
fi
let cgi_guts :: CgInteractiveGuts
cgi_guts = Module
-> CoreProgram
-> [TyCon]
-> ForeignStubs
-> Maybe ModBreaks
-> [SptEntry]
-> CgInteractiveGuts
CgInteractiveGuts Module
this_mod CoreProgram
core_binds (TypeEnv -> [TyCon]
typeEnvTyCons (ModDetails -> TypeEnv
md_types ModDetails
details)) ForeignStubs
NoStubs forall a. Maybe a
Nothing []
[Unlinked] -> Unlinked
LoadedBCOs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. IO a -> IO a
unsafeInterleaveIO forall a b. (a -> b) -> a -> b
$ do
Logger -> SDoc -> IO ()
trace_if (HscEnv -> Logger
hsc_logger HscEnv
hsc_env) (forall doc. IsLine doc => [Char] -> doc
text [Char]
"Generating ByteCode for" forall doc. IsLine doc => doc -> doc -> doc
<+> (forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
HscEnv -> CgInteractiveGuts -> ModLocation -> IO [Unlinked]
generateByteCode HscEnv
hsc_env CgInteractiveGuts
cgi_guts (WholeCoreBindings -> ModLocation
wcb_mod_location WholeCoreBindings
fi))
go Unlinked
ul = forall (m :: * -> *) a. Monad m => a -> m a
return Unlinked
ul
hscDesugarAndSimplify :: ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> Hsc HscBackendAction
hscDesugarAndSimplify :: ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> Hsc HscBackendAction
hscDesugarAndSimplify ModSummary
summary (FrontendTypecheck TcGblEnv
tc_result) Messages GhcMessage
tc_warnings Maybe Fingerprint
mb_old_hash = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
let bcknd :: Backend
bcknd = DynFlags -> Backend
backend DynFlags
dflags
hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
summary
diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
print_config :: DiagnosticOpts GhcMessage
print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig DynFlags
dflags
Maybe ModGuts
mb_desugar <-
if ModSummary -> Module
ms_mod ModSummary
summary forall a. Eq a => a -> a -> Bool
/= Module
gHC_PRIM Bool -> Bool -> Bool
&& HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsSrcFile
then forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' (ModSummary -> ModLocation
ms_location ModSummary
summary) TcGblEnv
tc_result
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
Messages GhcMessage
w <- Hsc (Messages GhcMessage)
getDiagnostics
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagnosticOpts GhcMessage
print_config DiagOpts
diag_opts (forall e. Messages e -> Messages e -> Messages e
unionMessages Messages GhcMessage
tc_warnings Messages GhcMessage
w)
Hsc ()
clearDiagnostics
case Maybe ModGuts
mb_desugar of
Just ModGuts
desugared_guts | Backend -> Bool
backendGeneratesCode Backend
bcknd -> do
[[Char]]
plugins <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef [[Char]]
tcg_th_coreplugins TcGblEnv
tc_result)
ModGuts
simplified_guts <- [[Char]] -> ModGuts -> Hsc ModGuts
hscSimplify' [[Char]]
plugins ModGuts
desugared_guts
(CgGuts
cg_guts, ModDetails
details) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy HscEnv
hsc_env ModGuts
simplified_guts
let !partial_iface :: PartialModIface
partial_iface =
{-# SCC "GHC.Driver.Main.mkPartialIface" #-}
forall a. NFData a => a -> a
force (HscEnv
-> CoreProgram
-> ModDetails
-> ModSummary
-> ModGuts
-> PartialModIface
mkPartialIface HscEnv
hsc_env (CgGuts -> CoreProgram
cg_binds CgGuts
cg_guts) ModDetails
details ModSummary
summary ModGuts
simplified_guts)
forall (m :: * -> *) a. Monad m => a -> m a
return HscRecomp { hscs_guts :: CgGuts
hscs_guts = CgGuts
cg_guts,
hscs_mod_location :: ModLocation
hscs_mod_location = ModSummary -> ModLocation
ms_location ModSummary
summary,
hscs_partial_iface :: PartialModIface
hscs_partial_iface = PartialModIface
partial_iface,
hscs_old_iface_hash :: Maybe Fingerprint
hscs_old_iface_hash = Maybe Fingerprint
mb_old_hash
}
Just ModGuts
desugared_guts | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteIfSimplifiedCore DynFlags
dflags -> do
[[Char]]
plugins <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef [[Char]]
tcg_th_coreplugins TcGblEnv
tc_result)
ModGuts
simplified_guts <- [[Char]] -> ModGuts -> Hsc ModGuts
hscSimplify' [[Char]]
plugins ModGuts
desugared_guts
(CgGuts
cg_guts, ModDetails
_) <-
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy HscEnv
hsc_env ModGuts
simplified_guts
(ModIface
iface, ModDetails
_details) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
HscEnv
-> Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ CgGuts -> CoreProgram
cg_binds CgGuts
cg_guts) TcGblEnv
tc_result ModSummary
summary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface Logger
logger DynFlags
dflags Bool
True ModIface
iface Maybe Fingerprint
mb_old_hash (ModSummary -> ModLocation
ms_location ModSummary
summary)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModIface -> HscBackendAction
HscUpdate ModIface
iface
Maybe ModGuts
_ -> do
(ModIface
iface, ModDetails
_details) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
HscEnv
-> Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env forall a. Maybe a
Nothing TcGblEnv
tc_result ModSummary
summary
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface Logger
logger DynFlags
dflags Bool
True ModIface
iface Maybe Fingerprint
mb_old_hash (ModSummary -> ModLocation
ms_location ModSummary
summary)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModIface -> HscBackendAction
HscUpdate ModIface
iface
hscMaybeWriteIface
:: Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface :: Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface Logger
logger DynFlags
dflags Bool
is_simple ModIface
iface Maybe Fingerprint
old_iface ModLocation
mod_location = do
let force_write_interface :: Bool
force_write_interface = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags
write_interface :: Bool
write_interface = Backend -> Bool
backendWritesFiles (DynFlags -> Backend
backend DynFlags
dflags)
write_iface :: DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags' ModIface
iface =
let !iface_name :: [Char]
iface_name = if DynFlags -> Bool
dynamicNow DynFlags
dflags' then ModLocation -> [Char]
ml_dyn_hi_file ModLocation
mod_location else ModLocation -> [Char]
ml_hi_file ModLocation
mod_location
profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags'
in
{-# SCC "writeIface" #-}
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(forall doc. IsLine doc => [Char] -> doc
text [Char]
"WriteIface"forall doc. IsLine doc => doc -> doc -> doc
<+>forall doc. IsLine doc => doc -> doc
brackets (forall doc. IsLine doc => [Char] -> doc
text [Char]
iface_name))
(forall a b. a -> b -> a
const ())
(Logger -> Profile -> [Char] -> ModIface -> IO ()
writeIface Logger
logger Profile
profile [Char]
iface_name ModIface
iface)
if (Bool
write_interface Bool -> Bool -> Bool
|| Bool
force_write_interface) then do
let change :: Bool
change = Maybe Fingerprint
old_iface forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just (ModIfaceBackend -> Fingerprint
mi_iface_hash (forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))
let dt :: DynamicTooState
dt = DynFlags -> DynamicTooState
dynamicTooState DynFlags
dflags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_if_trace) forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang (forall doc. IsLine doc => [Char] -> doc
text [Char]
"Writing interface(s):") Int
2 forall a b. (a -> b) -> a -> b
$ forall doc. IsDoc doc => [doc] -> doc
vcat
[ forall doc. IsLine doc => [Char] -> doc
text [Char]
"Kind:" forall doc. IsLine doc => doc -> doc -> doc
<+> if Bool
is_simple then forall doc. IsLine doc => [Char] -> doc
text [Char]
"simple" else forall doc. IsLine doc => [Char] -> doc
text [Char]
"full"
, forall doc. IsLine doc => [Char] -> doc
text [Char]
"Hash change:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr Bool
change
, forall doc. IsLine doc => [Char] -> doc
text [Char]
"DynamicToo state:" forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => [Char] -> doc
text (forall a. Show a => a -> [Char]
show DynamicTooState
dt)
]
if Bool
is_simple
then forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
change forall a b. (a -> b) -> a -> b
$ do
DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
case DynamicTooState
dt of
DynamicTooState
DT_Dont -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
DynamicTooState
DT_Dyn -> forall a. HasCallStack => [Char] -> a
panic [Char]
"Unexpected DT_Dyn state when writing simple interface"
DynamicTooState
DT_OK -> DynFlags -> ModIface -> IO ()
write_iface (DynFlags -> DynFlags
setDynamicNow DynFlags
dflags) ModIface
iface
else case DynamicTooState
dt of
DynamicTooState
DT_Dont | Bool
change -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
DT_OK | Bool
change -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
DT_Dyn -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ do
let hie_file :: [Char]
hie_file = ModLocation -> [Char]
ml_hie_file ModLocation
mod_location
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([Char] -> IO Bool
doesFileExist [Char]
hie_file) forall a b. (a -> b) -> a -> b
$
Logger -> DynFlags -> [Char] -> [Char] -> IO ()
GHC.SysTools.touch Logger
logger DynFlags
dflags [Char]
"Touching hie file" [Char]
hie_file
else
ModIface -> IO ()
forceModIface ModIface
iface
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env ModIface
old_iface
= do
ModDetails
new_details <- {-# SCC "tcRnIface" #-}
forall a. HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule HscEnv
hsc_env (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
old_iface) (ModIface -> IfG ModDetails
typecheckIface ModIface
old_iface)
case forall a. KnotVars a -> Module -> Maybe a
lookupKnotVars (HscEnv -> KnotVars (IORef TypeEnv)
hsc_type_env_vars HscEnv
hsc_env) (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
old_iface) of
Maybe (IORef TypeEnv)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just IORef TypeEnv
te_var -> forall a. IORef a -> a -> IO ()
writeIORef IORef TypeEnv
te_var (ModDetails -> TypeEnv
md_types ModDetails
new_details)
HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
forall (m :: * -> *) a. Monad m => a -> m a
return ModDetails
new_details
oneShotMsg :: Logger -> RecompileRequired -> IO ()
oneShotMsg :: Logger -> RecompileRequired -> IO ()
oneShotMsg Logger
logger RecompileRequired
recomp =
case RecompileRequired
recomp of
RecompileRequired
UpToDate -> Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger forall a b. (a -> b) -> a -> b
$ forall doc. IsLine doc => [Char] -> doc
text [Char]
"compilation IS NOT required"
NeedsRecompile CompileReason
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
batchMsg :: Messager
batchMsg :: Messager
batchMsg = (HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith (\HscEnv
_ (Int, Int)
_ RecompileRequired
_ ModuleGraphNode
_ -> forall doc. IsOutput doc => doc
empty)
batchMultiMsg :: Messager
batchMultiMsg :: Messager
batchMultiMsg = (HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith (\HscEnv
_ (Int, Int)
_ RecompileRequired
_ ModuleGraphNode
node -> forall doc. IsLine doc => doc -> doc
brackets (forall a. Outputable a => a -> SDoc
ppr (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
node)))
batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager
batchMsgWith :: (HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc
extra HscEnv
hsc_env_start (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node =
case RecompileRequired
recomp of
RecompileRequired
UpToDate
| Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2 -> SDoc -> SDoc -> IO ()
showMsg (forall doc. IsLine doc => [Char] -> doc
text [Char]
"Skipping") forall doc. IsOutput doc => doc
empty
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
NeedsRecompile CompileReason
reason0 -> SDoc -> SDoc -> IO ()
showMsg (forall doc. IsLine doc => [Char] -> doc
text [Char]
herald) forall a b. (a -> b) -> a -> b
$ case CompileReason
reason0 of
CompileReason
MustCompile -> forall doc. IsOutput doc => doc
empty
(RecompBecause RecompReason
reason) -> forall doc. IsLine doc => [Char] -> doc
text [Char]
" [" forall doc. IsLine doc => doc -> doc -> doc
<> UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (forall a. Outputable a => a -> SDoc
ppr RecompReason
reason) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => [Char] -> doc
text [Char]
"]"
where
herald :: [Char]
herald = case ModuleGraphNode
node of
LinkNode {} -> [Char]
"Linking"
InstantiationNode {} -> [Char]
"Instantiating"
ModuleNode {} -> [Char]
"Compiling"
hsc_env :: HscEnv
hsc_env = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
node) HscEnv
hsc_env_start
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
showMsg :: SDoc -> SDoc -> IO ()
showMsg SDoc
msg SDoc
reason =
Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger forall a b. (a -> b) -> a -> b
$
((Int, Int) -> SDoc
showModuleIndex (Int, Int)
mod_index forall doc. IsLine doc => doc -> doc -> doc
<>
SDoc
msg forall doc. IsLine doc => doc -> doc -> doc
<+> DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModuleGraphNode
node)
forall doc. IsLine doc => doc -> doc -> doc
<> HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc
extra HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
reason
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports TcGblEnv
tcg_env = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
TcGblEnv
tcg_env' <- TcGblEnv -> Hsc TcGblEnv
checkSafeImports TcGblEnv
tcg_env
DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkRULES DynFlags
dflags TcGblEnv
tcg_env'
where
checkRULES :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkRULES DynFlags
dflags TcGblEnv
tcg_env' =
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
in case DynFlags -> Bool
safeLanguageOn DynFlags
dflags of
Bool
True -> do
Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ DiagOpts
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DiagOpts
diag_opts (TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = [] }
Bool
False
| DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
-> forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env' forall a b. (a -> b) -> a -> b
$ DiagOpts
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DiagOpts
diag_opts (TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env'
warns :: DiagOpts
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DiagOpts
diag_opts [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules = forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Bag a
listToBag forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules DiagOpts
diag_opts) [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules
warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules DiagOpts
diag_opts (L SrcSpanAnnA
loc RuleDecl GhcTc
rule) =
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$ RuleDecl GhcTc -> DriverMessage
DriverUserDefinedRuleIgnored RuleDecl GhcTc
rule
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports :: TcGblEnv -> Hsc TcGblEnv
checkSafeImports TcGblEnv
tcg_env
= do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
[(Module, SrcSpan, Bool)]
imps <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, Bool)
condense [(Module, [ImportedModsVal])]
imports'
let ([(Module, SrcSpan, Bool)]
safeImps, [(Module, SrcSpan, Bool)]
regImps) = forall a. (a -> Bool) -> [a] -> ([a], [a])
partition (\(Module
_,SrcSpan
_,Bool
s) -> Bool
s) [(Module, SrcSpan, Bool)]
imps
Messages GhcMessage
oldErrs <- Hsc (Messages GhcMessage)
getDiagnostics
Hsc ()
clearDiagnostics
Set UnitId
safePkgs <- forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall a. (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe [(Module, SrcSpan, Bool)]
safeImps
Messages GhcMessage
safeErrs <- Hsc (Messages GhcMessage)
getDiagnostics
Hsc ()
clearDiagnostics
(Messages GhcMessage
infErrs, Set UnitId
infPkgs) <- case (DynFlags -> Bool
safeInferOn DynFlags
dflags) of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall e. Messages e
emptyMessages, forall a. Set a
S.empty)
Bool
True -> do Set UnitId
infPkgs <- forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall a. (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe [(Module, SrcSpan, Bool)]
regImps
Messages GhcMessage
infErrs <- Hsc (Messages GhcMessage)
getDiagnostics
Hsc ()
clearDiagnostics
forall (m :: * -> *) a. Monad m => a -> m a
return (Messages GhcMessage
infErrs, Set UnitId
infPkgs)
Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
oldErrs
DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
GhcMessageOpts
print_config <- DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> GhcMessageOpts -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger GhcMessageOpts
print_config DiagOpts
diag_opts Messages GhcMessage
safeErrs
let infPassed :: Bool
infPassed = forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
infErrs
TcGblEnv
tcg_env' <- case (Bool -> Bool
not Bool
infPassed) of
Bool
True -> forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env Messages GhcMessage
infErrs
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
packageTrustOn DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgReqs
let newTrust :: ImportAvails
newTrust = DynFlags -> Set UnitId -> Set UnitId -> Bool -> ImportAvails
pkgTrustReqs DynFlags
dflags Set UnitId
safePkgs Set UnitId
infPkgs Bool
infPassed
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_imports :: ImportAvails
tcg_imports = ImportAvails
impInfo ImportAvails -> ImportAvails -> ImportAvails
`plusImportAvails` ImportAvails
newTrust }
where
impInfo :: ImportAvails
impInfo = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env
imports :: ImportedMods
imports = ImportAvails -> ImportedMods
imp_mods ImportAvails
impInfo
imports1 :: [(Module, [ImportedBy])]
imports1 = forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ImportedMods
imports
imports' :: [(Module, [ImportedModsVal])]
imports' = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [ImportedBy] -> [ImportedModsVal]
importedByUser) [(Module, [ImportedBy])]
imports1
pkgReqs :: Set UnitId
pkgReqs = ImportAvails -> Set UnitId
imp_trust_pkgs ImportAvails
impInfo
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, IsSafeImport)
condense :: (Module, [ImportedModsVal]) -> Hsc (Module, SrcSpan, Bool)
condense (Module
_, []) = forall a. HasCallStack => [Char] -> a
panic [Char]
"GHC.Driver.Main.condense: Pattern match failure!"
condense (Module
m, ImportedModsVal
x:[ImportedModsVal]
xs) = do ImportedModsVal
imv <- forall (t :: * -> *) (m :: * -> *) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldlM ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' ImportedModsVal
x [ImportedModsVal]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return (Module
m, ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
imv, ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
imv)
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' ImportedModsVal
v1 ImportedModsVal
v2
| ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v1 forall a. Eq a => a -> a -> Bool
/= ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v2
= forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
v1) forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ ModuleName -> DriverMessage
DriverMixedSafetyImport (ImportedModsVal -> ModuleName
imv_name ImportedModsVal
v1)
| Bool
otherwise
= forall (m :: * -> *) a. Monad m => a -> m a
return ImportedModsVal
v1
checkSafe :: (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe :: forall a. (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe (Module
m, SrcSpan
l, a
_) = forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId ->
Bool -> ImportAvails
pkgTrustReqs :: DynFlags -> Set UnitId -> Set UnitId -> Bool -> ImportAvails
pkgTrustReqs DynFlags
dflags Set UnitId
req Set UnitId
inf Bool
infPassed | DynFlags -> Bool
safeInferOn DynFlags
dflags
Bool -> Bool -> Bool
&& Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags) Bool -> Bool -> Bool
&& Bool
infPassed
= ImportAvails
emptyImportAvails {
imp_trust_pkgs :: Set UnitId
imp_trust_pkgs = Set UnitId
req forall a. Ord a => Set a -> Set a -> Set a
`S.union` Set UnitId
inf
}
pkgTrustReqs DynFlags
dflags Set UnitId
_ Set UnitId
_ Bool
_ | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Unsafe
= ImportAvails
emptyImportAvails
pkgTrustReqs DynFlags
_ Set UnitId
req Set UnitId
_ Bool
_ = ImportAvails
emptyImportAvails { imp_trust_pkgs :: Set UnitId
imp_trust_pkgs = Set UnitId
req }
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe HscEnv
hsc_env Module
m SrcSpan
l = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Set UnitId
pkgs <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
packageTrustOn DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgs
Messages GhcMessage
errs <- Hsc (Messages GhcMessage)
getDiagnostics
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
errs
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe HscEnv
hsc_env Module
m SrcSpan
l = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
(Maybe UnitId
self, Set UnitId
pkgs) <- Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
Bool
good <- forall e. Messages e -> Bool
isEmptyMessages forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Hsc (Messages GhcMessage)
getDiagnostics
Hsc ()
clearDiagnostics
let pkgs' :: Set UnitId
pkgs' | Just UnitId
p <- Maybe UnitId
self = forall a. Ord a => a -> Set a -> Set a
S.insert UnitId
p Set UnitId
pkgs
| Bool
otherwise = Set UnitId
pkgs
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
good, Set UnitId
pkgs')
hscCheckSafe' :: Module -> SrcSpan
-> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' :: Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
(Bool
tw, Set UnitId
pkgs) <- HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe HomeUnit
home_unit Module
m SrcSpan
l
case Bool
tw of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, Set UnitId
pkgs)
Bool
True | HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
m -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Maybe a
Nothing, Set UnitId
pkgs)
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GenUnit UnitId -> UnitId
toUnitId (forall unit. GenModule unit -> unit
moduleUnit Module
m), Set UnitId
pkgs)
where
isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe HomeUnit
home_unit Module
m SrcSpan
l = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Maybe ModIface
iface <- Module -> Hsc (Maybe ModIface)
lookup' Module
m
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
case Maybe ModIface
iface of
Maybe ModIface
Nothing -> forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverCannotLoadInterfaceFile Module
m
Just ModIface
iface' ->
let trust :: SafeHaskellMode
trust = IfaceTrustInfo -> SafeHaskellMode
getSafeMode forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
iface'
trust_own_pkg :: Bool
trust_own_pkg = forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_trust_pkg ModIface
iface'
safeM :: Bool
safeM = SafeHaskellMode
trust forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [SafeHaskellMode
Sf_Safe, SafeHaskellMode
Sf_SafeInferred, SafeHaskellMode
Sf_Trustworthy]
safeP :: Bool
safeP = DynFlags
-> UnitState
-> HomeUnit
-> SafeHaskellMode
-> Bool
-> Module
-> Bool
packageTrusted DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) HomeUnit
home_unit SafeHaskellMode
trust Bool
trust_own_pkg Module
m
pkgRs :: Set UnitId
pkgRs = Dependencies -> Set UnitId
dep_trusted_pkgs forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface'
warns :: Messages GhcMessage
warns = if WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnInferredSafeImports DynFlags
dflags
Bool -> Bool -> Bool
&& DynFlags -> Bool
safeLanguageOn DynFlags
dflags
Bool -> Bool -> Bool
&& SafeHaskellMode
trust forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_SafeInferred
then DiagOpts -> Messages GhcMessage
inferredImportWarn DiagOpts
diag_opts
else forall e. Messages e
emptyMessages
errs :: Messages GhcMessage
errs = case (Bool
safeM, Bool
safeP) of
(Bool
True, Bool
True ) -> forall e. Messages e
emptyMessages
(Bool
True, Bool
False) -> Messages GhcMessage
pkgTrustErr
(Bool
False, Bool
_ ) -> Messages GhcMessage
modTrustErr
in do
Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
warns
Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
errs
forall (m :: * -> *) a. Monad m => a -> m a
return (SafeHaskellMode
trust forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy, Set UnitId
pkgRs)
where
state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
inferredImportWarn :: DiagOpts -> Messages GhcMessage
inferredImportWarn DiagOpts
diag_opts = forall e. MsgEnvelope e -> Messages e
singleMessage
forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
diag_opts SrcSpan
l (UnitState -> NamePprCtx
pkgQual UnitState
state)
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverInferredSafeImport Module
m
pkgTrustErr :: Messages GhcMessage
pkgTrustErr = forall e. MsgEnvelope e -> Messages e
singleMessage
forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
l (UnitState -> NamePprCtx
pkgQual UnitState
state)
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ UnitState -> Module -> DriverMessage
DriverCannotImportFromUntrustedPackage UnitState
state Module
m
modTrustErr :: Messages GhcMessage
modTrustErr = forall e. MsgEnvelope e -> Messages e
singleMessage
forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
l (UnitState -> NamePprCtx
pkgQual UnitState
state)
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverCannotImportUnsafeModule Module
m
packageTrusted :: DynFlags -> UnitState -> HomeUnit -> SafeHaskellMode -> Bool -> Module -> Bool
packageTrusted :: DynFlags
-> UnitState
-> HomeUnit
-> SafeHaskellMode
-> Bool
-> Module
-> Bool
packageTrusted DynFlags
dflags UnitState
unit_state HomeUnit
home_unit SafeHaskellMode
safe_mode Bool
trust_own_pkg Module
mod =
case SafeHaskellMode
safe_mode of
SafeHaskellMode
Sf_None -> Bool
False
SafeHaskellMode
Sf_Ignore -> Bool
False
SafeHaskellMode
Sf_Unsafe -> Bool
False
SafeHaskellMode
_ | Bool -> Bool
not (DynFlags -> Bool
packageTrustOn DynFlags
dflags) -> Bool
True
SafeHaskellMode
Sf_Safe | Bool -> Bool
not Bool
trust_own_pkg -> Bool
True
SafeHaskellMode
Sf_SafeInferred | Bool -> Bool
not Bool
trust_own_pkg -> Bool
True
SafeHaskellMode
_ | HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod -> Bool
True
SafeHaskellMode
_ -> forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitState -> GenUnit UnitId -> UnitInfo
unsafeLookupUnit UnitState
unit_state (forall unit. GenModule unit -> unit
moduleUnit Module
m)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' :: Module -> Hsc (Maybe ModIface)
lookup' Module
m = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
ExternalPackageState
hsc_eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
let pkgIfaceT :: PackageIfaceTable
pkgIfaceT = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
hsc_eps
hug :: HomeUnitGraph
hug = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
iface :: Maybe ModIface
iface = HomeUnitGraph -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomeUnitGraph
hug PackageIfaceTable
pkgIfaceT Module
m
case Maybe ModIface
iface of
Just ModIface
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
iface
Maybe ModIface
Nothing -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
m)
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgs = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let errors :: Bag (MsgEnvelope GhcMessage)
errors = forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr UnitId
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
go forall a. Bag a
emptyBag Set UnitId
pkgs
state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
go :: UnitId
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
go UnitId
pkg Bag (MsgEnvelope GhcMessage)
acc
| forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
state UnitId
pkg
= Bag (MsgEnvelope GhcMessage)
acc
| Bool
otherwise
= (forall a. a -> Bag a -> Bag a
`consBag` Bag (MsgEnvelope GhcMessage)
acc)
forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
noSrcSpan (UnitState -> NamePprCtx
pkgQual UnitState
state)
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage
forall a b. (a -> b) -> a -> b
$ UnitState -> UnitId -> DriverMessage
DriverPackageNotTrusted UnitState
state UnitId
pkg
if forall a. Bag a -> Bool
isEmptyBag Bag (MsgEnvelope GhcMessage)
errors
then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors forall a b. (a -> b) -> a -> b
$ forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages Bag (MsgEnvelope GhcMessage)
errors
markUnsafeInfer :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer :: forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env Messages e
whyUnsafe = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let reason :: DiagnosticReason
reason = WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnsafe
let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
Opt_WarnUnsafe DiagOpts
diag_opts)
(Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (DynFlags -> SrcSpan
warnUnsafeOnLoc DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic -> DriverMessage
DriverUnknownMessage forall a b. (a -> b) -> a -> b
$
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic forall a b. (a -> b) -> a -> b
$
DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
reason [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
DynFlags -> SDoc
whyUnsafe' DynFlags
dflags)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (TcGblEnv -> TcRef Bool
tcg_safe_infer TcGblEnv
tcg_env) Bool
False
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (TcGblEnv -> TcRef (Messages TcRnMessage)
tcg_safe_infer_reasons TcGblEnv
tcg_env) forall e. Messages e
emptyMessages
case Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags) of
Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ TcGblEnv
tcg_env { tcg_imports :: ImportAvails
tcg_imports = ImportAvails
wiped_trust }
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
where
wiped_trust :: ImportAvails
wiped_trust = (TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env) { imp_trust_pkgs :: Set UnitId
imp_trust_pkgs = forall a. Set a
S.empty }
pprMod :: SDoc
pprMod = forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ forall unit. GenModule unit -> ModuleName
moduleName forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
whyUnsafe' :: DynFlags -> SDoc
whyUnsafe' DynFlags
df = forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> SDoc
quotes SDoc
pprMod forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => [Char] -> doc
text [Char]
"has been inferred as unsafe!"
, forall doc. IsLine doc => [Char] -> doc
text [Char]
"Reason:"
, Int -> SDoc -> SDoc
nest Int
4 forall a b. (a -> b) -> a -> b
$ (forall doc. IsDoc doc => [doc] -> doc
vcat forall a b. (a -> b) -> a -> b
$ DynFlags -> [SDoc]
badFlags DynFlags
df) SDoc -> SDoc -> SDoc
$+$
(forall doc. IsDoc doc => [doc] -> doc
vcat forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (forall a. Diagnostic a => DiagnosticOpts a
defaultDiagnosticOpts @e) (forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages e
whyUnsafe)) SDoc -> SDoc -> SDoc
$+$
(forall doc. IsDoc doc => [doc] -> doc
vcat forall a b. (a -> b) -> a -> b
$ forall {t :: * -> *}. Foldable t => t ClsInst -> [SDoc]
badInsts forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
tcg_env)
]
badFlags :: DynFlags -> [SDoc]
badFlags DynFlags
df = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall {t} {d}. t -> ([Char], t -> SrcSpan, t -> Bool, d) -> [SDoc]
badFlag DynFlags
df) [([Char], DynFlags -> SrcSpan, DynFlags -> Bool,
DynFlags -> DynFlags)]
unsafeFlagsForInfer
badFlag :: t -> ([Char], t -> SrcSpan, t -> Bool, d) -> [SDoc]
badFlag t
df ([Char]
str,t -> SrcSpan
loc,t -> Bool
on,d
_)
| t -> Bool
on t
df = [MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCOutput (t -> SrcSpan
loc t
df) forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => [Char] -> doc
text [Char]
str forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => [Char] -> doc
text [Char]
"is not allowed in Safe Haskell"]
| Bool
otherwise = []
badInsts :: t ClsInst -> [SDoc]
badInsts t ClsInst
insts = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap ClsInst -> [SDoc]
badInst t ClsInst
insts
checkOverlap :: OverlapMode -> Bool
checkOverlap (NoOverlap SourceText
_) = Bool
False
checkOverlap OverlapMode
_ = Bool
True
badInst :: ClsInst -> [SDoc]
badInst ClsInst
ins | OverlapMode -> Bool
checkOverlap (OverlapFlag -> OverlapMode
overlapMode (ClsInst -> OverlapFlag
is_flag ClsInst
ins))
= [MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCOutput (Name -> SrcSpan
nameSrcSpan forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> Name
getName forall a b. (a -> b) -> a -> b
$ ClsInst -> Id
is_dfun ClsInst
ins) forall a b. (a -> b) -> a -> b
$
forall a. Outputable a => a -> SDoc
ppr (OverlapFlag -> OverlapMode
overlapMode forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
ins) forall doc. IsLine doc => doc -> doc -> doc
<+>
forall doc. IsLine doc => [Char] -> doc
text [Char]
"overlap mode isn't allowed in Safe Haskell"]
| Bool
otherwise = []
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode :: TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode TcGblEnv
tcg_env = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags -> TcGblEnv -> IO SafeHaskellMode
finalSafeMode DynFlags
dflags TcGblEnv
tcg_env
hscSimplify :: HscEnv -> [String] -> ModGuts -> IO ModGuts
hscSimplify :: HscEnv -> [[Char]] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [[Char]]
plugins ModGuts
modguts =
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ [[Char]] -> ModGuts -> Hsc ModGuts
hscSimplify' [[Char]]
plugins ModGuts
modguts
hscSimplify' :: [String] -> ModGuts -> Hsc ModGuts
hscSimplify' :: [[Char]] -> ModGuts -> Hsc ModGuts
hscSimplify' [[Char]]
plugins ModGuts
ds_result = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
HscEnv
hsc_env_with_plugins <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [[Char]]
plugins
then forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
initializePlugins
forall a b. (a -> b) -> a -> b
$ (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags (\DynFlags
dflags -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> DynFlags -> DynFlags
addPluginModuleName DynFlags
dflags [[Char]]
plugins)
HscEnv
hsc_env
{-# SCC "Core2Core" #-}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO ModGuts
core2core HscEnv
hsc_env_with_plugins ModGuts
ds_result
hscSimpleIface :: HscEnv
-> Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
hscSimpleIface :: HscEnv
-> Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env Maybe CoreProgram
mb_core_program TcGblEnv
tc_result ModSummary
summary
= forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ Maybe CoreProgram
-> TcGblEnv -> ModSummary -> Hsc (ModIface, ModDetails)
hscSimpleIface' Maybe CoreProgram
mb_core_program TcGblEnv
tc_result ModSummary
summary
hscSimpleIface' :: Maybe CoreProgram
-> TcGblEnv
-> ModSummary
-> Hsc (ModIface, ModDetails)
hscSimpleIface' :: Maybe CoreProgram
-> TcGblEnv -> ModSummary -> Hsc (ModIface, ModDetails)
hscSimpleIface' Maybe CoreProgram
mb_core_program TcGblEnv
tc_result ModSummary
summary = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
ModDetails
details <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc Logger
logger TcGblEnv
tc_result
SafeHaskellMode
safe_mode <- TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode TcGblEnv
tc_result
ModIface
new_iface
<- {-# SCC "MkFinalIface" #-}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
HscEnv
-> SafeHaskellMode
-> ModDetails
-> ModSummary
-> Maybe CoreProgram
-> TcGblEnv
-> IO ModIface
mkIfaceTc HscEnv
hsc_env SafeHaskellMode
safe_mode ModDetails
details ModSummary
summary Maybe CoreProgram
mb_core_program TcGblEnv
tc_result
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
new_iface, ModDetails
details)
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
hscGenHardCode :: HscEnv
-> CgGuts
-> ModLocation
-> [Char]
-> IO
([Char], Maybe [Char], [(ForeignSrcLang, [Char])],
Maybe StgCgInfos, Maybe CmmCgInfos)
hscGenHardCode HscEnv
hsc_env CgGuts
cgguts ModLocation
location [Char]
output_filename = do
let CgGuts{
cg_module :: CgGuts -> Module
cg_module = Module
this_mod,
cg_binds :: CgGuts -> CoreProgram
cg_binds = CoreProgram
core_binds,
cg_ccs :: CgGuts -> [CostCentre]
cg_ccs = [CostCentre]
local_ccs,
cg_tycons :: CgGuts -> [TyCon]
cg_tycons = [TyCon]
tycons,
cg_foreign :: CgGuts -> ForeignStubs
cg_foreign = ForeignStubs
foreign_stubs0,
cg_foreign_files :: CgGuts -> [(ForeignSrcLang, [Char])]
cg_foreign_files = [(ForeignSrcLang, [Char])]
foreign_files,
cg_dep_pkgs :: CgGuts -> Set UnitId
cg_dep_pkgs = Set UnitId
dependencies,
cg_hpc_info :: CgGuts -> HpcInfo
cg_hpc_info = HpcInfo
hpc_info,
cg_spt_entries :: CgGuts -> [SptEntry]
cg_spt_entries = [SptEntry]
spt_entries
} = CgGuts
cgguts
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
llvm_config :: LlvmConfigCache
llvm_config = HscEnv -> LlvmConfigCache
hsc_llvm_config HscEnv
hsc_env
profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
data_tycons :: [TyCon]
data_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
(CoreProgram
late_cc_binds, [CostCentre]
late_local_ccs) <-
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateCcs DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateInlineCcs DynFlags
dflags)
then {-# SCC lateCC #-} do
(CoreProgram
binds,Set CostCentre
late_ccs) <- DynFlags
-> Logger
-> Module
-> CoreProgram
-> IO (CoreProgram, Set CostCentre)
addLateCostCentresPgm DynFlags
dflags Logger
logger Module
this_mod CoreProgram
core_binds
forall (m :: * -> *) a. Monad m => a -> m a
return ( CoreProgram
binds, (forall a. Set a -> [a]
S.toList Set CostCentre
late_ccs forall a. Monoid a => a -> a -> a
`mappend` [CostCentre]
local_ccs ))
else
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram
core_binds, [CostCentre]
local_ccs)
(CoreProgram
prepd_binds) <- {-# SCC "CorePrep" #-} do
CorePrepConfig
cp_cfg <- HscEnv -> IO CorePrepConfig
initCorePrepConfig HscEnv
hsc_env
Logger
-> CorePrepConfig
-> CorePrepPgmConfig
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm
(HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
CorePrepConfig
cp_cfg
(DynFlags -> [Id] -> CorePrepPgmConfig
initCorePrepPgmConfig (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (InteractiveContext -> [Id]
interactiveInScope forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env))
Module
this_mod ModLocation
location CoreProgram
late_cc_binds [TyCon]
data_tycons
([CgStgTopBinding]
stg_binds, InfoTableProvMap
denv, ([CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks), StgCgInfos
stg_cg_infos)
<- {-# SCC "CoreToStg" #-}
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(forall doc. IsLine doc => [Char] -> doc
text [Char]
"CoreToStg"forall doc. IsLine doc => doc -> doc -> doc
<+>forall doc. IsLine doc => doc -> doc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(\([CgStgTopBinding]
a, InfoTableProvMap
b, ([CostCentre]
c,[CostCentreStack]
d), StgCgInfos
tag_env) ->
[CgStgTopBinding]
a forall a b. [a] -> b -> b
`seqList`
InfoTableProvMap
b seq :: forall a b. a -> b -> b
`seq`
[CostCentre]
c forall a b. [a] -> b -> b
`seqList`
[CostCentreStack]
d forall a b. [a] -> b -> b
`seqList`
(forall elt key. (elt -> ()) -> UniqFM key elt -> ()
seqEltsUFM (TagSig -> ()
seqTagSig) StgCgInfos
tag_env))
(Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
([CgStgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg Logger
logger DynFlags
dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) Bool
False Module
this_mod ModLocation
location CoreProgram
prepd_binds)
let cost_centre_info :: ([CostCentre], [CostCentreStack])
cost_centre_info =
([CostCentre]
late_local_ccs forall a. [a] -> [a] -> [a]
++ [CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks)
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
prof_init :: CStub
prof_init
| DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags = Platform -> Module -> ([CostCentre], [CostCentreStack]) -> CStub
profilingInitCode Platform
platform Module
this_mod ([CostCentre], [CostCentreStack])
cost_centre_info
| Bool
otherwise = forall a. Monoid a => a
mempty
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (forall doc. IsLine doc => [Char] -> doc
text [Char]
"CodeGen"forall doc. IsLine doc => doc -> doc -> doc
<+>forall doc. IsLine doc => doc -> doc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
this_mod)) (forall a b. a -> b -> a
const ())
forall a b. (a -> b) -> a -> b
$ case Backend -> DefunctionalizedCodeOutput
backendCodeOutput (DynFlags -> Backend
backend DynFlags
dflags) of
DefunctionalizedCodeOutput
JSCodeOutput ->
do
let js_config :: StgToJSConfig
js_config = DynFlags -> StgToJSConfig
initStgToJSConfig DynFlags
dflags
cmm_cg_infos :: Maybe a
cmm_cg_infos = forall a. Maybe a
Nothing
stub_c_exists :: Maybe a
stub_c_exists = forall a. Maybe a
Nothing
foreign_fps :: [a]
foreign_fps = []
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_stg_final [Char]
"Final STG:" DumpFormat
FormatSTG
(forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings (DynFlags -> StgPprOpts
initStgPprOpts DynFlags
dflags) [CgStgTopBinding]
stg_binds)
Logger
-> StgToJSConfig
-> [CgStgTopBinding]
-> Module
-> [SptEntry]
-> ForeignStubs
-> ([CostCentre], [CostCentreStack])
-> [Char]
-> IO ()
stgToJS Logger
logger StgToJSConfig
js_config [CgStgTopBinding]
stg_binds Module
this_mod [SptEntry]
spt_entries ForeignStubs
foreign_stubs0 ([CostCentre], [CostCentreStack])
cost_centre_info [Char]
output_filename
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
output_filename, forall a. Maybe a
stub_c_exists, forall a. [a]
foreign_fps, forall a. a -> Maybe a
Just StgCgInfos
stg_cg_infos, forall a. Maybe a
cmm_cg_infos)
DefunctionalizedCodeOutput
_ ->
do
Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
cmms <- {-# SCC "StgToCmm" #-}
HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos)
doCodeGen HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons
([CostCentre], [CostCentreStack])
cost_centre_info
[CgStgTopBinding]
stg_binds HpcInfo
hpc_info
Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CmmCgInfos
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
case Hooks
-> forall a.
Maybe
(DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a))
cmmToRawCmmHook Hooks
hooks of
Maybe
(DynFlags
-> Maybe Module
-> Stream
IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
-> IO
(Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CmmCgInfos))
Nothing -> forall a.
Logger
-> Profile
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a)
cmmToRawCmm Logger
logger Profile
profile Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
cmms
Just DynFlags
-> Maybe Module
-> Stream
IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
-> IO
(Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CmmCgInfos)
h -> DynFlags
-> Maybe Module
-> Stream
IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
-> IO
(Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CmmCgInfos)
h DynFlags
dflags (forall a. a -> Maybe a
Just Module
this_mod) Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
cmms
let dump :: [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
dump [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a) forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm_raw [Char]
"Raw Cmm" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a)
forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a
rawcmms1 :: Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CmmCgInfos
rawcmms1 = forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
dump Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CmmCgInfos
rawcmms0
let foreign_stubs :: CmmCgInfos -> ForeignStubs
foreign_stubs CmmCgInfos
st = ForeignStubs
foreign_stubs0
ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
prof_init
ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CmmCgInfos -> CStub
cgIPEStub CmmCgInfos
st
([Char]
output_filename, (Bool
_stub_h_exists, Maybe [Char]
stub_c_exists), [(ForeignSrcLang, [Char])]
foreign_fps, CmmCgInfos
cmm_cg_infos)
<- {-# SCC "codeOutput" #-}
forall a.
Logger
-> TmpFs
-> LlvmConfigCache
-> DynFlags
-> UnitState
-> Module
-> [Char]
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, [Char])]
-> Set UnitId
-> Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a
-> IO ([Char], (Bool, Maybe [Char]), [(ForeignSrcLang, [Char])], a)
codeOutput Logger
logger TmpFs
tmpfs LlvmConfigCache
llvm_config DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
this_mod [Char]
output_filename ModLocation
location
CmmCgInfos -> ForeignStubs
foreign_stubs [(ForeignSrcLang, [Char])]
foreign_files Set UnitId
dependencies Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CmmCgInfos
rawcmms1
forall (m :: * -> *) a. Monad m => a -> m a
return ( [Char]
output_filename, Maybe [Char]
stub_c_exists, [(ForeignSrcLang, [Char])]
foreign_fps
, forall a. a -> Maybe a
Just StgCgInfos
stg_cg_infos, forall a. a -> Maybe a
Just CmmCgInfos
cmm_cg_infos)
data CgInteractiveGuts = CgInteractiveGuts { CgInteractiveGuts -> Module
cgi_module :: Module
, CgInteractiveGuts -> CoreProgram
cgi_binds :: CoreProgram
, CgInteractiveGuts -> [TyCon]
cgi_tycons :: [TyCon]
, CgInteractiveGuts -> ForeignStubs
cgi_foreign :: ForeignStubs
, CgInteractiveGuts -> Maybe ModBreaks
cgi_modBreaks :: Maybe ModBreaks
, CgInteractiveGuts -> [SptEntry]
cgi_spt_entries :: [SptEntry]
}
mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts
mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts
mkCgInteractiveGuts CgGuts{Module
cg_module :: Module
cg_module :: CgGuts -> Module
cg_module, CoreProgram
cg_binds :: CoreProgram
cg_binds :: CgGuts -> CoreProgram
cg_binds, [TyCon]
cg_tycons :: [TyCon]
cg_tycons :: CgGuts -> [TyCon]
cg_tycons, ForeignStubs
cg_foreign :: ForeignStubs
cg_foreign :: CgGuts -> ForeignStubs
cg_foreign, Maybe ModBreaks
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks :: Maybe ModBreaks
cg_modBreaks, [SptEntry]
cg_spt_entries :: [SptEntry]
cg_spt_entries :: CgGuts -> [SptEntry]
cg_spt_entries}
= Module
-> CoreProgram
-> [TyCon]
-> ForeignStubs
-> Maybe ModBreaks
-> [SptEntry]
-> CgInteractiveGuts
CgInteractiveGuts Module
cg_module CoreProgram
cg_binds [TyCon]
cg_tycons ForeignStubs
cg_foreign Maybe ModBreaks
cg_modBreaks [SptEntry]
cg_spt_entries
hscInteractive :: HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive :: HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO (Maybe [Char], CompiledByteCode, [SptEntry])
hscInteractive HscEnv
hsc_env CgInteractiveGuts
cgguts ModLocation
location = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
let CgInteractiveGuts{
cgi_module :: CgInteractiveGuts -> Module
cgi_module = Module
this_mod,
cgi_binds :: CgInteractiveGuts -> CoreProgram
cgi_binds = CoreProgram
core_binds,
cgi_tycons :: CgInteractiveGuts -> [TyCon]
cgi_tycons = [TyCon]
tycons,
cgi_foreign :: CgInteractiveGuts -> ForeignStubs
cgi_foreign = ForeignStubs
foreign_stubs,
cgi_modBreaks :: CgInteractiveGuts -> Maybe ModBreaks
cgi_modBreaks = Maybe ModBreaks
mod_breaks,
cgi_spt_entries :: CgInteractiveGuts -> [SptEntry]
cgi_spt_entries = [SptEntry]
spt_entries } = CgInteractiveGuts
cgguts
data_tycons :: [TyCon]
data_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
CoreProgram
prepd_binds <- {-# SCC "CorePrep" #-} do
CorePrepConfig
cp_cfg <- HscEnv -> IO CorePrepConfig
initCorePrepConfig HscEnv
hsc_env
Logger
-> CorePrepConfig
-> CorePrepPgmConfig
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm
(HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
CorePrepConfig
cp_cfg
(DynFlags -> [Id] -> CorePrepPgmConfig
initCorePrepPgmConfig (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (InteractiveContext -> [Id]
interactiveInScope forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env))
Module
this_mod ModLocation
location CoreProgram
core_binds [TyCon]
data_tycons
([CgStgTopBinding]
stg_binds, InfoTableProvMap
_infotable_prov, ([CostCentre], [CostCentreStack])
_caf_ccs__caf_cc_stacks, StgCgInfos
_ignore_stg_cg_infos)
<- {-# SCC "CoreToStg" #-}
Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
([CgStgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg Logger
logger DynFlags
dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) Bool
True Module
this_mod ModLocation
location CoreProgram
prepd_binds
CompiledByteCode
comp_bc <- HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod [CgStgTopBinding]
stg_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks
(Bool
_istub_h_exists, Maybe [Char]
istub_c_exists)
<- Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe [Char])
outputForeignStubs Logger
logger TmpFs
tmpfs DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
this_mod ModLocation
location ForeignStubs
foreign_stubs
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char]
istub_c_exists, CompiledByteCode
comp_bc, [SptEntry]
spt_entries)
generateByteCode :: HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO [Unlinked]
generateByteCode :: HscEnv -> CgInteractiveGuts -> ModLocation -> IO [Unlinked]
generateByteCode HscEnv
hsc_env CgInteractiveGuts
cgguts ModLocation
mod_location = do
(Maybe [Char]
hasStub, CompiledByteCode
comp_bc, [SptEntry]
spt_entries) <- HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO (Maybe [Char], CompiledByteCode, [SptEntry])
hscInteractive HscEnv
hsc_env CgInteractiveGuts
cgguts ModLocation
mod_location
[Unlinked]
stub_o <- case Maybe [Char]
hasStub of
Maybe [Char]
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Just [Char]
stub_c -> do
[Char]
stub_o <- HscEnv -> ForeignSrcLang -> [Char] -> IO [Char]
compileForeign HscEnv
hsc_env ForeignSrcLang
LangC [Char]
stub_c
forall (m :: * -> *) a. Monad m => a -> m a
return [[Char] -> Unlinked
DotO [Char]
stub_o]
let hs_unlinked :: [Unlinked]
hs_unlinked = [CompiledByteCode -> [SptEntry] -> Unlinked
BCOs CompiledByteCode
comp_bc [SptEntry]
spt_entries]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Unlinked]
hs_unlinked forall a. [a] -> [a] -> [a]
++ [Unlinked]
stub_o)
generateFreshByteCode :: HscEnv
-> ModuleName
-> CgInteractiveGuts
-> ModLocation
-> IO Linkable
generateFreshByteCode :: HscEnv
-> ModuleName -> CgInteractiveGuts -> ModLocation -> IO Linkable
generateFreshByteCode HscEnv
hsc_env ModuleName
mod_name CgInteractiveGuts
cgguts ModLocation
mod_location = do
[Unlinked]
ul <- HscEnv -> CgInteractiveGuts -> ModLocation -> IO [Unlinked]
generateByteCode HscEnv
hsc_env CgInteractiveGuts
cgguts ModLocation
mod_location
UTCTime
unlinked_time <- IO UTCTime
getCurrentTime
let !linkable :: Linkable
linkable = UTCTime -> Module -> [Unlinked] -> Linkable
LM UTCTime
unlinked_time (HomeUnit -> ModuleName -> Module
mkHomeModule (HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env) ModuleName
mod_name) [Unlinked]
ul
forall (m :: * -> *) a. Monad m => a -> m a
return Linkable
linkable
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
hscCompileCmmFile :: HscEnv -> [Char] -> [Char] -> [Char] -> IO (Maybe [Char])
hscCompileCmmFile HscEnv
hsc_env [Char]
original_filename [Char]
filename [Char]
output_filename = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
llvm_config :: LlvmConfigCache
llvm_config = HscEnv -> LlvmConfigCache
hsc_llvm_config HscEnv
hsc_env
cmm_config :: CmmConfig
cmm_config = DynFlags -> CmmConfig
initCmmConfig DynFlags
dflags
do_info_table :: Bool
do_info_table = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags
mod_name :: ModuleName
mod_name = [Char] -> ModuleName
mkModuleName forall a b. (a -> b) -> a -> b
$ [Char]
"Cmm$" forall a. [a] -> [a] -> [a]
++ [Char]
original_filename
cmm_mod :: Module
cmm_mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
cmmpConfig :: CmmParserConfig
cmmpConfig = DynFlags -> CmmParserConfig
initCmmParserConfig DynFlags
dflags
([GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
cmm, [InfoProvEnt]
ipe_ents) <- forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe
forall a b. (a -> b) -> a -> b
$ do
(Messages PsWarning
warns,Messages PsWarning
errs,Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt])
cmm) <- forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger (forall doc. IsLine doc => [Char] -> doc
text [Char]
"ParseCmm"forall doc. IsLine doc => doc -> doc -> doc
<+>forall doc. IsLine doc => doc -> doc
brackets (forall doc. IsLine doc => [Char] -> doc
text [Char]
filename)) (\(Messages PsWarning, Messages PsWarning,
Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt]))
_ -> ())
forall a b. (a -> b) -> a -> b
$ CmmParserConfig
-> Module
-> HomeUnit
-> [Char]
-> IO
(Messages PsWarning, Messages PsWarning,
Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt]))
parseCmmFile CmmParserConfig
cmmpConfig Module
cmm_mod HomeUnit
home_unit [Char]
filename
let msgs :: Messages PsWarning
msgs = Messages PsWarning
warns forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages PsWarning
errs
forall (m :: * -> *) a. Monad m => a -> m a
return (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
msgs, Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt])
cmm)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm_verbose_by_proc [Char]
"Parsed Cmm" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
cmm)
[GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
cmmgroup <-
forall (m :: * -> *) (f :: * -> *) a b.
(Monad m, Traversable f) =>
(a -> m [b]) -> f a -> m [b]
concatMapM (\GenCmmDecl CmmStatics CmmTopInfo CmmGraph
cmm -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Logger
-> CmmConfig
-> ModuleSRTInfo
-> [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
-> IO
(ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
cmmPipeline Logger
logger CmmConfig
cmm_config (Module -> ModuleSRTInfo
emptySRT Module
cmm_mod) [GenCmmDecl CmmStatics CmmTopInfo CmmGraph
cmm]) [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
cmm
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
cmmgroup) forall a b. (a -> b) -> a -> b
$
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm [Char]
"Output Cmm"
DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
cmmgroup)
Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ()
rawCmms <- case Hooks
-> forall a.
Maybe
(DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a))
cmmToRawCmmHook Hooks
hooks of
Maybe
(DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] ()
-> IO
(Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
()))
Nothing -> forall a.
Logger
-> Profile
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a)
cmmToRawCmm Logger
logger Profile
profile (forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
cmmgroup)
Just DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] ()
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ())
h -> DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] ()
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ())
h DynFlags
dflags forall a. Maybe a
Nothing (forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
cmmgroup)
let foreign_stubs :: () -> ForeignStubs
foreign_stubs ()
_
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InfoProvEnt]
ipe_ents =
let ip_init :: CStub
ip_init = Bool -> Platform -> Module -> CStub
ipInitCode Bool
do_info_table Platform
platform Module
cmm_mod
in ForeignStubs
NoStubs ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
ip_init
| Bool
otherwise = ForeignStubs
NoStubs
([Char]
_output_filename, (Bool
_stub_h_exists, Maybe [Char]
stub_c_exists), [(ForeignSrcLang, [Char])]
_foreign_fps, ()
_caf_infos)
<- forall a.
Logger
-> TmpFs
-> LlvmConfigCache
-> DynFlags
-> UnitState
-> Module
-> [Char]
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, [Char])]
-> Set UnitId
-> Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a
-> IO ([Char], (Bool, Maybe [Char]), [(ForeignSrcLang, [Char])], a)
codeOutput Logger
logger TmpFs
tmpfs LlvmConfigCache
llvm_config DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
cmm_mod [Char]
output_filename ModLocation
no_loc () -> ForeignStubs
foreign_stubs [] forall a. Set a
S.empty
Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ()
rawCmms
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
stub_c_exists
where
no_loc :: ModLocation
no_loc = ModLocation{ ml_hs_file :: Maybe [Char]
ml_hs_file = forall a. a -> Maybe a
Just [Char]
original_filename,
ml_hi_file :: [Char]
ml_hi_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no hi file",
ml_obj_file :: [Char]
ml_obj_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no obj file",
ml_dyn_obj_file :: [Char]
ml_dyn_obj_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no dyn obj file",
ml_dyn_hi_file :: [Char]
ml_dyn_hi_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no dyn obj file",
ml_hie_file :: [Char]
ml_hie_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no hie file"}
doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [CgStgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroupSRTs CmmCgInfos)
doCodeGen :: HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos)
doCodeGen HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons
([CostCentre], [CostCentreStack])
cost_centre_info [CgStgTopBinding]
stg_binds_w_fvs HpcInfo
hpc_info = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
stg_ppr_opts :: StgPprOpts
stg_ppr_opts = (DynFlags -> StgPprOpts
initStgPprOpts DynFlags
dflags)
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_stg_final [Char]
"Final STG:" DumpFormat
FormatSTG
(forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings StgPprOpts
stg_ppr_opts [CgStgTopBinding]
stg_binds_w_fvs)
let stg_to_cmm :: DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
stg_to_cmm DynFlags
dflags Module
mod = case Hooks
-> Maybe
(StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos)
stgToCmmHook Hooks
hooks of
Maybe
(StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos)
Nothing -> Logger
-> TmpFs
-> StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
StgToCmm.codeGen Logger
logger TmpFs
tmpfs (DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig DynFlags
dflags Module
mod)
Just StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
h -> StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
h (DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig DynFlags
dflags Module
mod)
let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
cmm_stream :: Stream IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
cmm_stream = [CgStgTopBinding]
stg_binds_w_fvs forall a b. [a] -> b -> b
`seqList` {-# SCC "StgToCmm" #-}
DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
stg_to_cmm DynFlags
dflags Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons ([CostCentre], [CostCentreStack])
cost_centre_info [CgStgTopBinding]
stg_binds_w_fvs HpcInfo
hpc_info
let dump1 :: [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
dump1 [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
a = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
a) forall a b. (a -> b) -> a -> b
$
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm_from_stg
[Char]
"Cmm produced by codegen" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
a)
forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
a
ppr_stream1 :: Stream IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
ppr_stream1 = forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
dump1 Stream IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
cmm_stream
cmm_config :: CmmConfig
cmm_config = DynFlags -> CmmConfig
initCmmConfig DynFlags
dflags
pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
pipeline_stream :: Stream
IO
[GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
(NonCaffySet, ModuleLFInfos)
pipeline_stream = do
(NonCaffySet
non_cafs, ModuleLFInfos
lf_infos) <-
{-# SCC "cmmPipeline" #-}
forall (m :: * -> *) a b c r.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)
Stream.mapAccumL_ (Logger
-> CmmConfig
-> ModuleSRTInfo
-> [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
-> IO
(ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
cmmPipeline Logger
logger CmmConfig
cmm_config) (Module -> ModuleSRTInfo
emptySRT Module
this_mod) Stream IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
ppr_stream1
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SRTMap -> NonCaffySet
srtMapNonCAFs forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleSRTInfo -> SRTMap
moduleSRTMap)
forall (m :: * -> *) a. Monad m => a -> m a
return (NonCaffySet
non_cafs, ModuleLFInfos
lf_infos)
dump2 :: [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
dump2 [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a) forall a b. (a -> b) -> a -> b
$
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm [Char]
"Output Cmm" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a)
forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
dump2 forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> InfoTableProvMap
-> Stream
IO
[GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
(NonCaffySet, ModuleLFInfos)
-> Stream
IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
generateCgIPEStub HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv Stream
IO
[GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
(NonCaffySet, ModuleLFInfos)
pipeline_stream
myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
-> Bool
-> Module -> ModLocation -> CoreExpr
-> IO ( Id
, [CgStgTopBinding]
, InfoTableProvMap
, CollectedCCs
, StgCgInfos )
myCoreToStgExpr :: Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreExpr
-> IO
(Id, [CgStgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStgExpr Logger
logger DynFlags
dflags InteractiveContext
ictxt Bool
for_bytecode Module
this_mod ModLocation
ml CoreExpr
prepd_expr = do
let bco_tmp_id :: Id
bco_tmp_id = FastString -> Unique -> Mult -> Mult -> Id
mkSysLocal ([Char] -> FastString
fsLit [Char]
"BCO_toplevel")
(Int -> Unique
mkPseudoUniqueE Int
0)
Mult
ManyTy
(HasDebugCallStack => CoreExpr -> Mult
exprType CoreExpr
prepd_expr)
([CgStgTopBinding]
stg_binds, InfoTableProvMap
prov_map, ([CostCentre], [CostCentreStack])
collected_ccs, StgCgInfos
stg_cg_infos) <-
Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
([CgStgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg Logger
logger
DynFlags
dflags
InteractiveContext
ictxt
Bool
for_bytecode
Module
this_mod
ModLocation
ml
[forall b. b -> Expr b -> Bind b
NonRec Id
bco_tmp_id CoreExpr
prepd_expr]
forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bco_tmp_id, [CgStgTopBinding]
stg_binds, InfoTableProvMap
prov_map, ([CostCentre], [CostCentreStack])
collected_ccs, StgCgInfos
stg_cg_infos)
myCoreToStg :: Logger -> DynFlags -> InteractiveContext
-> Bool
-> Module -> ModLocation -> CoreProgram
-> IO ( [CgStgTopBinding]
, InfoTableProvMap
, CollectedCCs
, StgCgInfos )
myCoreToStg :: Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
([CgStgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg Logger
logger DynFlags
dflags InteractiveContext
ictxt Bool
for_bytecode Module
this_mod ModLocation
ml CoreProgram
prepd_binds = do
let ([StgTopBinding]
stg_binds, InfoTableProvMap
denv, ([CostCentre], [CostCentreStack])
cost_centre_info)
= {-# SCC "Core2Stg" #-}
CoreToStgOpts
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
coreToStg (DynFlags -> CoreToStgOpts
initCoreToStgOpts DynFlags
dflags) Module
this_mod ModLocation
ml CoreProgram
prepd_binds
([CgStgTopBinding]
stg_binds_with_fvs,StgCgInfos
stg_cg_info)
<- {-# SCC "Stg2Stg" #-}
Logger
-> [Id]
-> StgPipelineOpts
-> Module
-> [StgTopBinding]
-> IO ([CgStgTopBinding], StgCgInfos)
stg2stg Logger
logger (InteractiveContext -> [Id]
interactiveInScope InteractiveContext
ictxt) (DynFlags -> Bool -> StgPipelineOpts
initStgPipelineOpts DynFlags
dflags Bool
for_bytecode)
Module
this_mod [StgTopBinding]
stg_binds
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_stg_cg [Char]
"CodeGenInput STG:" DumpFormat
FormatSTG
(forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings (DynFlags -> StgPprOpts
initStgPprOpts DynFlags
dflags) [CgStgTopBinding]
stg_binds_with_fvs)
forall (m :: * -> *) a. Monad m => a -> m a
return ([CgStgTopBinding]
stg_binds_with_fvs, InfoTableProvMap
denv, ([CostCentre], [CostCentreStack])
cost_centre_info, StgCgInfos
stg_cg_info)
hscStmt :: HscEnv -> String -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmt :: HscEnv -> [Char] -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmt HscEnv
hsc_env [Char]
stmt = HscEnv
-> [Char]
-> [Char]
-> Int
-> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmtWithLocation HscEnv
hsc_env [Char]
stmt [Char]
"<interactive>" Int
1
hscStmtWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscStmtWithLocation :: HscEnv
-> [Char]
-> [Char]
-> Int
-> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscStmtWithLocation HscEnv
hsc_env0 [Char]
stmt [Char]
source Int
linenumber =
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt <- [Char] -> Int -> [Char] -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation [Char]
source Int
linenumber [Char]
stmt
case Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt of
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
parsed_stmt -> do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
parsed_stmt
hscParsedStmt :: HscEnv
-> GhciLStmt GhcPs
-> IO ( Maybe ([Id]
, ForeignHValue
, FixityEnv))
hscParsedStmt :: HscEnv
-> GhciLStmt GhcPs -> IO (Maybe ([Id], ForeignHValue, FixityEnv))
hscParsedStmt HscEnv
hsc_env GhciLStmt GhcPs
stmt = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
([Id]
ids, GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr, FixityEnv
fix_env) <- forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs
-> IO
(Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
stmt
CoreExpr
ds_expr <- forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages DsMessage, a) -> m (Messages GhcMessage, a)
hoistDsMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
deSugarExpr HscEnv
hsc_env GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SDoc -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr (forall doc. IsLine doc => [Char] -> doc
text [Char]
"desugar expression") HscEnv
hsc_env CoreExpr
ds_expr)
Hsc ()
handleWarnings
let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
(ForeignHValue
hval,[Linkable]
_,PkgsLoaded
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
src_span CoreExpr
ds_expr
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([Id]
ids, ForeignHValue
hval, FixityEnv
fix_env)
hscDecls :: HscEnv
-> String
-> IO ([TyThing], InteractiveContext)
hscDecls :: HscEnv -> [Char] -> IO ([TyThing], InteractiveContext)
hscDecls HscEnv
hsc_env [Char]
str = HscEnv
-> [Char] -> [Char] -> Int -> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation HscEnv
hsc_env [Char]
str [Char]
"<interactive>" Int
1
hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO (HsModule GhcPs)
hscParseModuleWithLocation :: HscEnv -> [Char] -> Int -> [Char] -> IO (HsModule GhcPs)
hscParseModuleWithLocation HscEnv
hsc_env [Char]
source Int
line_num [Char]
str = do
L SrcSpan
_ HsModule GhcPs
mod <-
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$
forall thing.
(Outputable thing, Data thing) =>
[Char] -> Int -> P thing -> [Char] -> Hsc thing
hscParseThingWithLocation [Char]
source Int
line_num P (Located (HsModule GhcPs))
parseModule [Char]
str
forall (m :: * -> *) a. Monad m => a -> m a
return HsModule GhcPs
mod
hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation :: HscEnv -> [Char] -> Int -> [Char] -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation HscEnv
hsc_env [Char]
source Int
line_num [Char]
str = do
HsModule { hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
hsmodDecls = [LHsDecl GhcPs]
decls } <- HscEnv -> [Char] -> Int -> [Char] -> IO (HsModule GhcPs)
hscParseModuleWithLocation HscEnv
hsc_env [Char]
source Int
line_num [Char]
str
forall (m :: * -> *) a. Monad m => a -> m a
return [LHsDecl GhcPs]
decls
hscDeclsWithLocation :: HscEnv
-> String
-> String
-> Int
-> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation :: HscEnv
-> [Char] -> [Char] -> Int -> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation HscEnv
hsc_env [Char]
str [Char]
source Int
linenumber = do
L SrcSpan
_ (HsModule{ hsmodDecls :: forall p. HsModule p -> [LHsDecl p]
hsmodDecls = [LHsDecl GhcPs]
decls }) <-
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$
forall thing.
(Outputable thing, Data thing) =>
[Char] -> Int -> P thing -> [Char] -> Hsc thing
hscParseThingWithLocation [Char]
source Int
linenumber P (Located (HsModule GhcPs))
parseModule [Char]
str
HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
TcGblEnv
tc_gblenv <- forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LHsDecl GhcPs] -> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnDeclsi HscEnv
hsc_env [LHsDecl GhcPs]
decls
let defaults :: Maybe [Mult]
defaults = TcGblEnv -> Maybe [Mult]
tcg_default TcGblEnv
tc_gblenv
let iNTERACTIVELoc :: ModLocation
iNTERACTIVELoc = ModLocation{ ml_hs_file :: Maybe [Char]
ml_hs_file = forall a. Maybe a
Nothing,
ml_hi_file :: [Char]
ml_hi_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_hi_file",
ml_obj_file :: [Char]
ml_obj_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_obj_file",
ml_dyn_obj_file :: [Char]
ml_dyn_obj_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_dyn_obj_file",
ml_dyn_hi_file :: [Char]
ml_dyn_hi_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_dyn_hi_file",
ml_hie_file :: [Char]
ml_hie_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_hie_file" }
ModGuts
ds_result <- ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' ModLocation
iNTERACTIVELoc TcGblEnv
tc_gblenv
ModGuts
simpl_mg <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
[[Char]]
plugins <- forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef [[Char]]
tcg_th_coreplugins TcGblEnv
tc_gblenv)
HscEnv -> [[Char]] -> ModGuts -> IO ModGuts
hscSimplify HscEnv
hsc_env [[Char]]
plugins ModGuts
ds_result
(CgGuts
tidy_cg, ModDetails
mod_details) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy HscEnv
hsc_env ModGuts
simpl_mg
let !CgGuts{ cg_module :: CgGuts -> Module
cg_module = Module
this_mod,
cg_binds :: CgGuts -> CoreProgram
cg_binds = CoreProgram
core_binds,
cg_tycons :: CgGuts -> [TyCon]
cg_tycons = [TyCon]
tycons,
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
mod_breaks } = CgGuts
tidy_cg
!ModDetails { md_insts :: ModDetails -> InstEnv
md_insts = InstEnv
cls_insts
, md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
fam_insts } = ModDetails
mod_details
data_tycons :: [TyCon]
data_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
CoreProgram
prepd_binds <- {-# SCC "CorePrep" #-} forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
CorePrepConfig
cp_cfg <- HscEnv -> IO CorePrepConfig
initCorePrepConfig HscEnv
hsc_env
Logger
-> CorePrepConfig
-> CorePrepPgmConfig
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm
(HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
CorePrepConfig
cp_cfg
(DynFlags -> [Id] -> CorePrepPgmConfig
initCorePrepPgmConfig (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) (InteractiveContext -> [Id]
interactiveInScope forall a b. (a -> b) -> a -> b
$ HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env))
Module
this_mod ModLocation
iNTERACTIVELoc CoreProgram
core_binds [TyCon]
data_tycons
([CgStgTopBinding]
stg_binds, InfoTableProvMap
_infotable_prov, ([CostCentre], [CostCentreStack])
_caf_ccs__caf_cc_stacks, StgCgInfos
_stg_cg_info)
<- {-# SCC "CoreToStg" #-}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
([CgStgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
(HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
Bool
True
Module
this_mod
ModLocation
iNTERACTIVELoc
CoreProgram
prepd_binds
CompiledByteCode
cbc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod
[CgStgTopBinding]
stg_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks
let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> HscEnv
-> SrcSpan
-> CompiledByteCode
-> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
loadDecls Interp
interp HscEnv
hsc_env SrcSpan
src_span CompiledByteCode
cbc
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env (CgGuts -> [SptEntry]
cg_spt_entries CgGuts
tidy_cg)
let tcs :: [TyCon]
tcs = forall a. (a -> Bool) -> [a] -> [a]
filterOut TyCon -> Bool
isImplicitTyCon (ModGuts -> [TyCon]
mg_tcs ModGuts
simpl_mg)
patsyns :: [PatSyn]
patsyns = ModGuts -> [PatSyn]
mg_patsyns ModGuts
simpl_mg
ext_ids :: [Id]
ext_ids = [ Id
id | Id
id <- forall b. [Bind b] -> [b]
bindersOfBinds CoreProgram
core_binds
, Name -> Bool
isExternalName (Id -> Name
idName Id
id)
, Bool -> Bool
not (Id -> Bool
isDFunId Id
id Bool -> Bool -> Bool
|| Id -> Bool
isImplicitId Id
id) ]
new_tythings :: [TyThing]
new_tythings = forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId [Id]
ext_ids forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon [TyCon]
tcs forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map (ConLike -> TyThing
AConLike forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSyn -> ConLike
PatSynCon) [PatSyn]
patsyns
ictxt :: InteractiveContext
ictxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
fix_env :: FixityEnv
fix_env = TcGblEnv -> FixityEnv
tcg_fix_env TcGblEnv
tc_gblenv
new_ictxt :: InteractiveContext
new_ictxt = InteractiveContext
-> [TyThing]
-> InstEnv
-> [FamInst]
-> Maybe [Mult]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings InstEnv
cls_insts
[FamInst]
fam_insts Maybe [Mult]
defaults FixityEnv
fix_env
forall (m :: * -> *) a. Monad m => a -> m a
return ([TyThing]
new_tythings, InteractiveContext
new_ictxt)
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries :: HscEnv -> [SptEntry] -> IO ()
hscAddSptEntries HscEnv
hsc_env [SptEntry]
entries = do
let interp :: Interp
interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env
let add_spt_entry :: SptEntry -> IO ()
add_spt_entry :: SptEntry -> IO ()
add_spt_entry (SptEntry Id
i Fingerprint
fpr) = do
(ForeignHValue
val, [Linkable]
_, PkgsLoaded
_) <- Interp
-> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
loadName Interp
interp HscEnv
hsc_env (Id -> Name
idName Id
i)
Interp -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry Interp
interp Fingerprint
fpr ForeignHValue
val
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SptEntry -> IO ()
add_spt_entry [SptEntry]
entries
hscImport :: HscEnv -> String -> IO (ImportDecl GhcPs)
hscImport :: HscEnv -> [Char] -> IO (ImportDecl GhcPs)
hscImport HscEnv
hsc_env [Char]
str = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
forall thing.
(Outputable thing, Data thing) =>
P thing -> [Char] -> Hsc thing
hscParseThing P (Located (HsModule GhcPs))
parseModule [Char]
str forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(L SrcSpan
_ (HsModule{hsmodImports :: forall p. HsModule p -> [LImportDecl p]
hsmodImports=[LImportDecl GhcPs]
is})) ->
case [LImportDecl GhcPs]
is of
[L SrcSpanAnnA
_ ImportDecl GhcPs
i] -> forall (m :: * -> *) a. Monad m => a -> m a
return ImportDecl GhcPs
i
[LImportDecl GhcPs]
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
PsWarning -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic -> PsWarning
PsUnknownMessage forall a b. (a -> b) -> a -> b
$
forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => [Char] -> doc
text [Char]
"parse error in import declaration"
hscTcExpr :: HscEnv
-> TcRnExprMode
-> String
-> IO Type
hscTcExpr :: HscEnv -> TcRnExprMode -> [Char] -> IO Mult
hscTcExpr HscEnv
hsc_env0 TcRnExprMode
mode [Char]
expr = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- [Char] -> Hsc (LHsExpr GhcPs)
hscParseExpr [Char]
expr
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO (Messages TcRnMessage, Maybe Mult)
tcRnExpr HscEnv
hsc_env TcRnExprMode
mode GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr
hscKcType
:: HscEnv
-> Bool
-> String
-> IO (Type, Kind)
hscKcType :: HscEnv -> Bool -> [Char] -> IO (Mult, Mult)
hscKcType HscEnv
hsc_env0 Bool
normalise [Char]
str = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
GenLocated SrcSpanAnnA (HsType GhcPs)
ty <- [Char] -> Hsc (LHsType GhcPs)
hscParseType [Char]
str
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages TcRnMessage, Maybe (Mult, Mult))
tcRnType HscEnv
hsc_env ZonkFlexi
DefaultFlexi Bool
normalise GenLocated SrcSpanAnnA (HsType GhcPs)
ty
hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr :: [Char] -> Hsc (LHsExpr GhcPs)
hscParseExpr [Char]
expr = do
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt <- [Char] -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt [Char]
expr
case Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt of
Just (L SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) -> forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
_ -> forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
PsWarning -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic -> PsWarning
PsUnknownMessage forall a b. (a -> b) -> a -> b
$ forall a.
(DiagnosticOpts a ~ NoDiagnosticOpts, Diagnostic a, Typeable a) =>
a -> UnknownDiagnostic
UnknownDiagnostic forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
forall doc. IsLine doc => [Char] -> doc
text [Char]
"not an expression:" forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes (forall doc. IsLine doc => [Char] -> doc
text [Char]
expr)
hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt :: [Char] -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt = forall thing.
(Outputable thing, Data thing) =>
P thing -> [Char] -> Hsc thing
hscParseThing P (Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
parseStmt
hscParseStmtWithLocation :: String -> Int -> String
-> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation :: [Char] -> Int -> [Char] -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation [Char]
source Int
linenumber [Char]
stmt =
forall thing.
(Outputable thing, Data thing) =>
[Char] -> Int -> P thing -> [Char] -> Hsc thing
hscParseThingWithLocation [Char]
source Int
linenumber P (Maybe
(GenLocated
SrcSpanAnnA
(StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
parseStmt [Char]
stmt
hscParseType :: String -> Hsc (LHsType GhcPs)
hscParseType :: [Char] -> Hsc (LHsType GhcPs)
hscParseType = forall thing.
(Outputable thing, Data thing) =>
P thing -> [Char] -> Hsc thing
hscParseThing P (GenLocated SrcSpanAnnA (HsType GhcPs))
parseType
hscParseIdentifier :: HscEnv -> String -> IO (LocatedN RdrName)
hscParseIdentifier :: HscEnv -> [Char] -> IO (LocatedN RdrName)
hscParseIdentifier HscEnv
hsc_env [Char]
str =
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall thing.
(Outputable thing, Data thing) =>
P thing -> [Char] -> Hsc thing
hscParseThing P (LocatedN RdrName)
parseIdentifier [Char]
str
hscParseThing :: (Outputable thing, Data thing)
=> Lexer.P thing -> String -> Hsc thing
hscParseThing :: forall thing.
(Outputable thing, Data thing) =>
P thing -> [Char] -> Hsc thing
hscParseThing = forall thing.
(Outputable thing, Data thing) =>
[Char] -> Int -> P thing -> [Char] -> Hsc thing
hscParseThingWithLocation [Char]
"<interactive>" Int
1
hscParseThingWithLocation :: (Outputable thing, Data thing) => String -> Int
-> Lexer.P thing -> String -> Hsc thing
hscParseThingWithLocation :: forall thing.
(Outputable thing, Data thing) =>
[Char] -> Int -> P thing -> [Char] -> Hsc thing
hscParseThingWithLocation [Char]
source Int
linenumber P thing
parser [Char]
str = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(forall doc. IsLine doc => [Char] -> doc
text [Char]
"Parser [source]")
(forall a b. a -> b -> a
const ()) forall a b. (a -> b) -> a -> b
$ {-# SCC "Parser" #-} do
let buf :: StringBuffer
buf = [Char] -> StringBuffer
stringToStringBuffer [Char]
str
loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
fsLit [Char]
source) Int
linenumber Int
1
case forall a. P a -> PState -> ParseResult a
unP P thing
parser (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) StringBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst ->
forall a. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst)
POk PState
pst thing
thing -> do
(Messages PsWarning, Messages PsWarning) -> Hsc ()
logWarningsReportErrors (PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_parsed [Char]
"Parser"
DumpFormat
FormatHaskell (forall a. Outputable a => a -> SDoc
ppr thing
thing)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_parsed_ast [Char]
"Parser AST"
DumpFormat
FormatHaskell (forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations thing
thing)
forall (m :: * -> *) a. Monad m => a -> m a
return thing
thing
hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy HscEnv
hsc_env ModGuts
guts = do
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let this_mod :: Module
this_mod = ModGuts -> Module
mg_module ModGuts
guts
TidyOpts
opts <- HscEnv -> IO TidyOpts
initTidyOpts HscEnv
hsc_env
(CgGuts
cgguts, ModDetails
details) <- forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(forall doc. IsLine doc => [Char] -> doc
text [Char]
"CoreTidy"forall doc. IsLine doc => doc -> doc -> doc
<+>forall doc. IsLine doc => doc -> doc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(forall a b. a -> b -> a
const ())
forall a b. (a -> b) -> a -> b
$! {-# SCC "CoreTidy" #-} TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram TidyOpts
opts ModGuts
guts
let tidy_rules :: [CoreRule]
tidy_rules = ModDetails -> [CoreRule]
md_rules ModDetails
details
let all_tidy_binds :: CoreProgram
all_tidy_binds = CgGuts -> CoreProgram
cg_binds CgGuts
cgguts
let name_ppr_ctx :: NamePprCtx
name_ppr_ctx = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts)
ptc :: PromotionTickContext
ptc = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
HscEnv
-> NamePprCtx -> CoreToDo -> CoreProgram -> [CoreRule] -> IO ()
endPassHscEnvIO HscEnv
hsc_env NamePprCtx
name_ppr_ctx CoreToDo
CoreTidy CoreProgram
all_tidy_binds [CoreRule]
tidy_rules
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_simpl) forall a b. (a -> b) -> a -> b
$
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_rules
[Char]
"Tidy Core rules"
DumpFormat
FormatText
([CoreRule] -> SDoc
pprRulesForUser [CoreRule]
tidy_rules)
let cs :: CoreStats
cs = CoreProgram -> CoreStats
coreBindsStats CoreProgram
all_tidy_binds
Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_core_stats [Char]
"Core Stats"
DumpFormat
FormatText
(forall doc. IsLine doc => [Char] -> doc
text [Char]
"Tidy size (terms,types,coercions)"
forall doc. IsLine doc => doc -> doc -> doc
<+> forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod) forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => doc
colon
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Int -> doc
int (CoreStats -> Int
cs_tm CoreStats
cs)
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Int -> doc
int (CoreStats -> Int
cs_ty CoreStats
cs)
forall doc. IsLine doc => doc -> doc -> doc
<+> forall doc. IsLine doc => Int -> doc
int (CoreStats -> Int
cs_co CoreStats
cs))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CgGuts
cgguts, ModDetails
details)
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr :: HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
loc CoreExpr
expr =
case Hooks
-> Maybe
(HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded))
hscCompileCoreExprHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) of
Maybe
(HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded))
Nothing -> HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
loc CoreExpr
expr
Just HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
h -> HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
h HscEnv
hsc_env SrcSpan
loc CoreExpr
expr
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr' :: HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
srcspan CoreExpr
ds_expr
= do {
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
; let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
; let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
; let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
; let simplify_expr_opts :: SimplifyExprOpts
simplify_expr_opts = DynFlags -> InteractiveContext -> SimplifyExprOpts
initSimplifyExprOpts DynFlags
dflags InteractiveContext
ic
; CoreExpr
simpl_expr <- Logger
-> ExternalUnitCache -> SimplifyExprOpts -> CoreExpr -> IO CoreExpr
simplifyExpr Logger
logger (UnitEnv -> ExternalUnitCache
ue_eps UnitEnv
unit_env) SimplifyExprOpts
simplify_expr_opts CoreExpr
ds_expr
; let tidy_expr :: CoreExpr
tidy_expr = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
emptyTidyEnv CoreExpr
simpl_expr
; CorePrepConfig
cp_cfg <- HscEnv -> IO CorePrepConfig
initCorePrepConfig HscEnv
hsc_env
; CoreExpr
prepd_expr <- Logger -> CorePrepConfig -> CoreExpr -> IO CoreExpr
corePrepExpr
Logger
logger CorePrepConfig
cp_cfg
CoreExpr
tidy_expr
; SDoc -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr (forall doc. IsLine doc => [Char] -> doc
text [Char]
"hscCompileExpr") HscEnv
hsc_env CoreExpr
prepd_expr
; let iNTERACTIVELoc :: ModLocation
iNTERACTIVELoc = ModLocation{ ml_hs_file :: Maybe [Char]
ml_hs_file = forall a. Maybe a
Nothing,
ml_hi_file :: [Char]
ml_hi_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_hi_file",
ml_obj_file :: [Char]
ml_obj_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_obj_file",
ml_dyn_obj_file :: [Char]
ml_dyn_obj_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr': ml_obj_file",
ml_dyn_hi_file :: [Char]
ml_dyn_hi_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr': ml_dyn_hi_file",
ml_hie_file :: [Char]
ml_hie_file = forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_hie_file" }
; let ictxt :: InteractiveContext
ictxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
; (Id
binding_id, [CgStgTopBinding]
stg_expr, InfoTableProvMap
_, ([CostCentre], [CostCentreStack])
_, StgCgInfos
_stg_cg_info) <-
Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreExpr
-> IO
(Id, [CgStgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStgExpr Logger
logger
DynFlags
dflags
InteractiveContext
ictxt
Bool
True
(InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
ModLocation
iNTERACTIVELoc
CoreExpr
prepd_expr
; CompiledByteCode
bcos <- HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env
(InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
[CgStgTopBinding]
stg_expr
[] forall a. Maybe a
Nothing
; ([(Name, ForeignHValue)]
fv_hvs, [Linkable]
mods_needed, PkgsLoaded
units_needed) <- Interp
-> HscEnv
-> SrcSpan
-> CompiledByteCode
-> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
loadDecls (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env SrcSpan
srcspan CompiledByteCode
bcos
; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"hscCompileCoreExpr'"
forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Id -> Name
idName Id
binding_id) [(Name, ForeignHValue)]
fv_hvs, [Linkable]
mods_needed, PkgsLoaded
units_needed) }
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env = do
ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
let
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
dump_rn_stats :: Bool
dump_rn_stats = Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_rn_stats
dump_if_trace :: Bool
dump_if_trace = Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_if_trace
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
dump_if_trace Bool -> Bool -> Bool
|| Bool
dump_rn_stats) forall a b. (a -> b) -> a -> b
$
Logger -> [Char] -> SDoc -> IO ()
logDumpMsg Logger
logger [Char]
"Interface statistics" (ExternalPackageState -> SDoc
ifaceStats ExternalPackageState
eps)
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex (Int
i,Int
n) = forall doc. IsLine doc => [Char] -> doc
text [Char]
"[" forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
pad forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Int -> doc
int Int
i forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => [Char] -> doc
text [Char]
" of " forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => Int -> doc
int Int
n forall doc. IsLine doc => doc -> doc -> doc
<> forall doc. IsLine doc => [Char] -> doc
text [Char]
"] "
where
len :: a -> b
len a
x = forall a b. (RealFrac a, Integral b) => a -> b
ceiling (forall a. Floating a => a -> a -> a
logBase Float
10 (forall a b. (Integral a, Num b) => a -> b
fromIntegral a
xforall a. Num a => a -> a -> a
+Float
1) :: Float)
pad :: SDoc
pad = forall doc. IsLine doc => [Char] -> doc
text (forall a. Int -> a -> [a]
replicate (forall {b} {a}. (Integral b, Integral a) => a -> b
len Int
n forall a. Num a => a -> a -> a
- forall {b} {a}. (Integral b, Integral a) => a -> b
len Int
i) Char
' ')
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags =
GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags Bool -> Bool -> Bool
&&
Bool -> Bool
not (Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend DynFlags
dflags))