{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# OPTIONS_GHC -fprof-auto-top #-}
module GHC.Driver.Main
(
newHscEnv
, Messager, batchMsg
, HscStatus (..)
, hscIncrementalCompile
, initModDetails
, hscMaybeWriteIface
, hscCompileCmmFile
, hscGenHardCode
, hscInteractive
, hscParse
, hscTypecheckRename
, hscDesugar
, makeSimpleDetails
, hscSimplify
, hscCheckSafe
, hscGetSafe
, hscParseIdentifier
, hscTcRcLookupName
, hscTcRnGetInfo
, hscIsGHCiMonad
, hscGetModuleInterface
, hscRnImportDecls
, hscTcRnLookupRdrName
, hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
, hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
, hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
, hscParseExpr
, hscParseType
, hscCompileCoreExpr
, hscCompileCoreExpr'
, hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen
, getHscEnv
, hscSimpleIface'
, oneShotMsg
, dumpIfaceStats
, ioMsgMaybe
, showModuleIndex
, hscAddSptEntries
) where
import GHC.Prelude
import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.CodeOutput
import GHC.Driver.Config
import GHC.Driver.Hooks
import GHC.Parser.Errors
import GHC.Runtime.Context
import GHC.Runtime.Interpreter ( addSptEntry, hscInterp )
import GHC.Runtime.Loader ( initializePlugins )
import GHCi.RemoteTypes ( ForeignHValue )
import GHC.ByteCode.Types
import GHC.Linker.Loader
import GHC.Linker.Types
import GHC.Hs
import GHC.Hs.Dump
import GHC.Hs.Stats ( ppSourceStats )
import GHC.HsToCore
import GHC.StgToByteCode ( byteCodeGen )
import GHC.IfaceToCore ( typecheckIface )
import GHC.Iface.Load ( ifaceStats, initExternalPackageState, 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, NameCacheUpdater(..))
import GHC.Iface.Ext.Debug ( diffFile, validateScopes )
import GHC.Iface.Env ( updNameCache )
import GHC.Core
import GHC.Core.Tidy ( tidyExpr )
import GHC.Core.Type ( Type, Kind )
import GHC.Core.Lint ( lintInteractiveExpr )
import GHC.Core.Multiplicity
import GHC.Core.Utils ( exprType )
import GHC.Core.ConLike
import GHC.Core.Opt.Pipeline
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.CoreToStg.Prep
import GHC.CoreToStg ( coreToStg )
import GHC.Parser.Errors.Ppr
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.FVs ( annTopBindingsFreeVars )
import GHC.Stg.Pipeline ( stg2stg )
import GHC.Builtin.Utils
import GHC.Builtin.Names
import GHC.Builtin.Uniques ( mkPseudoUniqueE )
import qualified GHC.StgToCmm as StgToCmm ( codeGen )
import GHC.StgToCmm.Types (CgInfos (..), ModuleLFInfos)
import GHC.Cmm
import GHC.Cmm.Parser ( parseCmmFile )
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
import GHC.Unit
import GHC.Unit.External
import GHC.Unit.State
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.Unique.Supply
import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Env
import GHC.Types.Name.Cache ( initNameCache )
import GHC.Types.Name.Reader
import GHC.Types.Name.Ppr
import GHC.Types.TyThing
import GHC.Types.HpcInfo
import GHC.Utils.Fingerprint ( Fingerprint )
import GHC.Utils.Panic
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Exception
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 Data.Data hiding (Fixity, TyCon)
import Data.List ( nub, isPrefixOf, partition )
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Set as S
import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
import Data.Bifunctor (first, bimap)
import GHC.Data.Maybe
import Data.List.NonEmpty (NonEmpty ((:|)))
#include "HsVersions.h"
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags = do
IORef ExternalPackageState
eps_var <- forall a. a -> IO (IORef a)
newIORef ExternalPackageState
initExternalPackageState
UniqSupply
us <- Char -> IO UniqSupply
mkSplitUniqSupply Char
'r'
IORef NameCache
nc_var <- forall a. a -> IO (IORef a)
newIORef (UniqSupply -> [Name] -> NameCache
initNameCache UniqSupply
us [Name]
knownKeyNames)
IORef (InstalledModuleEnv InstalledFindResult)
fc_var <- forall a. a -> IO (IORef a)
newIORef forall a. InstalledModuleEnv a
emptyInstalledModuleEnv
Logger
logger <- IO Logger
initLogger
TmpFs
tmpfs <- IO TmpFs
initTmpFs
forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
dflags
, hsc_logger :: Logger
hsc_logger = Logger
logger
, 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_HPT :: HomePackageTable
hsc_HPT = HomePackageTable
emptyHomePackageTable
, hsc_EPS :: IORef ExternalPackageState
hsc_EPS = IORef ExternalPackageState
eps_var
, hsc_NC :: IORef NameCache
hsc_NC = IORef NameCache
nc_var
, hsc_FC :: IORef (InstalledModuleEnv InstalledFindResult)
hsc_FC = IORef (InstalledModuleEnv InstalledFindResult)
fc_var
, hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = forall a. Maybe a
Nothing
, hsc_interp :: Maybe Interp
hsc_interp = forall a. Maybe a
Nothing
, hsc_unit_env :: UnitEnv
hsc_unit_env = forall a. [Char] -> a
panic [Char]
"hsc_unit_env not initialized"
, hsc_plugins :: [LoadedPlugin]
hsc_plugins = []
, hsc_static_plugins :: [StaticPlugin]
hsc_static_plugins = []
, hsc_unit_dbs :: Maybe [UnitDatabase UnitId]
hsc_unit_dbs = forall a. Maybe a
Nothing
, hsc_hooks :: Hooks
hsc_hooks = Hooks
emptyHooks
, hsc_tmpfs :: TmpFs
hsc_tmpfs = TmpFs
tmpfs
}
getWarnings :: Hsc WarningMessages
getWarnings :: Hsc WarningMessages
getWarnings = forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ WarningMessages
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (WarningMessages
w, WarningMessages
w)
clearWarnings :: Hsc ()
clearWarnings :: Hsc ()
clearWarnings = forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ WarningMessages
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), forall a. Bag a
emptyBag)
logWarnings :: WarningMessages -> Hsc ()
logWarnings :: WarningMessages -> Hsc ()
logWarnings WarningMessages
w = forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ WarningMessages
w0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), WarningMessages
w0 forall a. Bag a -> Bag a -> Bag a
`unionBags` WarningMessages
w)
getHscEnv :: Hsc HscEnv
getHscEnv :: Hsc HscEnv
getHscEnv = forall a.
(HscEnv -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
e WarningMessages
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, WarningMessages
w)
handleWarnings :: Hsc ()
handleWarnings :: Hsc ()
handleWarnings = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
WarningMessages
w <- Hsc WarningMessages
getWarnings
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> WarningMessages -> IO ()
printOrThrowWarnings Logger
logger DynFlags
dflags WarningMessages
w
Hsc ()
clearWarnings
logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()
logWarningsReportErrors :: (Bag PsWarning, Bag PsError) -> Hsc ()
logWarningsReportErrors (Bag PsWarning
warnings,Bag PsError
errors) = do
let warns :: WarningMessages
warns = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> MsgEnvelope DecoratedSDoc
pprWarning Bag PsWarning
warnings
errs :: WarningMessages
errs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError Bag PsError
errors
WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs) forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors WarningMessages
errs
handleWarningsThrowErrors :: (Bag PsWarning, Bag PsError) -> Hsc a
handleWarningsThrowErrors :: forall a. (Bag PsWarning, Bag PsError) -> Hsc a
handleWarningsThrowErrors (Bag PsWarning
warnings, Bag PsError
errors) = do
let warns :: WarningMessages
warns = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> MsgEnvelope DecoratedSDoc
pprWarning Bag PsWarning
warnings
errs :: WarningMessages
errs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError Bag PsError
errors
WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
(WarningMessages
wWarns, WarningMessages
wErrs) <- DynFlags -> WarningMessages -> (WarningMessages, WarningMessages)
warningsToMessages DynFlags
dflags forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hsc WarningMessages
getWarnings
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a.
RenderableDiagnostic a =>
Logger -> DynFlags -> Bag (MsgEnvelope a) -> IO ()
printBagOfErrors Logger
logger DynFlags
dflags WarningMessages
wWarns
forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors (forall a. Bag a -> Bag a -> Bag a
unionBags WarningMessages
errs WarningMessages
wErrs)
ioMsgMaybe :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe :: forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe IO (Messages DecoratedSDoc, Maybe a)
ioA = do
(Messages DecoratedSDoc
msgs, Maybe a
mb_r) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Messages DecoratedSDoc, Maybe a)
ioA
let (WarningMessages
warns, WarningMessages
errs) = forall e. Messages e -> (Bag (MsgEnvelope e), Bag (MsgEnvelope e))
partitionMessages Messages DecoratedSDoc
msgs
WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
case Maybe a
mb_r of
Maybe a
Nothing -> forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors WarningMessages
errs
Just a
r -> ASSERT( isEmptyBag errs ) return r
ioMsgMaybe' :: IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' :: forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' IO (Messages DecoratedSDoc, Maybe a)
ioA = do
(Messages DecoratedSDoc
msgs, Maybe a
mb_r) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO (Messages DecoratedSDoc, Maybe a)
ioA
WarningMessages -> Hsc ()
logWarnings (forall e. Messages e -> Bag (MsgEnvelope e)
getWarningMessages Messages DecoratedSDoc
msgs)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mb_r
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [Name]
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO [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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> LocatedN RdrName -> IO (Messages DecoratedSDoc, 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 DecoratedSDoc, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Messages DecoratedSDoc, 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 DecoratedSDoc, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name
-> IO
(Messages DecoratedSDoc,
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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv -> [Char] -> IO (Messages DecoratedSDoc, 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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Messages DecoratedSDoc, 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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LImportDecl GhcPs]
-> IO (Messages DecoratedSDoc, 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 -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
([Char] -> SDoc
text [Char]
"Parser"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
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
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 NonEmpty (PsLoc, Char, [Char])
chars ->
WarningMessages -> Hsc ()
logWarnings forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ PsWarning -> MsgEnvelope DecoratedSDoc
pprWarning forall a b. (a -> b) -> a -> b
$
NonEmpty (PsLoc, Char, [Char]) -> PsWarning
PsWarnBidirectionalFormatChars NonEmpty (PsLoc, Char, [Char])
chars
let parseMod :: P (Located HsModule)
parseMod | HscSource
HsigFile forall a. Eq a => a -> a -> Bool
== ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
= P (Located HsModule)
parseSignature
| Bool
otherwise = P (Located HsModule)
parseModule
case forall a. P a -> PState -> ParseResult a
unP P (Located HsModule)
parseMod (ParserOpts -> StringBuffer -> RealSrcLoc -> PState
initParserState (DynFlags -> ParserOpts
initParserOpts DynFlags
dflags) StringBuffer
buf RealSrcLoc
loc) of
PFailed PState
pst ->
forall a. (Bag PsWarning, Bag PsError) -> Hsc a
handleWarningsThrowErrors (PState -> (Bag PsWarning, Bag PsError)
getMessages PState
pst)
POk PState
pst Located HsModule
rdr_module -> do
let (WarningMessages
warns, WarningMessages
errs) = forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> MsgEnvelope DecoratedSDoc
pprWarning) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError) (PState -> (Bag PsWarning, Bag PsError)
getMessages PState
pst)
WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_dump_parsed [Char]
"Parser"
DumpFormat
FormatHaskell (forall a. Outputable a => a -> SDoc
ppr Located HsModule
rdr_module)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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
rdr_module)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags DumpFlag
Opt_D_source_stats [Char]
"Source Statistics"
DumpFormat
FormatText (Bool -> Located HsModule -> SDoc
ppSourceStats Bool
False Located HsModule
rdr_module)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> Bool
isEmptyBag WarningMessages
errs) forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => WarningMessages -> io a
throwErrors WarningMessages
errs
let n_hspp :: [Char]
n_hspp = [Char] -> [Char]
FilePath.normalise [Char]
src_filename
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
. (DynFlags -> [Char]
tmpDir DynFlags
dflags 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
hpm_module = Located HsModule
rdr_module,
hpm_src_files :: [[Char]]
hpm_src_files = [[Char]]
srcs2
}
let applyPluginAction :: Plugin -> [[Char]] -> HsParsedModule -> Hsc HsParsedModule
applyPluginAction Plugin
p [[Char]]
opts
= Plugin
-> [[Char]] -> ModSummary -> HsParsedModule -> Hsc HsParsedModule
parsedResultAction Plugin
p [[Char]]
opts ModSummary
mod_summary
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
forall (m :: * -> *) a.
Monad m =>
HscEnv -> PluginOperation m a -> a -> m a
withPlugins HscEnv
hsc_env Plugin -> [[Char]] -> HsParsedModule -> Hsc HsParsedModule
applyPluginAction HsParsedModule
res
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. [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
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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 <- ModSummary -> TcGblEnv -> RenamedSource -> Hsc 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
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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 -> WarningMessages -> IO (a, WarningMessages)) -> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
e WarningMessages
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, WarningMessages
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 -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"Got valid scopes"
[SDoc]
xs -> do
Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"Got invalid scopes"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags) [SDoc]
xs
HieFileResult
file' <- NameCacheUpdater -> [Char] -> IO HieFileResult
readHieFile ((forall c. (NameCache -> (NameCache, c)) -> IO c)
-> NameCacheUpdater
NCU forall a b. (a -> b) -> a -> b
$ forall c. IORef NameCache -> (NameCache -> (NameCache, c)) -> IO c
updNameCache forall a b. (a -> b) -> a -> b
$ HscEnv -> IORef NameCache
hsc_NC HscEnv
hs_env) [Char]
out_file
case Diff HieFile
diffFile HieFile
hieFile (HieFileResult -> HieFile
hie_file_result HieFileResult
file') of
[] ->
Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"Got no roundtrip errors"
[SDoc]
xs -> do
Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"Got roundtrip errors"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger (DynFlags -> DumpFlag -> DynFlags
dopt_set DynFlags
dflags DumpFlag
Opt_D_ppr_debug)) [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)
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
MASSERT( isHomeModule home_unit 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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> RealSrcSpan
-> IO (Messages DecoratedSDoc, 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, Maybe Fingerprint
_, ModDetails
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result0 forall a. Maybe a
Nothing
forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$
HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO (Messages DecoratedSDoc, 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 LHsDocString)
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 LHsDocString)
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
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
$
WarningMessages -> Hsc ()
logWarnings forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$
forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnMissingSafeHaskellMode) forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainWarnMsg (forall l e. GenLocated l e -> l
getLoc (HsParsedModule -> Located HsModule
hpm_module HsParsedModule
mod)) forall a b. (a -> b) -> a -> b
$
SDoc
warnMissingSafeHaskellMode
TcGblEnv
tcg_res <- {-# SCC "Typecheck-Rename" #-}
forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$
HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages DecoratedSDoc, Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
sum
Bool
save_rn_syntax HsParsedModule
mod
(Bool
tcSafeOK, WarningMessages
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 (Bool, WarningMessages)
tcg_safeInfer 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 TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_res WarningMessages
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 b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef (Bool, WarningMessages)
tcg_safeInfer 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 -> (WarningMessages -> Hsc ()
logWarnings forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$
forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnSafe) forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainWarnMsg (DynFlags -> SrcSpan
warnSafeOnLoc DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
TcGblEnv -> SDoc
errSafe 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 ->
(WarningMessages -> Hsc ()
logWarnings forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$
forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnTrustworthySafe) forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainWarnMsg (DynFlags -> SrcSpan
trustworthyOnLoc DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
TcGblEnv -> SDoc
errTwthySafe 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'
where
pprMod :: TcGblEnv -> SDoc
pprMod TcGblEnv
t = 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
t
errSafe :: TcGblEnv -> SDoc
errSafe TcGblEnv
t = SDoc -> SDoc
quotes (TcGblEnv -> SDoc
pprMod TcGblEnv
t) SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
text [Char]
"has been inferred as safe!"
errTwthySafe :: TcGblEnv -> SDoc
errTwthySafe TcGblEnv
t = SDoc -> SDoc
quotes (TcGblEnv -> SDoc
pprMod TcGblEnv
t)
SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
text [Char]
"is marked as Trustworthy but has been inferred as safe!"
warnMissingSafeHaskellMode :: SDoc
warnMissingSafeHaskellMode = forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName (ModSummary -> Module
ms_mod ModSummary
sum))
SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
text [Char]
"is missing Safe Haskell mode"
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
ModGuts
r <- forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$
{-# SCC "deSugar" #-}
HscEnv
-> ModLocation
-> TcGblEnv
-> IO (Messages DecoratedSDoc, Maybe ModGuts)
deSugar HscEnv
hsc_env ModLocation
mod_location TcGblEnv
tc_result
Hsc ()
handleWarnings
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
r
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails :: HscEnv -> TcGblEnv -> IO ModDetails
makeSimpleDetails HscEnv
hsc_env TcGblEnv
tc_result = HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc HscEnv
hsc_env TcGblEnv
tc_result
type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()
hscIncrementalFrontend :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend
Bool
always_do_basic_recompilation_check Maybe TcGblEnv
m_tc_result
Maybe Messager
mHscMessage ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int, Int)
mod_index
= do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
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 (ExtendedModSummary -> ModuleGraphNode
ModuleNode (ModSummary -> ExtendedModSummary
extendModSummaryNoDeps ModSummary
mod_summary))
Maybe Messager
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
skip :: ModIface
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
skip ModIface
iface = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RecompileRequired -> IO ()
msg RecompileRequired
UpToDate
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left ModIface
iface
compile :: Maybe Fingerprint
-> RecompileRequired
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
compile Maybe Fingerprint
mb_old_hash RecompileRequired
reason = do
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ RecompileRequired -> IO ()
msg RecompileRequired
reason
FrontendResult
tc_result <- 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
mod_summary forall a. Maybe a
Nothing
Just ModSummary -> Hsc FrontendResult
h -> ModSummary -> Hsc FrontendResult
h ModSummary
mod_summary
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (FrontendResult
tc_result, Maybe Fingerprint
mb_old_hash)
stable :: Bool
stable = case SourceModified
source_modified of
SourceModified
SourceUnmodifiedAndStable -> Bool
True
SourceModified
_ -> Bool
False
case Maybe TcGblEnv
m_tc_result of
Just TcGblEnv
tc_result
| Bool -> Bool
not Bool
always_do_basic_recompilation_check ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (TcGblEnv -> FrontendResult
FrontendTypecheck TcGblEnv
tc_result, forall a. Maybe a
Nothing)
Maybe TcGblEnv
_ -> do
(RecompileRequired
recomp_reqd, Maybe ModIface
mb_checked_iface)
<- {-# SCC "checkOldIface" #-}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> IO (RecompileRequired, Maybe ModIface)
checkOldIface HscEnv
hsc_env ModSummary
mod_summary
SourceModified
source_modified Maybe ModIface
mb_old_iface
let mb_old_hash :: Maybe Fingerprint
mb_old_hash = 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
case Maybe ModIface
mb_checked_iface of
Just ModIface
iface | Bool -> Bool
not (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp_reqd) ->
case Maybe TcGblEnv
m_tc_result of
Maybe TcGblEnv
Nothing
| forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_used_th ModIface
iface Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
stable ->
Maybe Fingerprint
-> RecompileRequired
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
compile Maybe Fingerprint
mb_old_hash ([Char] -> RecompileRequired
RecompBecause [Char]
"TH")
Maybe TcGblEnv
_ ->
ModIface
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
skip ModIface
iface
Maybe ModIface
_ ->
case Maybe TcGblEnv
m_tc_result of
Maybe TcGblEnv
Nothing -> Maybe Fingerprint
-> RecompileRequired
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
compile Maybe Fingerprint
mb_old_hash RecompileRequired
recomp_reqd
Just TcGblEnv
tc_result ->
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (TcGblEnv -> FrontendResult
FrontendTypecheck TcGblEnv
tc_result, Maybe Fingerprint
mb_old_hash)
hscIncrementalCompile :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int,Int)
-> IO (HscStatus, HscEnv)
hscIncrementalCompile :: Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> HscEnv
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> IO (HscStatus, HscEnv)
hscIncrementalCompile Bool
always_do_basic_recompilation_check Maybe TcGblEnv
m_tc_result
Maybe Messager
mHscMessage HscEnv
hsc_env' ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int, Int)
mod_index
= do
HscEnv
hsc_env'' <- HscEnv -> IO HscEnv
initializePlugins HscEnv
hsc_env'
IORef TypeEnv
type_env_var <- forall a. a -> IO (IORef a)
newIORef forall a. NameEnv a
emptyNameEnv
let mod :: Module
mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
hsc_env :: HscEnv
hsc_env | GhcMode -> Bool
isOneShot (DynFlags -> GhcMode
ghcMode (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env''))
= HscEnv
hsc_env'' { hsc_type_env_var :: Maybe (Module, IORef TypeEnv)
hsc_type_env_var = forall a. a -> Maybe a
Just (Module
mod, IORef TypeEnv
type_env_var) }
| Bool
otherwise
= HscEnv
hsc_env''
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
Either ModIface (FrontendResult, Maybe Fingerprint)
e <- Bool
-> Maybe TcGblEnv
-> Maybe Messager
-> ModSummary
-> SourceModified
-> Maybe ModIface
-> (Int, Int)
-> Hsc (Either ModIface (FrontendResult, Maybe Fingerprint))
hscIncrementalFrontend Bool
always_do_basic_recompilation_check Maybe TcGblEnv
m_tc_result Maybe Messager
mHscMessage
ModSummary
mod_summary SourceModified
source_modified Maybe ModIface
mb_old_iface (Int, Int)
mod_index
case Either ModIface (FrontendResult, Maybe Fingerprint)
e of
Left ModIface
iface -> do
ModDetails
details <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails HscEnv
hsc_env ModSummary
mod_summary ModIface
iface
forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface -> ModDetails -> HscStatus
HscUpToDate ModIface
iface ModDetails
details, HscEnv
hsc_env')
Right (FrontendTypecheck TcGblEnv
tc_result, Maybe Fingerprint
mb_old_hash) -> do
HscStatus
status <- ModSummary -> TcGblEnv -> Maybe Fingerprint -> Hsc HscStatus
finish ModSummary
mod_summary TcGblEnv
tc_result Maybe Fingerprint
mb_old_hash
forall (m :: * -> *) a. Monad m => a -> m a
return (HscStatus
status, HscEnv
hsc_env)
initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails :: HscEnv -> ModSummary -> ModIface -> IO ModDetails
initModDetails HscEnv
hsc_env ModSummary
mod_summary ModIface
iface =
forall a. (a -> IO a) -> IO a
fixIO forall a b. (a -> b) -> a -> b
$ \ModDetails
details' -> do
let hsc_env' :: HscEnv
hsc_env' =
HscEnv
hsc_env {
hsc_HPT :: HomePackageTable
hsc_HPT = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt (HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env)
(ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary)
(ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details' forall a. Maybe a
Nothing)
}
HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env' ModIface
iface
finish :: ModSummary
-> TcGblEnv
-> Maybe Fingerprint
-> Hsc HscStatus
finish :: ModSummary -> TcGblEnv -> Maybe Fingerprint -> Hsc HscStatus
finish ModSummary
summary TcGblEnv
tc_result 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
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
case Maybe ModGuts
mb_desugar of
Just ModGuts
desugared_guts | Backend
bcknd forall a. Eq a => a -> a -> Bool
/= Backend
NoBackend -> 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) <- {-# SCC "CoreTidy" #-}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram 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 -> ModDetails -> ModGuts -> PartialModIface
mkPartialIface HscEnv
hsc_env ModDetails
details 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
}
Maybe ModGuts
_ -> do
(ModIface
iface, Maybe Fingerprint
mb_old_iface_hash, ModDetails
details) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result Maybe Fingerprint
mb_old_hash
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_iface_hash (ModSummary -> ModLocation
ms_location ModSummary
summary)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case Backend
bcknd of
Backend
NoBackend -> ModIface -> ModDetails -> HscStatus
HscNotGeneratingCode ModIface
iface ModDetails
details
Backend
_ -> case HscSource
hsc_src of
HscSource
HsBootFile -> ModIface -> ModDetails -> HscStatus
HscUpdateBoot ModIface
iface ModDetails
details
HscSource
HsigFile -> ModIface -> ModDetails -> HscStatus
HscUpdateSig ModIface
iface ModDetails
details
HscSource
_ -> forall a. [Char] -> a
panic [Char]
"finish"
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 = case DynFlags -> Backend
backend DynFlags
dflags of
Backend
NoBackend -> Bool
False
Backend
Interpreter -> Bool
False
Backend
_ -> Bool
True
baseName :: [Char]
baseName = ModLocation -> [Char]
ml_hi_file ModLocation
mod_location
buildIfName :: [Char] -> Bool -> [Char]
buildIfName [Char]
suffix Bool
is_dynamic
| Just [Char]
name <- (if Bool
is_dynamic then DynFlags -> Maybe [Char]
dynOutputHi else DynFlags -> Maybe [Char]
outputHi) DynFlags
dflags
= [Char]
name
| Bool
otherwise
= let with_hi :: [Char]
with_hi = [Char] -> [Char] -> [Char]
replaceExtension [Char]
baseName [Char]
suffix
in IsBootInterface -> [Char] -> [Char]
addBootSuffix_maybe (ModIface -> IsBootInterface
mi_boot ModIface
iface) [Char]
with_hi
write_iface :: DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags' ModIface
iface =
let !iface_name :: [Char]
iface_name = [Char] -> Bool -> [Char]
buildIfName (DynFlags -> [Char]
hiSuf DynFlags
dflags') (DynFlags -> Bool
dynamicNow DynFlags
dflags')
in
{-# SCC "writeIface" #-}
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags'
([Char] -> SDoc
text [Char]
"WriteIface"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets ([Char] -> SDoc
text [Char]
iface_name))
(forall a b. a -> b -> a
const ())
(Logger -> DynFlags -> [Char] -> ModIface -> IO ()
writeIface Logger
logger DynFlags
dflags' [Char]
iface_name ModIface
iface)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
write_interface Bool -> Bool -> Bool
|| Bool
force_write_interface) forall a b. (a -> b) -> a -> b
$ do
let no_change :: Bool
no_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))
DynamicTooState
dt <- forall (m :: * -> *). MonadIO m => DynFlags -> m DynamicTooState
dynamicTooState DynFlags
dflags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_if_trace DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ Logger -> DynFlags -> SDoc -> IO ()
putMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$
SDoc -> Int -> SDoc -> SDoc
hang ([Char] -> SDoc
text [Char]
"Writing interface(s):") Int
2 forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
vcat
[ [Char] -> SDoc
text [Char]
"Kind:" SDoc -> SDoc -> SDoc
<+> if Bool
is_simple then [Char] -> SDoc
text [Char]
"simple" else [Char] -> SDoc
text [Char]
"full"
, [Char] -> SDoc
text [Char]
"Hash change:" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (Bool -> Bool
not Bool
no_change)
, [Char] -> SDoc
text [Char]
"DynamicToo state:" SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
text (forall a. Show a => a -> [Char]
show DynamicTooState
dt)
]
if Bool
is_simple
then forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
no_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_Failed -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
DynamicTooState
DT_Dyn -> forall a. [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 -> Bool
not Bool
no_change -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
DT_OK | Bool -> Bool
not Bool
no_change -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
DT_Dyn -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
DT_Failed | Bool -> Bool
not (DynFlags -> Bool
dynamicNow DynFlags
dflags) -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
DynamicTooState
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
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 -> IfG a -> IO a
initIfaceLoad HscEnv
hsc_env (ModIface -> IfG ModDetails
typecheckIface ModIface
old_iface)
HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
forall (m :: * -> *) a. Monad m => a -> m a
return ModDetails
new_details
oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg :: HscEnv -> RecompileRequired -> IO ()
oneShotMsg HscEnv
hsc_env RecompileRequired
recomp =
case RecompileRequired
recomp of
RecompileRequired
UpToDate ->
Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$
[Char] -> SDoc
text [Char]
"compilation IS NOT required"
RecompileRequired
_ ->
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
batchMsg :: Messager
batchMsg :: Messager
batchMsg HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node = case ModuleGraphNode
node of
InstantiationNode InstantiatedUnit
_ ->
case RecompileRequired
recomp of
RecompileRequired
MustCompile -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
text [Char]
"Instantiating ") SDoc
empty
RecompileRequired
UpToDate
| DynFlags -> Int
verbosity DynFlags
dflags forall a. Ord a => a -> a -> Bool
>= Int
2 -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
text [Char]
"Skipping ") SDoc
empty
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RecompBecause [Char]
reason -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
text [Char]
"Instantiating ") ([Char] -> SDoc
text [Char]
" [" SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
reason SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
"]")
ModuleNode ExtendedModSummary
_ ->
case RecompileRequired
recomp of
RecompileRequired
MustCompile -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
text [Char]
"Compiling ") SDoc
empty
RecompileRequired
UpToDate
| DynFlags -> Int
verbosity DynFlags
dflags forall a. Ord a => a -> a -> Bool
>= Int
2 -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
text [Char]
"Skipping ") SDoc
empty
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RecompBecause [Char]
reason -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
text [Char]
"Compiling ") ([Char] -> SDoc
text [Char]
" [" SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
reason SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
"]")
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
showMsg :: SDoc -> SDoc -> IO ()
showMsg SDoc
msg SDoc
reason =
Logger -> DynFlags -> SDoc -> IO ()
compilationProgressMsg Logger
logger DynFlags
dflags forall a b. (a -> b) -> a -> b
$
((Int, Int) -> SDoc
showModuleIndex (Int, Int)
mod_index SDoc -> SDoc -> SDoc
<>
SDoc
msg SDoc -> SDoc -> SDoc
<> DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModuleGraphNode
node)
SDoc -> SDoc -> SDoc
<> 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' =
case DynFlags -> Bool
safeLanguageOn DynFlags
dflags of
Bool
True -> do
WarningMessages -> Hsc ()
logWarnings forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (RuleDecl GhcTc)] -> WarningMessages
warns (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')
-> TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env' forall a b. (a -> b) -> a -> b
$ [GenLocated SrcSpanAnnA (RuleDecl GhcTc)] -> WarningMessages
warns (TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
| Bool
otherwise
-> forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env'
warns :: [GenLocated SrcSpanAnnA (RuleDecl GhcTc)] -> WarningMessages
warns [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules = forall a. [a] -> Bag a
listToBag forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc
warnRules [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules
warnRules :: LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc
warnRules :: LRuleDecl GhcTc -> MsgEnvelope DecoratedSDoc
warnRules (L SrcSpanAnnA
loc (HsRule { rd_name :: forall pass. RuleDecl pass -> XRec pass (SourceText, FastString)
rd_name = XRec GhcTc (SourceText, FastString)
n })) =
SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainWarnMsg (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$
[Char] -> SDoc
text [Char]
"Rule \"" SDoc -> SDoc -> SDoc
<> FastString -> SDoc
ftext (forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall l e. GenLocated l e -> e
unLoc XRec GhcTc (SourceText, FastString)
n) SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
"\" ignored" SDoc -> SDoc -> SDoc
$+$
[Char] -> SDoc
text [Char]
"User defined rules are disabled under Safe Haskell"
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
WarningMessages
oldErrs <- Hsc WarningMessages
getWarnings
Hsc ()
clearWarnings
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
WarningMessages
safeErrs <- Hsc WarningMessages
getWarnings
Hsc ()
clearWarnings
(WarningMessages
infErrs, Set UnitId
infPkgs) <- case (DynFlags -> Bool
safeInferOn DynFlags
dflags) of
Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Bag a
emptyBag, 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
WarningMessages
infErrs <- Hsc WarningMessages
getWarnings
Hsc ()
clearWarnings
forall (m :: * -> *) a. Monad m => a -> m a
return (WarningMessages
infErrs, Set UnitId
infPkgs)
WarningMessages -> Hsc ()
logWarnings WarningMessages
oldErrs
case (forall a. Bag a -> Bool
isEmptyBag WarningMessages
safeErrs) of
Bool
False -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> SourceError
mkSrcErr forall a b. (a -> b) -> a -> b
$ WarningMessages
safeErrs
Bool
True -> do
let infPassed :: Bool
infPassed = forall a. Bag a -> Bool
isEmptyBag WarningMessages
infErrs
TcGblEnv
tcg_env' <- case (Bool -> Bool
not Bool
infPassed) of
Bool
True -> TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env WarningMessages
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. [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 DecoratedSDoc -> io a
throwOneError forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope (ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
v1)
([Char] -> SDoc
text [Char]
"Module" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (ImportedModsVal -> ModuleName
imv_name ImportedModsVal
v1) SDoc -> SDoc -> SDoc
<+>
([Char] -> SDoc
text forall a b. (a -> b) -> a -> b
$ [Char]
"is imported both as a safe and unsafe import!"))
| 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
WarningMessages
errs <- Hsc WarningMessages
getWarnings
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Bag a -> Bool
isEmptyBag WarningMessages
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 a. Bag a -> Bool
isEmptyBag forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Hsc WarningMessages
getWarnings
Hsc ()
clearWarnings
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
$ Unit -> 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
case Maybe ModIface
iface of
Maybe ModIface
Nothing -> forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope DecoratedSDoc -> io a
throwOneError forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
l
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"Can't load the interface file for" SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr Module
m
SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
", to check that it can be safely imported"
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 (HscEnv -> UnitState
hsc_units HscEnv
hsc_env) HomeUnit
home_unit SafeHaskellMode
trust Bool
trust_own_pkg Module
m
pkgRs :: Set UnitId
pkgRs = forall a. Ord a => [a] -> Set a
S.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ Dependencies -> [(UnitId, Bool)]
dep_pkgs forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface'
warns :: WarningMessages
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 WarningMessages
inferredImportWarn
else forall a. Bag a
emptyBag
errs :: WarningMessages
errs = case (Bool
safeM, Bool
safeP) of
(Bool
True, Bool
True ) -> forall a. Bag a
emptyBag
(Bool
True, Bool
False) -> WarningMessages
pkgTrustErr
(Bool
False, Bool
_ ) -> WarningMessages
modTrustErr
in do
WarningMessages -> Hsc ()
logWarnings WarningMessages
warns
WarningMessages -> Hsc ()
logWarnings WarningMessages
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 = HscEnv -> UnitState
hsc_units HscEnv
hsc_env
inferredImportWarn :: WarningMessages
inferredImportWarn = forall a. a -> Bag a
unitBag
forall a b. (a -> b) -> a -> b
$ forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnInferredSafeImports)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkWarnMsg SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state)
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
sep
[ [Char] -> SDoc
text [Char]
"Importing Safe-Inferred module "
SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName Module
m)
SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
" from explicitly Safe module"
]
pkgTrustErr :: WarningMessages
pkgTrustErr = forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkMsgEnvelope SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state) forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName Module
m)
SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
": Can't be safely imported!"
, [Char] -> SDoc
text [Char]
"The package ("
SDoc -> SDoc -> SDoc
<> (UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state forall a b. (a -> b) -> a -> b
$ forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> unit
moduleUnit Module
m))
SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
") the module resides in isn't trusted."
]
modTrustErr :: WarningMessages
modTrustErr = forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkMsgEnvelope SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state) forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
sep [ forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName Module
m)
SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
": Can't be safely imported!"
, [Char] -> SDoc
text [Char]
"The module itself isn't safe." ]
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 compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsTrusted forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitState -> Unit -> 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
homePkgT :: HomePackageTable
homePkgT = HscEnv -> HomePackageTable
hsc_HPT HscEnv
hsc_env
iface :: Maybe ModIface
iface = HomePackageTable -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomePackageTable
homePkgT 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 DecoratedSDoc, 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 :: [MsgEnvelope DecoratedSDoc]
errors = forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr UnitId
-> [MsgEnvelope DecoratedSDoc] -> [MsgEnvelope DecoratedSDoc]
go [] Set UnitId
pkgs
state :: UnitState
state = HscEnv -> UnitState
hsc_units HscEnv
hsc_env
go :: UnitId
-> [MsgEnvelope DecoratedSDoc] -> [MsgEnvelope DecoratedSDoc]
go UnitId
pkg [MsgEnvelope DecoratedSDoc]
acc
| forall compid srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo compid srcpkgid srcpkgname uid modulename mod
-> Bool
unitIsTrusted forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
state UnitId
pkg
= [MsgEnvelope DecoratedSDoc]
acc
| Bool
otherwise
= (forall a. a -> [a] -> [a]
:[MsgEnvelope DecoratedSDoc]
acc) forall a b. (a -> b) -> a -> b
$ SrcSpan -> PrintUnqualified -> SDoc -> MsgEnvelope DecoratedSDoc
mkMsgEnvelope SrcSpan
noSrcSpan (UnitState -> PrintUnqualified
pkgQual UnitState
state)
forall a b. (a -> b) -> a -> b
$ UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"The package ("
SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr UnitId
pkg
SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
") is required to be trusted but it isn't!"
case [MsgEnvelope DecoratedSDoc]
errors of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[MsgEnvelope DecoratedSDoc]
_ -> (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e a. Exception e => e -> IO a
throwIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. WarningMessages -> SourceError
mkSrcErr forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> Bag a
listToBag) [MsgEnvelope DecoratedSDoc]
errors
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer :: TcGblEnv -> WarningMessages -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env WarningMessages
whyUnsafe = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnsafe DynFlags
dflags)
(WarningMessages -> Hsc ()
logWarnings forall a b. (a -> b) -> a -> b
$ forall a. a -> Bag a
unitBag forall a b. (a -> b) -> a -> b
$ forall e. WarnReason -> MsgEnvelope e -> MsgEnvelope e
makeIntoWarning (WarningFlag -> WarnReason
Reason WarningFlag
Opt_WarnUnsafe) forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainWarnMsg (DynFlags -> SrcSpan
warnUnsafeOnLoc DynFlags
dflags) (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, WarningMessages)
tcg_safeInfer TcGblEnv
tcg_env) (Bool
False, WarningMessages
whyUnsafe)
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 = [SDoc] -> SDoc
vcat [ SDoc -> SDoc
quotes SDoc
pprMod SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
text [Char]
"has been inferred as unsafe!"
, [Char] -> SDoc
text [Char]
"Reason:"
, Int -> SDoc -> SDoc
nest Int
4 forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ DynFlags -> [SDoc]
badFlags DynFlags
df) SDoc -> SDoc -> SDoc
$+$
([SDoc] -> SDoc
vcat forall a b. (a -> b) -> a -> b
$ WarningMessages -> [SDoc]
pprMsgEnvelopeBagWithLoc WarningMessages
whyUnsafe) SDoc -> SDoc -> SDoc
$+$
([SDoc] -> SDoc
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 = [Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevOutput (t -> SrcSpan
loc t
df) forall a b. (a -> b) -> a -> b
$
[Char] -> SDoc
text [Char]
str SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
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))
= [Severity -> SrcSpan -> SDoc -> SDoc
mkLocMessage Severity
SevOutput (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) SDoc -> SDoc -> SDoc
<+>
[Char] -> SDoc
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
$ HscEnv
hsc_env
{ hsc_dflags :: DynFlags
hsc_dflags = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> DynFlags -> DynFlags
addPluginModuleName (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env) [[Char]]
plugins
}
{-# 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
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface :: HscEnv
-> TcGblEnv
-> Maybe Fingerprint
-> IO (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface
= forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface' TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface
hscSimpleIface' :: TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface' :: TcGblEnv
-> Maybe Fingerprint
-> Hsc (ModIface, Maybe Fingerprint, ModDetails)
hscSimpleIface' TcGblEnv
tc_result Maybe Fingerprint
mb_old_iface = do
HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
ModDetails
details <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc HscEnv
hsc_env 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 -> TcGblEnv -> IO ModIface
mkIfaceTc HscEnv
hsc_env SafeHaskellMode
safe_mode ModDetails
details 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, Maybe Fingerprint
mb_old_iface, ModDetails
details)
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
-> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], CgInfos)
hscGenHardCode :: HscEnv
-> CgGuts
-> ModLocation
-> [Char]
-> IO ([Char], Maybe [Char], [(ForeignSrcLang, [Char])], CgInfos)
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_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 -> [UnitId]
cg_dep_pkgs = [UnitId]
dependencies,
cg_hpc_info :: CgGuts -> HpcInfo
cg_hpc_info = HpcInfo
hpc_info } = 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
data_tycons :: [TyCon]
data_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
(CoreProgram
prepd_binds, Set CostCentre
local_ccs) <- {-# SCC "CorePrep" #-}
HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
location
CoreProgram
core_binds [TyCon]
data_tycons
([StgTopBinding]
stg_binds, InfoTableProvMap
denv, ([CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks))
<- {-# SCC "CoreToStg" #-}
forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
([Char] -> SDoc
text [Char]
"CoreToStg"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
(\([StgTopBinding]
a, InfoTableProvMap
b, ([CostCentre]
c,[CostCentreStack]
d)) -> [StgTopBinding]
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` ())
(Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg Logger
logger DynFlags
dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) Module
this_mod ModLocation
location CoreProgram
prepd_binds)
let cost_centre_info :: ([CostCentre], [CostCentreStack])
cost_centre_info =
(forall a. Set a -> [a]
S.toList Set CostCentre
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 -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
([Char] -> SDoc
text [Char]
"CodeGen"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
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
$ do
Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos
cmms <- {-# SCC "StgToCmm" #-}
HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [StgTopBinding]
-> HpcInfo
-> IO
(Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos)
doCodeGen HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons
([CostCentre], [CostCentreStack])
cost_centre_info
[StgTopBinding]
stg_binds HpcInfo
hpc_info
Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CgInfos
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] CgInfos
-> IO
(Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CgInfos))
Nothing -> forall a.
Logger
-> DynFlags
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a)
cmmToRawCmm Logger
logger DynFlags
dflags Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos
cmms
Just DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos
-> IO
(Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CgInfos)
h -> DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos
-> IO
(Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CgInfos)
h DynFlags
dflags (forall a. a -> Maybe a
Just Module
this_mod) Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos
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
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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]
CgInfos
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]
CgInfos
rawcmms0
let foreign_stubs :: CgInfos -> ForeignStubs
foreign_stubs CgInfos
st = ForeignStubs
foreign_stubs0 ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
prof_init
ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CgInfos -> CStub
cgIPEStub CgInfos
st
([Char]
output_filename, (Bool
_stub_h_exists, Maybe [Char]
stub_c_exists), [(ForeignSrcLang, [Char])]
foreign_fps, CgInfos
cg_infos)
<- {-# SCC "codeOutput" #-}
forall a.
Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> [Char]
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, [Char])]
-> [UnitId]
-> Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a
-> IO ([Char], (Bool, Maybe [Char]), [(ForeignSrcLang, [Char])], a)
codeOutput Logger
logger TmpFs
tmpfs DynFlags
dflags (HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
this_mod [Char]
output_filename ModLocation
location
CgInfos -> ForeignStubs
foreign_stubs [(ForeignSrcLang, [Char])]
foreign_files [UnitId]
dependencies Stream
IO
[GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
CgInfos
rawcmms1
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
output_filename, Maybe [Char]
stub_c_exists, [(ForeignSrcLang, [Char])]
foreign_fps, CgInfos
cg_infos)
hscInteractive :: HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe FilePath, CompiledByteCode, [SptEntry])
hscInteractive :: HscEnv
-> CgGuts
-> ModLocation
-> IO (Maybe [Char], CompiledByteCode, [SptEntry])
hscInteractive HscEnv
hsc_env CgGuts
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 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_foreign :: CgGuts -> ForeignStubs
cg_foreign = ForeignStubs
foreign_stubs,
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
mod_breaks,
cg_spt_entries :: CgGuts -> [SptEntry]
cg_spt_entries = [SptEntry]
spt_entries } = CgGuts
cgguts
data_tycons :: [TyCon]
data_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
(CoreProgram
prepd_binds, Set CostCentre
_) <- {-# SCC "CorePrep" #-}
HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
location CoreProgram
core_binds [TyCon]
data_tycons
([StgTopBinding]
stg_binds, InfoTableProvMap
_infotable_prov, ([CostCentre], [CostCentreStack])
_caf_ccs__caf_cc_stacks)
<- {-# SCC "CoreToStg" #-}
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg Logger
logger DynFlags
dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) Module
this_mod ModLocation
location CoreProgram
prepd_binds
CompiledByteCode
comp_bc <- HscEnv
-> Module
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod [StgTopBinding]
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 (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)
hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> IO (Maybe FilePath)
hscCompileCmmFile :: HscEnv -> [Char] -> [Char] -> IO (Maybe [Char])
hscCompileCmmFile HscEnv
hsc_env [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
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
platform :: Platform
platform = DynFlags -> Platform
targetPlatform 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] -> [Char]
FilePath.takeFileName [Char]
filename
cmm_mod :: Module
cmm_mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
([GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
cmm, [InfoProvEnt]
ents) <- forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe
forall a b. (a -> b) -> a -> b
$ do
(Bag PsWarning
warns,Bag PsError
errs,Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt])
cmm) <- forall (m :: * -> *) a.
MonadIO m =>
Logger -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags ([Char] -> SDoc
text [Char]
"ParseCmm"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets ([Char] -> SDoc
text [Char]
filename)) (\(Bag PsWarning, Bag PsError,
Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt]))
_ -> ())
forall a b. (a -> b) -> a -> b
$ DynFlags
-> Module
-> HomeUnit
-> [Char]
-> IO
(Bag PsWarning, Bag PsError,
Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt]))
parseCmmFile DynFlags
dflags Module
cmm_mod HomeUnit
home_unit [Char]
filename
forall (m :: * -> *) a. Monad m => a -> m a
return (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> MsgEnvelope DecoratedSDoc
pprWarning Bag PsWarning
warns forall a. Bag a -> Bag a -> Bag a
`unionBags` forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsError -> MsgEnvelope DecoratedSDoc
pprError Bag PsError
errs), 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
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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 :: * -> *) a b. Monad m => (a -> m [b]) -> [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
<$> HscEnv
-> ModuleSRTInfo
-> [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
-> IO
(ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
cmmPipeline HscEnv
hsc_env (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
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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
-> DynFlags
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
-> IO
(Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a)
cmmToRawCmm Logger
logger DynFlags
dflags (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 ()
_ =
let ip_init :: CStub
ip_init = DynFlags -> Module -> [InfoProvEnt] -> CStub
ipInitCode DynFlags
dflags Module
cmm_mod [InfoProvEnt]
ents
in ForeignStubs
NoStubs ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
ip_init
([Char]
_output_filename, (Bool
_stub_h_exists, Maybe [Char]
stub_c_exists), [(ForeignSrcLang, [Char])]
_foreign_fps, ()
_caf_infos)
<- forall a.
Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> [Char]
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, [Char])]
-> [UnitId]
-> Stream
IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a
-> IO ([Char], (Bool, Maybe [Char]), [(ForeignSrcLang, [Char])], a)
codeOutput Logger
logger TmpFs
tmpfs DynFlags
dflags (HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
cmm_mod [Char]
output_filename ModLocation
no_loc () -> ForeignStubs
foreign_stubs [] []
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]
filename,
ml_hi_file :: [Char]
ml_hi_file = forall a. [Char] -> a
panic [Char]
"hscCompileCmmFile: no hi file",
ml_obj_file :: [Char]
ml_obj_file = forall a. [Char] -> a
panic [Char]
"hscCompileCmmFile: no obj file",
ml_hie_file :: [Char]
ml_hie_file = forall a. [Char] -> a
panic [Char]
"hscCompileCmmFile: no hie file"}
doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
-> CollectedCCs
-> [StgTopBinding]
-> HpcInfo
-> IO (Stream IO CmmGroupSRTs CgInfos)
doCodeGen :: HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [StgTopBinding]
-> HpcInfo
-> IO
(Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos)
doCodeGen HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons
([CostCentre], [CostCentreStack])
cost_centre_info [StgTopBinding]
stg_binds HpcInfo
hpc_info = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
let hooks :: Hooks
hooks = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
let tmpfs :: TmpFs
tmpfs = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
let platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
let stg_binds_w_fvs :: [CgStgTopBinding]
stg_binds_w_fvs = [StgTopBinding] -> [CgStgTopBinding]
annTopBindingsFreeVars [StgTopBinding]
stg_binds
Logger
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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_w_fvs)
let stg_to_cmm :: DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO
[GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
(CStub, ModuleLFInfos)
stg_to_cmm = case Hooks
-> Maybe
(DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO
[GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
(CStub, ModuleLFInfos))
stgToCmmHook Hooks
hooks of
Maybe
(DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO
[GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
(CStub, ModuleLFInfos))
Nothing -> Logger
-> TmpFs
-> DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO
[GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
(CStub, ModuleLFInfos)
StgToCmm.codeGen Logger
logger TmpFs
tmpfs
Just DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO
[GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
(CStub, ModuleLFInfos)
h -> DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
IO
[GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
(CStub, ModuleLFInfos)
h
let cmm_stream :: Stream IO CmmGroup (CStub, ModuleLFInfos)
cmm_stream :: Stream
IO
[GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
(CStub, 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]
(CStub, 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
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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]
(CStub, 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]
(CStub, ModuleLFInfos)
cmm_stream
pipeline_stream :: Stream IO CmmGroupSRTs CgInfos
pipeline_stream :: Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos
pipeline_stream = do
(NonCaffySet
non_cafs, (CStub
used_info, 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_ (HscEnv
-> ModuleSRTInfo
-> [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
-> IO
(ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
cmmPipeline HscEnv
hsc_env) (Module -> ModuleSRTInfo
emptySRT Module
this_mod) Stream
IO
[GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
(CStub, 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 CgInfos{ cgNonCafs :: NonCaffySet
cgNonCafs = NonCaffySet
non_cafs, cgLFInfos :: ModuleLFInfos
cgLFInfos = ModuleLFInfos
lf_infos, cgIPEStub :: CStub
cgIPEStub = CStub
used_info }
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
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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 (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 Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CgInfos
pipeline_stream)
myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
-> Module -> ModLocation -> CoreExpr
-> IO ( Id
, [StgTopBinding]
, InfoTableProvMap
, CollectedCCs )
myCoreToStgExpr :: Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreExpr
-> IO
(Id, [StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStgExpr Logger
logger DynFlags
dflags InteractiveContext
ictxt 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
Many
(CoreExpr -> Mult
exprType CoreExpr
prepd_expr)
([StgTopBinding]
stg_binds, InfoTableProvMap
prov_map, ([CostCentre], [CostCentreStack])
collected_ccs) <-
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg Logger
logger
DynFlags
dflags
InteractiveContext
ictxt
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, [StgTopBinding]
stg_binds, InfoTableProvMap
prov_map, ([CostCentre], [CostCentreStack])
collected_ccs)
myCoreToStg :: Logger -> DynFlags -> InteractiveContext
-> Module -> ModLocation -> CoreProgram
-> IO ( [StgTopBinding]
, InfoTableProvMap
, CollectedCCs )
myCoreToStg :: Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg Logger
logger DynFlags
dflags InteractiveContext
ictxt Module
this_mod ModLocation
ml CoreProgram
prepd_binds = do
let ([StgTopBinding]
stg_binds, InfoTableProvMap
denv, ([CostCentre], [CostCentreStack])
cost_centre_info)
= {-# SCC "Core2Stg" #-}
DynFlags
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
coreToStg DynFlags
dflags Module
this_mod ModLocation
ml CoreProgram
prepd_binds
[StgTopBinding]
stg_binds2
<- {-# SCC "Stg2Stg" #-}
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> [StgTopBinding]
-> IO [StgTopBinding]
stg2stg Logger
logger DynFlags
dflags InteractiveContext
ictxt Module
this_mod [StgTopBinding]
stg_binds
forall (m :: * -> *) a. Monad m => a -> m a
return ([StgTopBinding]
stg_binds2, InfoTableProvMap
denv, ([CostCentre], [CostCentreStack])
cost_centre_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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs
-> IO
(Messages DecoratedSDoc, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
stmt
CoreExpr
ds_expr <- forall a. IO (Messages DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> LHsExpr GhcTc -> IO (Messages DecoratedSDoc, 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 ([Char] -> SDoc
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 <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
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
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
L SrcSpan
_ (HsModule{ hsmodDecls :: HsModule -> [LHsDecl GhcPs]
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
line_num P (Located HsModule)
parseModule [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 :: HsModule -> [LHsDecl GhcPs]
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)
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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LHsDecl GhcPs] -> IO (Messages DecoratedSDoc, 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. [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_hi_file",
ml_obj_file :: [Char]
ml_obj_file = forall a. [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_obj_file",
ml_hie_file :: [Char]
ml_hie_file = forall a. [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)
tidyProgram 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 -> [ClsInst]
md_insts = [ClsInst]
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, Set CostCentre
_) <- {-# SCC "CorePrep" #-}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO (CoreProgram, Set CostCentre)
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
iNTERACTIVELoc CoreProgram
core_binds [TyCon]
data_tycons
([StgTopBinding]
stg_binds, InfoTableProvMap
_infotable_prov, ([CostCentre], [CostCentreStack])
_caf_ccs__caf_cc_stacks)
<- {-# SCC "CoreToStg" #-}
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreProgram
-> IO
([StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
(HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
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
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod
[StgTopBinding]
stg_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks
let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
[(Name, ForeignHValue)]
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> HscEnv
-> SrcSpan
-> CompiledByteCode
-> IO [(Name, ForeignHValue)]
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]
-> [ClsInst]
-> [FamInst]
-> Maybe [Mult]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings [ClsInst]
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 <- Interp -> HscEnv -> Name -> IO ForeignHValue
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
(L SrcSpan
_ (HsModule{hsmodImports :: HsModule -> [LImportDecl GhcPs]
hsmodImports=[LImportDecl GhcPs]
is})) <-
forall thing.
(Outputable thing, Data thing) =>
P thing -> [Char] -> Hsc thing
hscParseThing P (Located HsModule)
parseModule [Char]
str
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 DecoratedSDoc -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
[Char] -> SDoc
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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO (Messages DecoratedSDoc, 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 DecoratedSDoc, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ HscEnv
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages DecoratedSDoc, 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 DecoratedSDoc -> io a
throwOneError forall a b. (a -> b) -> a -> b
$ SrcSpan -> SDoc -> MsgEnvelope DecoratedSDoc
mkPlainMsgEnvelope SrcSpan
noSrcSpan
([Char] -> SDoc
text [Char]
"not an expression:" SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
quotes ([Char] -> SDoc
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 -> DynFlags -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger DynFlags
dflags
([Char] -> SDoc
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. (Bag PsWarning, Bag PsError) -> Hsc a
handleWarningsThrowErrors (PState -> (Bag PsWarning, Bag PsError)
getMessages PState
pst)
POk PState
pst thing
thing -> do
(Bag PsWarning, Bag PsError) -> Hsc ()
logWarningsReportErrors (PState -> (Bag PsWarning, Bag PsError)
getMessages PState
pst)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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
-> DynFlags -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
dumpIfSet_dyn Logger
logger DynFlags
dflags 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
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
loc CoreExpr
expr =
case Hooks -> Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
hscCompileCoreExprHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) of
Maybe (HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue)
Nothing -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
loc CoreExpr
expr
Just HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
h -> HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
h HscEnv
hsc_env SrcSpan
loc CoreExpr
expr
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO ForeignHValue
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
srcspan CoreExpr
ds_expr
= do {
CoreExpr
simpl_expr <- HscEnv -> CoreExpr -> IO CoreExpr
simplifyExpr HscEnv
hsc_env CoreExpr
ds_expr
; let tidy_expr :: CoreExpr
tidy_expr = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
emptyTidyEnv CoreExpr
simpl_expr
; CoreExpr
prepd_expr <- HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr HscEnv
hsc_env CoreExpr
tidy_expr
; SDoc -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr ([Char] -> SDoc
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. [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_hi_file",
ml_obj_file :: [Char]
ml_obj_file = forall a. [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_obj_file",
ml_hie_file :: [Char]
ml_hie_file = forall a. [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_hie_file" }
; let ictxt :: InteractiveContext
ictxt = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
; (Id
binding_id, [StgTopBinding]
stg_expr, InfoTableProvMap
_, ([CostCentre], [CostCentreStack])
_) <-
Logger
-> DynFlags
-> InteractiveContext
-> Module
-> ModLocation
-> CoreExpr
-> IO
(Id, [StgTopBinding], InfoTableProvMap,
([CostCentre], [CostCentreStack]))
myCoreToStgExpr (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
(HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
InteractiveContext
ictxt
(InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
ModLocation
iNTERACTIVELoc
CoreExpr
prepd_expr
; CompiledByteCode
bcos <- HscEnv
-> Module
-> [StgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env
(InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
[StgTopBinding]
stg_expr
[] forall a. Maybe a
Nothing
; [(Name, ForeignHValue)]
fv_hvs <- Interp
-> HscEnv
-> SrcSpan
-> CompiledByteCode
-> IO [(Name, ForeignHValue)]
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) }
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env = do
ExternalPackageState
eps <- forall a. IORef a -> IO a
readIORef (HscEnv -> IORef ExternalPackageState
hsc_EPS HscEnv
hsc_env)
Logger -> DynFlags -> Bool -> [Char] -> SDoc -> IO ()
dumpIfSet Logger
logger DynFlags
dflags (Bool
dump_if_trace Bool -> Bool -> Bool
|| Bool
dump_rn_stats)
[Char]
"Interface statistics"
(ExternalPackageState -> SDoc
ifaceStats ExternalPackageState
eps)
where
dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
dump_rn_stats :: Bool
dump_rn_stats = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_rn_stats DynFlags
dflags
dump_if_trace :: Bool
dump_if_trace = DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_if_trace DynFlags
dflags
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex (Int
i,Int
n) = [Char] -> SDoc
text [Char]
"[" SDoc -> SDoc -> SDoc
<> SDoc
pad SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
" of " SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
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 = [Char] -> SDoc
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
' ')