{-# LANGUAGE BangPatterns #-}

{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE GADTs #-}

{-# OPTIONS_GHC -fprof-auto-top #-}

-------------------------------------------------------------------------------
--
-- | Main API for compiling plain Haskell source code.
--
-- This module implements compilation of a Haskell source. It is
-- /not/ concerned with preprocessing of source files; this is handled
-- in "GHC.Driver.Pipeline"
--
-- There are various entry points depending on what mode we're in:
-- "batch" mode (@--make@), "one-shot" mode (@-c@, @-S@ etc.), and
-- "interactive" mode (GHCi). There are also entry points for
-- individual passes: parsing, typechecking/renaming, desugaring, and
-- simplification.
--
-- All the functions here take an 'HscEnv' as a parameter, but none of
-- them return a new one: 'HscEnv' is treated as an immutable value
-- from here on in (although it has mutable components, for the
-- caches).
--
-- We use the Hsc monad to deal with warning messages consistently:
-- specifically, while executing within an Hsc monad, warnings are
-- collected. When a Hsc monad returns to an IO monad, the
-- warnings are printed, or compilation aborts if the @-Werror@
-- flag is enabled.
--
-- (c) The GRASP/AQUA Project, Glasgow University, 1993-2000
--
-------------------------------------------------------------------------------

module GHC.Driver.Main
    (
    -- * Making an HscEnv
      newHscEnv
    , newHscEnvWithHUG

    -- * Compiling complete source files
    , Messager, batchMsg, batchMultiMsg
    , HscBackendAction (..), HscRecompStatus (..)
    , initModDetails
    , hscMaybeWriteIface
    , hscCompileCmmFile

    , hscGenHardCode
    , hscInteractive

    -- * Running passes separately
    , hscRecompStatus
    , hscParse
    , hscTypecheckRename
    , hscTypecheckAndGetWarnings
    , hscDesugar
    , makeSimpleDetails
    , hscSimplify -- ToDo, shouldn't really export this
    , hscDesugarAndSimplify

    -- * Safe Haskell
    , hscCheckSafe
    , hscGetSafe

    -- * Support for interactive evaluation
    , hscParseIdentifier
    , hscTcRcLookupName
    , hscTcRnGetInfo
    , hscIsGHCiMonad
    , hscGetModuleInterface
    , hscRnImportDecls
    , hscTcRnLookupRdrName
    , hscStmt, hscParseStmtWithLocation, hscStmtWithLocation, hscParsedStmt
    , hscDecls, hscParseDeclsWithLocation, hscDeclsWithLocation, hscParsedDecls
    , hscParseModuleWithLocation
    , hscTcExpr, TcRnExprMode(..), hscImport, hscKcType
    , hscParseExpr
    , hscParseType
    , hscCompileCoreExpr
    , hscTidy


    -- * Low-level exports for hooks
    , hscCompileCoreExpr'
      -- We want to make sure that we export enough to be able to redefine
      -- hsc_typecheck in client code
    , hscParse', hscSimplify', hscDesugar', tcRnModule', doCodeGen
    , getHscEnv
    , hscSimpleIface'
    , oneShotMsg
    , dumpIfaceStats
    , ioMsgMaybe
    , showModuleIndex
    , hscAddSptEntries
    , writeInterfaceOnlyMode
    ) where

import GHC.Prelude

import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.CodeOutput
import GHC.Driver.Config.Logger   (initLogFlags)
import GHC.Driver.Config.Parser   (initParserOpts)
import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)
import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)
import GHC.Driver.Config.StgToCmm (initStgToCmmConfig)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Tidy
import GHC.Driver.Hooks

import GHC.Runtime.Context
import GHC.Runtime.Interpreter ( addSptEntry )
import GHC.Runtime.Loader      ( initializePlugins )
import GHCi.RemoteTypes        ( ForeignHValue )
import GHC.ByteCode.Types

import GHC.Linker.Loader
import GHC.Linker.Types

import GHC.Hs
import GHC.Hs.Dump
import GHC.Hs.Stats         ( ppSourceStats )

import GHC.HsToCore

import GHC.StgToByteCode    ( byteCodeGen )

import GHC.IfaceToCore  ( typecheckIface )

import GHC.Iface.Load   ( ifaceStats, writeIface )
import GHC.Iface.Make
import GHC.Iface.Recomp
import GHC.Iface.Tidy
import GHC.Iface.Ext.Ast    ( mkHieFile )
import GHC.Iface.Ext.Types  ( getAsts, hie_asts, hie_module )
import GHC.Iface.Ext.Binary ( readHieFile, writeHieFile , hie_file_result)
import GHC.Iface.Ext.Debug  ( diffFile, validateScopes )

import GHC.Core
import GHC.Core.Tidy           ( tidyExpr )
import GHC.Core.Type           ( Type, Kind )
import GHC.Core.Lint           ( lintInteractiveExpr, endPassIO )
import GHC.Core.Multiplicity
import GHC.Core.Utils          ( exprType )
import GHC.Core.ConLike
import GHC.Core.Opt.Monad      ( CoreToDo (..))
import GHC.Core.Opt.Pipeline
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Core.Rules
import GHC.Core.Stats
import GHC.Core.LateCC (addLateCostCentresPgm)


import GHC.CoreToStg.Prep
import GHC.CoreToStg    ( coreToStg )

import GHC.Parser.Errors.Types
import GHC.Parser
import GHC.Parser.Lexer as Lexer

import GHC.Tc.Module
import GHC.Tc.Utils.Monad
import GHC.Tc.Utils.Zonk    ( ZonkFlexi (DefaultFlexi) )

import GHC.Stg.Syntax
import GHC.Stg.Pipeline ( stg2stg, StgCgInfos )

import GHC.Builtin.Utils
import GHC.Builtin.Names
import GHC.Builtin.Uniques ( mkPseudoUniqueE )

import qualified GHC.StgToCmm as StgToCmm ( codeGen )
import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)

import GHC.Cmm
import GHC.Cmm.Parser       ( parseCmmFile )
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info

import GHC.Unit
import GHC.Unit.Env
import GHC.Unit.Finder
import GHC.Unit.External
import GHC.Unit.Module.ModDetails
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface
import GHC.Unit.Module.ModSummary
import GHC.Unit.Module.Graph
import GHC.Unit.Module.Imported
import GHC.Unit.Module.Deps
import GHC.Unit.Module.Status
import GHC.Unit.Home.ModInfo

import GHC.Types.Id
import GHC.Types.SourceError
import GHC.Types.SafeHaskell
import GHC.Types.ForeignStubs
import GHC.Types.Var.Env       ( emptyTidyEnv )
import GHC.Types.Error
import GHC.Types.Fixity.Env
import GHC.Types.CostCentre
import GHC.Types.IPE
import GHC.Types.SourceFile
import GHC.Types.SrcLoc
import GHC.Types.Name
import GHC.Types.Name.Cache ( initNameCache )
import GHC.Types.Name.Reader
import GHC.Types.Name.Ppr
import GHC.Types.TyThing
import GHC.Types.HpcInfo

import GHC.Utils.Fingerprint ( Fingerprint )
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import GHC.Utils.Error
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Logger
import GHC.Utils.TmpFs

import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Stream (Stream)
import qualified GHC.SysTools

import Data.Data hiding (Fixity, TyCon)
import Data.List        ( nub, isPrefixOf, partition )
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import System.IO (fixIO)
import qualified Data.Set as S
import Data.Set (Set)
import Data.Functor
import Control.DeepSeq (force)
import Data.Bifunctor (first)
import GHC.Data.Maybe
import GHC.Driver.Env.KnotVars
import GHC.Types.Name.Set (NonCaffySet)
import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub)
import Data.List.NonEmpty (NonEmpty ((:|)))
import GHC.Stg.InferTags.TagSig (seqTagSig)
import GHC.Types.Unique.FM


{- **********************************************************************
%*                                                                      *
                Initialisation
%*                                                                      *
%********************************************************************* -}

newHscEnv :: DynFlags -> IO HscEnv
newHscEnv :: DynFlags -> IO HscEnv
newHscEnv DynFlags
dflags = DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG DynFlags
dflags (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags) HomeUnitGraph
home_unit_graph
  where
    home_unit_graph :: HomeUnitGraph
home_unit_graph = forall v. UnitId -> v -> UnitEnvGraph v
unitEnv_singleton
                        (DynFlags -> UnitId
homeUnitId_ DynFlags
dflags)
                        (DynFlags -> HomePackageTable -> Maybe HomeUnit -> HomeUnitEnv
mkHomeUnitEnv DynFlags
dflags HomePackageTable
emptyHomePackageTable forall a. Maybe a
Nothing)

newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG :: DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG DynFlags
top_dynflags UnitId
cur_unit HomeUnitGraph
home_unit_graph = do
    NameCache
nc_var  <- Char -> [Name] -> IO NameCache
initNameCache Char
'r' [Name]
knownKeyNames
    FinderCache
fc_var  <- IO FinderCache
initFinderCache
    Logger
logger  <- IO Logger
initLogger
    TmpFs
tmpfs   <- IO TmpFs
initTmpFs
    let dflags :: DynFlags
dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags forall a b. (a -> b) -> a -> b
$ forall v. UnitId -> UnitEnvGraph v -> v
unitEnv_lookup UnitId
cur_unit HomeUnitGraph
home_unit_graph
    UnitEnv
unit_env <- UnitId -> HomeUnitGraph -> GhcNameVersion -> Platform -> IO UnitEnv
initUnitEnv UnitId
cur_unit HomeUnitGraph
home_unit_graph (DynFlags -> GhcNameVersion
ghcNameVersion DynFlags
dflags) (DynFlags -> Platform
targetPlatform DynFlags
dflags)
    forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv { hsc_dflags :: DynFlags
hsc_dflags = DynFlags
top_dynflags
                  , hsc_logger :: Logger
hsc_logger         = Logger -> LogFlags -> Logger
setLogFlags Logger
logger (DynFlags -> LogFlags
initLogFlags DynFlags
top_dynflags)
                  ,  hsc_targets :: [Target]
hsc_targets        = []
                  ,  hsc_mod_graph :: ModuleGraph
hsc_mod_graph      = ModuleGraph
emptyMG
                  ,  hsc_IC :: InteractiveContext
hsc_IC             = DynFlags -> InteractiveContext
emptyInteractiveContext DynFlags
dflags
                  ,  hsc_NC :: NameCache
hsc_NC             = NameCache
nc_var
                  ,  hsc_FC :: FinderCache
hsc_FC             = FinderCache
fc_var
                  ,  hsc_type_env_vars :: KnotVars (IORef TypeEnv)
hsc_type_env_vars  = forall a. KnotVars a
emptyKnotVars
                  ,  hsc_interp :: Maybe Interp
hsc_interp         = forall a. Maybe a
Nothing
                  ,  hsc_unit_env :: UnitEnv
hsc_unit_env       = UnitEnv
unit_env
                  ,  hsc_plugins :: Plugins
hsc_plugins        = Plugins
emptyPlugins
                  ,  hsc_hooks :: Hooks
hsc_hooks          = Hooks
emptyHooks
                  ,  hsc_tmpfs :: TmpFs
hsc_tmpfs          = TmpFs
tmpfs
                  }

-- -----------------------------------------------------------------------------

getDiagnostics :: Hsc (Messages GhcMessage)
getDiagnostics :: Hsc (Messages GhcMessage)
getDiagnostics = forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (Messages GhcMessage
w, Messages GhcMessage
w)

clearDiagnostics :: Hsc ()
clearDiagnostics :: Hsc ()
clearDiagnostics = forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), forall e. Messages e
emptyMessages)

logDiagnostics :: Messages GhcMessage -> Hsc ()
logDiagnostics :: Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
w = forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
_ Messages GhcMessage
w0 -> forall (m :: * -> *) a. Monad m => a -> m a
return ((), Messages GhcMessage
w0 forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages GhcMessage
w)

getHscEnv :: Hsc HscEnv
getHscEnv :: Hsc HscEnv
getHscEnv = forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
e Messages GhcMessage
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, Messages GhcMessage
w)

handleWarnings :: Hsc ()
handleWarnings :: Hsc ()
handleWarnings = do
    DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    Messages GhcMessage
w <- Hsc (Messages GhcMessage)
getDiagnostics
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagOpts
diag_opts Messages GhcMessage
w
    Hsc ()
clearDiagnostics

-- | log warning in the monad, and if there are errors then
-- throw a SourceError exception.
logWarningsReportErrors :: (Messages PsWarning, Messages PsError) -> Hsc ()
logWarningsReportErrors :: (Messages PsWarning, Messages PsWarning) -> Hsc ()
logWarningsReportErrors (Messages PsWarning
warnings,Messages PsWarning
errors) = do
    Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warnings)
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall e. Messages e -> Bool
isEmptyMessages Messages PsWarning
errors) forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
errors)

-- | Log warnings and throw errors, assuming the messages
-- contain at least one error (e.g. coming from PFailed)
handleWarningsThrowErrors :: (Messages PsWarning, Messages PsError) -> Hsc a
handleWarningsThrowErrors :: forall a. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (Messages PsWarning
warnings, Messages PsWarning
errors) = do
    DiagOpts
diag_opts <- DynFlags -> DiagOpts
initDiagOpts forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warnings)
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    let (Messages PsWarning
wWarns, Messages PsWarning
wErrs) = forall e. Diagnostic e => Messages e -> (Messages e, Messages e)
partitionMessages Messages PsWarning
warnings
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Diagnostic a => Logger -> DiagOpts -> Messages a -> IO ()
printMessages Logger
logger DiagOpts
diag_opts Messages PsWarning
wWarns
    forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap PsWarning -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ Messages PsWarning
errors forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages PsWarning
wErrs

-- | Deal with errors and warnings returned by a compilation step
--
-- In order to reduce dependencies to other parts of the compiler, functions
-- outside the "main" parts of GHC return warnings and errors as a parameter
-- and signal success via by wrapping the result in a 'Maybe' type. This
-- function logs the returned warnings and propagates errors as exceptions
-- (of type 'SourceError').
--
-- This function assumes the following invariants:
--
--  1. If the second result indicates success (is of the form 'Just x'),
--     there must be no error messages in the first result.
--
--  2. If there are no error messages, but the second result indicates failure
--     there should be warnings in the first result. That is, if the action
--     failed, it must have been due to the warnings (i.e., @-Werror@).
ioMsgMaybe :: IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe :: forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe IO (Messages GhcMessage, Maybe a)
ioA = do
    (Messages GhcMessage
msgs, Maybe a
mb_r) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Messages GhcMessage, Maybe a)
ioA
    let (Messages GhcMessage
warns, Messages GhcMessage
errs) = forall e. Diagnostic e => Messages e -> (Messages e, Messages e)
partitionMessages Messages GhcMessage
msgs
    Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
warns
    case Maybe a
mb_r of
        Maybe a
Nothing -> forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors Messages GhcMessage
errs
        Just a
r  -> forall a. HasCallStack => Bool -> a -> a
assert (forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
errs ) forall (m :: * -> *) a. Monad m => a -> m a
return a
r

-- | like ioMsgMaybe, except that we ignore error messages and return
-- 'Nothing' instead.
ioMsgMaybe' :: IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' :: forall a. IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' IO (Messages GhcMessage, Maybe a)
ioA = do
    (Messages GhcMessage
msgs, Maybe a
mb_r) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe a)
ioA
    Messages GhcMessage -> Hsc ()
logDiagnostics (forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall a b. (a -> b) -> a -> b
$ forall e. Diagnostic e => Messages e -> Bag (MsgEnvelope e)
getWarningMessages Messages GhcMessage
msgs)
    forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
mb_r

-- -----------------------------------------------------------------------------
-- | Lookup things in the compiler's environment

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 GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> LocatedN RdrName -> IO (Messages TcRnMessage, Maybe [Name])
tcRnLookupRdrName HscEnv
hsc_env LocatedN RdrName
rdr_name }

hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName HscEnv
hsc_env0 Name
name = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  forall a. IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> Name -> IO (Messages TcRnMessage, Maybe TyThing)
tcRnLookupName HscEnv
hsc_env Name
name
      -- ignore errors: the only error we're likely to get is
      -- "name not found", and the Maybe in the return type
      -- is used to indicate that.

hscTcRnGetInfo :: HscEnv -> Name
               -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo :: HscEnv
-> Name -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
hscTcRnGetInfo HscEnv
hsc_env0 Name
name
  = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$
    do { HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
       ; forall a. IO (Messages GhcMessage, Maybe a) -> Hsc (Maybe a)
ioMsgMaybe' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> Name
-> IO
     (Messages TcRnMessage,
      Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
tcRnGetInfo HscEnv
hsc_env Name
name }

hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad :: HscEnv -> [Char] -> IO Name
hscIsGHCiMonad HscEnv
hsc_env [Char]
name
  = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> [Char] -> IO (Messages TcRnMessage, Maybe Name)
isGHCiMonad HscEnv
hsc_env [Char]
name

hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface :: HscEnv -> Module -> IO ModIface
hscGetModuleInterface HscEnv
hsc_env0 Module
mod = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
mod

-- -----------------------------------------------------------------------------
-- | Rename some import declarations
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls :: HscEnv -> [LImportDecl GhcPs] -> IO GlobalRdrEnv
hscRnImportDecls HscEnv
hsc_env0 [LImportDecl GhcPs]
import_decls = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LImportDecl GhcPs]
-> IO (Messages TcRnMessage, Maybe GlobalRdrEnv)
tcRnImportDecls HscEnv
hsc_env [LImportDecl GhcPs]
import_decls

-- -----------------------------------------------------------------------------
-- | parse a file, returning the abstract syntax

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

-- internal version, that doesn't fail due to -Werror
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' :: ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
 | Just HsParsedModule
r <- ModSummary -> Maybe HsParsedModule
ms_parsed_mod ModSummary
mod_summary = forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
r
 | Bool
otherwise = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    {-# SCC "Parser" #-} forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
                ([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

    --------------------------  Parser  ----------------
    -- sometimes we already have the buffer in memory, perhaps
    -- because we needed to parse the imports out of it, or get the
    -- module name.
    StringBuffer
buf <- case Maybe StringBuffer
maybe_src_buf of
               Just StringBuffer
b  -> forall (m :: * -> *) a. Monad m => a -> m a
return StringBuffer
b
               Maybe StringBuffer
Nothing -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> IO StringBuffer
hGetStringBuffer [Char]
src_filename

    let loc :: RealSrcLoc
loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
mkFastString [Char]
src_filename) Int
1 Int
1

    let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnUnicodeBidirectionalFormatCharacters DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ do
      case PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, [Char]))
checkBidirectionFormatChars (RealSrcLoc -> BufPos -> PsLoc
PsLoc RealSrcLoc
loc (Int -> BufPos
BufPos Int
0)) StringBuffer
buf of
        Maybe (NonEmpty (PsLoc, Char, [Char]))
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
        Just chars :: NonEmpty (PsLoc, Char, [Char])
chars@((PsLoc
eloc,Char
chr,[Char]
_) :| [(PsLoc, Char, [Char])]
_) ->
          let span :: SrcSpan
span = PsSpan -> SrcSpan
mkSrcSpanPs forall a b. (a -> b) -> a -> b
$ PsLoc -> PsLoc -> PsSpan
mkPsSpan PsLoc
eloc (PsLoc -> Char -> PsLoc
advancePsLoc PsLoc
eloc Char
chr)
          in Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
               forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
span forall a b. (a -> b) -> a -> b
$
               PsWarning -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ NonEmpty (PsLoc, Char, [Char]) -> PsWarning
PsWarnBidirectionalFormatChars NonEmpty (PsLoc, Char, [Char])
chars

    let parseMod :: P (Located HsModule)
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. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst)
        POk PState
pst Located HsModule
rdr_module -> do
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_parsed [Char]
"Parser"
                        DumpFormat
FormatHaskell (forall a. Outputable a => a -> SDoc
ppr Located HsModule
rdr_module)
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_parsed_ast [Char]
"Parser AST"
                        DumpFormat
FormatHaskell (forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan
                                                   BlankEpAnnotations
NoBlankEpAnnotations
                                                   Located HsModule
rdr_module)
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_source_stats [Char]
"Source Statistics"
                        DumpFormat
FormatText (Bool -> Located HsModule -> SDoc
ppSourceStats Bool
False Located HsModule
rdr_module)

            -- To get the list of extra source files, we take the list
            -- that the parser gave us,
            --   - eliminate files beginning with '<'.  gcc likes to use
            --     pseudo-filenames like "<built-in>" and "<command-line>"
            --   - normalise them (eliminate differences between ./f and f)
            --   - filter out the preprocessed source file
            --   - filter out anything beginning with tmpdir
            --   - remove duplicates
            --   - filter out the .hs/.lhs source filename if we have one
            --
            let n_hspp :: [Char]
n_hspp  = [Char] -> [Char]
FilePath.normalise [Char]
src_filename
                TempDir [Char]
tmp_dir = DynFlags -> TempDir
tmpDir DynFlags
dflags
                srcs0 :: [[Char]]
srcs0 = forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
tmp_dir forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
                            forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Eq a => a -> a -> Bool
== [Char]
n_hspp))
                            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
FilePath.normalise
                            forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"<")
                            forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map FastString -> [Char]
unpackFS
                            forall a b. (a -> b) -> a -> b
$ PState -> [FastString]
srcfiles PState
pst
                srcs1 :: [[Char]]
srcs1 = case ModLocation -> Maybe [Char]
ml_hs_file (ModSummary -> ModLocation
ms_location ModSummary
mod_summary) of
                          Just [Char]
f  -> forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= [Char] -> [Char]
FilePath.normalise [Char]
f) [[Char]]
srcs0
                          Maybe [Char]
Nothing -> [[Char]]
srcs0

            -- sometimes we see source files from earlier
            -- preprocessing stages that cannot be found, so just
            -- filter them out:
            [[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
                   }

            -- apply parse transformation of plugins
            let applyPluginAction :: Plugin -> [[Char]] -> ParsedResult -> Hsc ParsedResult
applyPluginAction Plugin
p [[Char]]
opts
                  = Plugin
-> [[Char]] -> ModSummary -> ParsedResult -> Hsc ParsedResult
parsedResultAction Plugin
p [[Char]]
opts ModSummary
mod_summary
            HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
            (ParsedResult HsParsedModule
transformed (PsMessages Messages PsWarning
warns Messages PsWarning
errs)) <-
              forall (m :: * -> *) a.
Monad m =>
Plugins -> PluginOperation m a -> a -> m a
withPlugins (HscEnv -> Plugins
hsc_plugins HscEnv
hsc_env) Plugin -> [[Char]] -> ParsedResult -> Hsc ParsedResult
applyPluginAction
                (HsParsedModule -> PsMessages -> ParsedResult
ParsedResult HsParsedModule
res (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Messages PsWarning -> Messages PsWarning -> PsMessages
PsMessages forall a b. (a -> b) -> a -> b
$ PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst))

            Messages GhcMessage -> Hsc ()
logDiagnostics (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warns)
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall e. Messages e -> Bool
isEmptyMessages Messages PsWarning
errs) forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
errs)

            forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
transformed

checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))
checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, [Char]))
checkBidirectionFormatChars PsLoc
start_loc StringBuffer
sb
  | StringBuffer -> Bool
containsBidirectionalFormatChar StringBuffer
sb = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, [Char])
go PsLoc
start_loc StringBuffer
sb
  | Bool
otherwise = forall a. Maybe a
Nothing
  where
    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, String)
    go :: PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, [Char])
go PsLoc
loc StringBuffer
sb
      | StringBuffer -> Bool
atEnd StringBuffer
sb = forall a. [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


-- -----------------------------------------------------------------------------
-- | If the renamed source has been kept, extract it. Dump it if requested.


extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff :: ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result = do
    let rn_info :: RenamedStuff
rn_info = TcGblEnv -> RenamedStuff
getRenamedStuff TcGblEnv
tc_result

    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_rn_ast [Char]
"Renamer"
                DumpFormat
FormatHaskell (forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations RenamedStuff
rn_info)

    -- Create HIE files
    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
        -- I assume this fromJust is safe because `-fwrite-hie-file`
        -- enables the option which keeps the renamed source.
        HieFile
hieFile <- forall (m :: * -> *).
MonadIO m =>
ModSummary -> TcGblEnv -> RenamedSource -> m HieFile
mkHieFile ModSummary
mod_summary TcGblEnv
tc_result (forall a. HasCallStack => Maybe a -> a
fromJust RenamedStuff
rn_info)
        let out_file :: [Char]
out_file = ModLocation -> [Char]
ml_hie_file forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
mod_summary
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ [Char] -> HieFile -> IO ()
writeHieFile [Char]
out_file HieFile
hieFile
        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_hie [Char]
"HIE AST" DumpFormat
FormatHaskell (forall a. Outputable a => a -> SDoc
ppr forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hieFile)

        -- Validate HIE files
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ValidateHie DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ do
            HscEnv
hs_env <- forall a.
(HscEnv -> Messages GhcMessage -> IO (a, Messages GhcMessage))
-> Hsc a
Hsc forall a b. (a -> b) -> a -> b
$ \HscEnv
e Messages GhcMessage
w -> forall (m :: * -> *) a. Monad m => a -> m a
return (HscEnv
e, Messages GhcMessage
w)
            forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
              -- Validate Scopes
              case forall a. Module -> Map HiePath (HieAST a) -> [SDoc]
validateScopes (HieFile -> Module
hie_module HieFile
hieFile) forall a b. (a -> b) -> a -> b
$ forall a. HieASTs a -> Map HiePath (HieAST a)
getAsts forall a b. (a -> b) -> a -> b
$ HieFile -> HieASTs Int
hie_asts HieFile
hieFile of
                  [] -> Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"Got valid scopes"
                  [SDoc]
xs -> do
                    Logger -> SDoc -> IO ()
putMsg Logger
logger 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 -> SDoc -> IO ()
putMsg Logger
logger) [SDoc]
xs
              -- Roundtrip testing
              HieFileResult
file' <- NameCache -> [Char] -> IO HieFileResult
readHieFile (HscEnv -> NameCache
hsc_NC HscEnv
hs_env) [Char]
out_file
              case Diff HieFile
diffFile HieFile
hieFile (HieFileResult -> HieFile
hie_file_result HieFileResult
file') of
                [] ->
                  Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"Got no roundtrip errors"
                [SDoc]
xs -> do
                  Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"Got roundtrip errors"
                  let logger' :: Logger
logger' = Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags Logger
logger (DumpFlag -> LogFlags -> LogFlags
log_set_dopt DumpFlag
Opt_D_ppr_debug)
                  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> SDoc -> IO ()
putMsg Logger
logger') [SDoc]
xs
    forall (m :: * -> *) a. Monad m => a -> m a
return RenamedStuff
rn_info


-- -----------------------------------------------------------------------------
-- | Rename and typecheck a module, additionally returning the renamed syntax
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)

-- | Do Typechecking without throwing SourceError exception with -Werror
hscTypecheckAndGetWarnings :: HscEnv ->  ModSummary -> IO (FrontendResult, WarningMessages)
hscTypecheckAndGetWarnings :: HscEnv -> ModSummary -> IO (FrontendResult, Messages GhcMessage)
hscTypecheckAndGetWarnings HscEnv
hsc_env ModSummary
summary = forall a. HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
  case Hooks -> Maybe (ModSummary -> Hsc FrontendResult)
hscFrontendHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) of
    Maybe (ModSummary -> Hsc FrontendResult)
Nothing -> TcGblEnv -> FrontendResult
FrontendTypecheck forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
False ModSummary
summary forall a. Maybe a
Nothing
    Just ModSummary -> Hsc FrontendResult
h  -> ModSummary -> Hsc FrontendResult
h ModSummary
summary

-- | A bunch of logic piled around @tcRnModule'@, concerning a) backpack
-- b) concerning dumping rename info and hie files. It would be nice to further
-- separate this stuff out, probably in conjunction better separating renaming
-- and type checking (#17781).
hsc_typecheck :: Bool -- ^ Keep renamed source?
              -> ModSummary -> Maybe HsParsedModule
              -> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck :: Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
keep_rn ModSummary
mod_summary Maybe HsParsedModule
mb_rdr_module = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    let hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
        outer_mod :: Module
outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
        mod_name :: ModuleName
mod_name = forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod
        outer_mod' :: Module
outer_mod' = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
        inner_mod :: Module
inner_mod = HomeUnit -> ModuleName -> Module
homeModuleNameInstantiation HomeUnit
home_unit ModuleName
mod_name
        src_filename :: [Char]
src_filename  = ModSummary -> [Char]
ms_hspp_file ModSummary
mod_summary
        real_loc :: RealSrcSpan
real_loc = RealSrcLoc -> RealSrcSpan
realSrcLocSpan forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
mkFastString [Char]
src_filename) Int
1 Int
1
        keep_rn' :: Bool
keep_rn' = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags Bool -> Bool -> Bool
|| Bool
keep_rn
    forall (m :: * -> *). (HasCallStack, Applicative m) => Bool -> m ()
massert (HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
outer_mod)
    TcGblEnv
tc_result <- if HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile Bool -> Bool -> Bool
&& Bool -> Bool
not (forall u. GenModule (GenUnit u) -> Bool
isHoleModule Module
inner_mod)
        then forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> RealSrcSpan
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnInstantiateSignature HscEnv
hsc_env Module
outer_mod' RealSrcSpan
real_loc
        else
         do HsParsedModule
hpm <- case Maybe HsParsedModule
mb_rdr_module of
                    Just HsParsedModule
hpm -> forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
hpm
                    Maybe HsParsedModule
Nothing -> ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
            TcGblEnv
tc_result0 <- ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' ModSummary
mod_summary Bool
keep_rn' HsParsedModule
hpm
            if HscSource
hsc_src forall a. Eq a => a -> a -> Bool
== HscSource
HsigFile
                then do (ModIface
iface, ModDetails
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> TcGblEnv -> ModSummary -> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result0 ModSummary
mod_summary
                        forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$
                            HscEnv
-> HsParsedModule
-> TcGblEnv
-> ModIface
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnMergeSignatures HscEnv
hsc_env HsParsedModule
hpm TcGblEnv
tc_result0 ModIface
iface
                else forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tc_result0
    -- TODO are we extracting anything when we merely instantiate a signature?
    -- If not, try to move this into the "else" case above.
    Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
rn_info <- ModSummary -> TcGblEnv -> Hsc RenamedStuff
extract_renamed_stuff ModSummary
mod_summary TcGblEnv
tc_result
    forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv
tc_result, Maybe
  (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
   Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
   Maybe (LHsDoc GhcRn))
rn_info)

-- wrapper around tcRnModule to handle safe haskell extras
tcRnModule' :: ModSummary -> Bool -> HsParsedModule
            -> Hsc TcGblEnv
tcRnModule' :: ModSummary -> Bool -> HsParsedModule -> Hsc TcGblEnv
tcRnModule' ModSummary
sum Bool
save_rn_syntax HsParsedModule
mod = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    DynFlags
dflags  <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
    -- -Wmissing-safe-haskell-mode
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (DynFlags -> Bool
safeHaskellModeEnabled DynFlags
dflags)
          Bool -> Bool -> Bool
&& WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnMissingSafeHaskellMode DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
        Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
        forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (forall l e. GenLocated l e -> l
getLoc (HsParsedModule -> Located HsModule
hpm_module HsParsedModule
mod)) forall a b. (a -> b) -> a -> b
$
        DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverMissingSafeHaskellMode (ModSummary -> Module
ms_mod ModSummary
sum)

    TcGblEnv
tcg_res <- {-# SCC "Typecheck-Rename" #-}
               forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$
                   HscEnv
-> ModSummary
-> Bool
-> HsParsedModule
-> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnModule HscEnv
hsc_env ModSummary
sum
                     Bool
save_rn_syntax HsParsedModule
mod

    -- See Note [Safe Haskell Overlapping Instances Implementation]
    -- although this is used for more than just that failure case.
    Bool
tcSafeOK <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef Bool
tcg_safe_infer TcGblEnv
tcg_res)
    Messages TcRnMessage
whyUnsafe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef (Messages TcRnMessage)
tcg_safe_infer_reasons TcGblEnv
tcg_res)
    let allSafeOK :: Bool
allSafeOK = DynFlags -> Bool
safeInferred DynFlags
dflags Bool -> Bool -> Bool
&& Bool
tcSafeOK

    -- end of the safe haskell line, how to respond to user?
    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)
      -- if safe Haskell off or safe infer failed, mark unsafe
      then forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_res Messages TcRnMessage
whyUnsafe

      -- module (could be) safe, throw warning if needed
      else do
          TcGblEnv
tcg_res' <- TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports TcGblEnv
tcg_res
          Bool
safe <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef (TcGblEnv -> TcRef Bool
tcg_safe_infer TcGblEnv
tcg_res')
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
safe forall a b. (a -> b) -> a -> b
$
            case WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnSafe DynFlags
dflags of
              Bool
True
                | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Safe -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise -> (Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
                       forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (DynFlags -> SrcSpan
warnSafeOnLoc DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
                       DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverInferredSafeModule (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_res'))
              Bool
False | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy Bool -> Bool -> Bool
&&
                      WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnTrustworthySafe DynFlags
dflags ->
                      (Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
                       forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (DynFlags -> SrcSpan
trustworthyOnLoc DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
                       DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverMarkedTrustworthyButInferredSafe (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_res'))
              Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
          forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_res'

-- | Convert a typechecked module to Core
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar :: HscEnv -> ModSummary -> TcGblEnv -> IO ModGuts
hscDesugar HscEnv
hsc_env ModSummary
mod_summary TcGblEnv
tc_result =
    forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' (ModSummary -> ModLocation
ms_location ModSummary
mod_summary) TcGblEnv
tc_result

hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' :: ModLocation -> TcGblEnv -> Hsc ModGuts
hscDesugar' ModLocation
mod_location TcGblEnv
tc_result = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages DsMessage, a) -> m (Messages GhcMessage, a)
hoistDsMessage forall a b. (a -> b) -> a -> b
$
      {-# SCC "deSugar" #-}
      HscEnv
-> ModLocation
-> TcGblEnv
-> IO (Messages DsMessage, Maybe ModGuts)
deSugar HscEnv
hsc_env ModLocation
mod_location TcGblEnv
tc_result

-- | Make a 'ModDetails' from the results of typechecking. Used when
-- typechecking only, as opposed to full compilation.
makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails
makeSimpleDetails :: Logger -> TcGblEnv -> IO ModDetails
makeSimpleDetails Logger
logger TcGblEnv
tc_result = Logger -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc Logger
logger TcGblEnv
tc_result


{- **********************************************************************
%*                                                                      *
                The main compiler pipeline
%*                                                                      *
%********************************************************************* -}

{-
                   --------------------------------
                        The compilation proper
                   --------------------------------

It's the task of the compilation proper to compile Haskell, hs-boot and core
files to either byte-code, hard-code (C, asm, LLVM, etc.) or to nothing at all
(the module is still parsed and type-checked. This feature is mostly used by
IDE's and the likes). Compilation can happen in either 'one-shot', 'batch',
'nothing', or 'interactive' mode. 'One-shot' mode targets hard-code, 'batch'
mode targets hard-code, 'nothing' mode targets nothing and 'interactive' mode
targets byte-code.

The modes are kept separate because of their different types and meanings:

 * In 'one-shot' mode, we're only compiling a single file and can therefore
 discard the new ModIface and ModDetails. This is also the reason it only
 targets hard-code; compiling to byte-code or nothing doesn't make sense when
 we discard the result.

 * 'Batch' mode is like 'one-shot' except that we keep the resulting ModIface
 and ModDetails. 'Batch' mode doesn't target byte-code since that require us to
 return the newly compiled byte-code.

 * 'Nothing' mode has exactly the same type as 'batch' mode but they're still
 kept separate. This is because compiling to nothing is fairly special: We
 don't output any interface files, we don't run the simplifier and we don't
 generate any code.

 * 'Interactive' mode is similar to 'batch' mode except that we return the
 compiled byte-code together with the ModIface and ModDetails.

Trying to compile a hs-boot file to byte-code will result in a run-time error.
This is the only thing that isn't caught by the type-system.
-}


type Messager = HscEnv -> (Int,Int) -> RecompileRequired -> ModuleGraphNode -> IO ()

-- | Do the recompilation avoidance checks for both one-shot and --make modes
-- This function is the *only* place in the compiler where we decide whether to
-- recompile a module or not!
hscRecompStatus :: Maybe Messager
                -> HscEnv
                -> ModSummary
                -> Maybe ModIface
                -> Maybe Linkable
                -> (Int,Int)
                -> IO HscRecompStatus
hscRecompStatus :: Maybe Messager
-> HscEnv
-> ModSummary
-> Maybe ModIface
-> Maybe Linkable
-> (Int, Int)
-> IO HscRecompStatus
hscRecompStatus
    Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
mb_old_iface Maybe Linkable
old_linkable (Int, Int)
mod_index
  = do
    let
        msg :: RecompileRequired -> IO ()
msg RecompileRequired
what = case Maybe Messager
mHscMessage of
          Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
what ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [] ModSummary
mod_summary)
          Maybe Messager
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- First check to see if the interface file agrees with the
    -- source file.
    --
    -- Save the interface that comes back from checkOldIface.
    -- In one-shot mode we don't have the old iface until this
    -- point, when checkOldIface reads it from the disk.
    MaybeValidated ModIface
recomp_if_result
          <- {-# SCC "checkOldIface" #-}
             forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModSummary -> Maybe ModIface -> IO (MaybeValidated ModIface)
checkOldIface HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
mb_old_iface
    case MaybeValidated ModIface
recomp_if_result of
      OutOfDateItem CompileReason
reason Maybe ModIface
mb_checked_iface -> do
        RecompileRequired -> IO ()
msg forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
reason
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Fingerprint -> HscRecompStatus
HscRecompNeeded forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModIfaceBackend -> Fingerprint
mi_iface_hash forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts) Maybe ModIface
mb_checked_iface
      UpToDateItem ModIface
checked_iface -> do
        let lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
mod_summary
        case DynFlags -> Backend
backend DynFlags
lcl_dflags of
          -- No need for a linkable, we're good to go
          Backend
NoBackend -> do
            RecompileRequired -> IO ()
msg forall a b. (a -> b) -> a -> b
$ RecompileRequired
UpToDate
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModIface -> Maybe Linkable -> HscRecompStatus
HscUpToDate ModIface
checked_iface forall a. Maybe a
Nothing
          -- Do need linkable
          Backend
_ -> do
            -- Check to see whether the expected build products already exist.
            -- If they don't exists then we trigger recompilation.
            MaybeValidated Linkable
recomp_linkable_result <- case () of
               -- Interpreter can use either already loaded bytecode or loaded object code
               ()
_ | Backend
Interpreter <- DynFlags -> Backend
backend DynFlags
lcl_dflags -> do
                     let res :: MaybeValidated Linkable
res = Maybe Linkable -> MaybeValidated Linkable
checkByteCode Maybe Linkable
old_linkable
                     case MaybeValidated Linkable
res of
                       UpToDateItem Linkable
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure MaybeValidated Linkable
res
                       MaybeValidated Linkable
_ -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags
-> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
checkObjects DynFlags
lcl_dflags Maybe Linkable
old_linkable ModSummary
mod_summary
                 -- Need object files for making object files
                 | Backend -> Bool
backendProducesObject (DynFlags -> Backend
backend DynFlags
lcl_dflags) -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DynFlags
-> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
checkObjects DynFlags
lcl_dflags Maybe Linkable
old_linkable ModSummary
mod_summary
                 | Bool
otherwise -> forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"hscRecompStatus" ([Char] -> SDoc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
backend DynFlags
lcl_dflags)
            case MaybeValidated Linkable
recomp_linkable_result of
              UpToDateItem Linkable
linkable -> do
                RecompileRequired -> IO ()
msg forall a b. (a -> b) -> a -> b
$ RecompileRequired
UpToDate
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModIface -> Maybe Linkable -> HscRecompStatus
HscUpToDate ModIface
checked_iface forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Linkable
linkable
              OutOfDateItem CompileReason
reason Maybe Linkable
_ -> do
                RecompileRequired -> IO ()
msg forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
reason
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Maybe Fingerprint -> HscRecompStatus
HscRecompNeeded forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ ModIfaceBackend -> Fingerprint
mi_iface_hash forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts forall a b. (a -> b) -> a -> b
$ ModIface
checked_iface

-- | Check that the .o files produced by compilation are already up-to-date
-- or not.
checkObjects :: DynFlags -> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
checkObjects :: DynFlags
-> Maybe Linkable -> ModSummary -> IO (MaybeValidated Linkable)
checkObjects DynFlags
dflags Maybe Linkable
mb_old_linkable ModSummary
summary = do
  let
    dt_enabled :: Bool
dt_enabled  = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_BuildDynamicToo DynFlags
dflags
    this_mod :: Module
this_mod    = ModSummary -> Module
ms_mod ModSummary
summary
    mb_obj_date :: Maybe UTCTime
mb_obj_date = ModSummary -> Maybe UTCTime
ms_obj_date ModSummary
summary
    mb_dyn_obj_date :: Maybe UTCTime
mb_dyn_obj_date = ModSummary -> Maybe UTCTime
ms_dyn_obj_date ModSummary
summary
    mb_if_date :: Maybe UTCTime
mb_if_date  = ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
summary
    obj_fn :: [Char]
obj_fn      = ModLocation -> [Char]
ml_obj_file (ModSummary -> ModLocation
ms_location ModSummary
summary)
    -- dynamic-too *also* produces the dyn_o_file, so have to check
    -- that's there, and if it's not, regenerate both .o and
    -- .dyn_o
    checkDynamicObj :: IO (MaybeValidated Linkable) -> IO (MaybeValidated Linkable)
checkDynamicObj IO (MaybeValidated Linkable)
k = if Bool
dt_enabled
      then case forall a. Ord a => a -> a -> Bool
(>=) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb_dyn_obj_date forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
mb_if_date of
        Just Bool
True -> IO (MaybeValidated Linkable)
k
        Maybe Bool
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingDynObjectFile forall a. Maybe a
Nothing
      -- Not in dynamic-too mode
      else IO (MaybeValidated Linkable)
k

  IO (MaybeValidated Linkable) -> IO (MaybeValidated Linkable)
checkDynamicObj forall a b. (a -> b) -> a -> b
$
    case (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb_obj_date forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe UTCTime
mb_if_date of
      Just (UTCTime
obj_date, UTCTime
if_date)
        | UTCTime
obj_date forall a. Ord a => a -> a -> Bool
>= UTCTime
if_date ->
            case Maybe Linkable
mb_old_linkable of
              Just Linkable
old_linkable
                | Linkable -> Bool
isObjectLinkable Linkable
old_linkable, Linkable -> UTCTime
linkableTime Linkable
old_linkable forall a. Eq a => a -> a -> Bool
== UTCTime
obj_date
                -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> MaybeValidated a
UpToDateItem Linkable
old_linkable
              Maybe Linkable
_ -> forall a. a -> MaybeValidated a
UpToDateItem forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Module -> [Char] -> UTCTime -> IO Linkable
findObjectLinkable Module
this_mod [Char]
obj_fn UTCTime
obj_date
      Maybe (UTCTime, UTCTime)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingObjectFile forall a. Maybe a
Nothing

-- | Check to see if we can reuse the old linkable, by this point we will
-- have just checked that the old interface matches up with the source hash, so
-- no need to check that again here
checkByteCode :: Maybe Linkable -> MaybeValidated Linkable
checkByteCode :: Maybe Linkable -> MaybeValidated Linkable
checkByteCode Maybe Linkable
mb_old_linkable =
  case Maybe Linkable
mb_old_linkable of
    Just Linkable
old_linkable
      | Bool -> Bool
not (Linkable -> Bool
isObjectLinkable Linkable
old_linkable)
      -> forall a. a -> MaybeValidated a
UpToDateItem Linkable
old_linkable
    Maybe Linkable
_ -> forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingBytecode forall a. Maybe a
Nothing

--------------------------------------------------------------
-- Compilers
--------------------------------------------------------------


-- Knot tying!  See Note [Knot-tying typecheckIface]
-- See Note [ModDetails and --make mode]
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 act :: HomePackageTable -> HomePackageTable
act HomePackageTable
hpt  = HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (ModSummary -> ModuleName
ms_mod_name ModSummary
mod_summary)
                                (ModIface -> ModDetails -> Maybe Linkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details' forall a. Maybe a
Nothing)
    let hsc_env' :: HscEnv
hsc_env' = (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT HomePackageTable -> HomePackageTable
act HscEnv
hsc_env
    -- NB: This result is actually not that useful
    -- in one-shot mode, since we're not going to do
    -- any further typechecking.  It's much more useful
    -- in make mode, since this HMI will go into the HPT.
    HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env' ModIface
iface


{-
Note [ModDetails and --make mode]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
An interface file consists of two parts

* The `ModIface` which ends up getting written to disk.
  The `ModIface` is a completely acyclic tree, which can be serialised
  and de-serialised completely straightforwardly.  The `ModIface` is
  also the structure that is finger-printed for recompilation control.

* The `ModDetails` which provides a more structured view that is suitable
  for usage during compilation.  The `ModDetails` is heavily cyclic:
  An `Id` contains a `Type`, which mentions a `TyCon` that contains kind
  that mentions other `TyCons`; the `Id` also includes an unfolding that
  in turn mentions more `Id`s;  And so on.

The `ModIface` can be created from the `ModDetails` and the `ModDetails` from
a `ModIface`.

During tidying, just before interfaces are written to disk,
the ModDetails is calculated and then converted into a ModIface (see GHC.Iface.Make.mkIface_).
Then when GHC needs to restart typechecking from a certain point it can read the
interface file, and regenerate the ModDetails from the ModIface (see GHC.IfaceToCore.typecheckIface).
The key part about the loading is that the ModDetails is regenerated lazily
from the ModIface, so that there's only a detailed in-memory representation
for declarations which are actually used from the interface. This mode is
also used when reading interface files from external packages.

In the old --make mode implementation, the interface was written after compiling a module
but the in-memory ModDetails which was used to compute the ModIface was retained.
The result was that --make mode used much more memory than `-c` mode, because a large amount of
information about a module would be kept in the ModDetails but never used.

The new idea is that even in `--make` mode, when there is an in-memory `ModDetails`
at hand, we re-create the `ModDetails` from the `ModIface`. Doing this means that
we only have to keep the `ModIface` decls in memory and then lazily load
detailed representations if needed. It turns out this makes a really big difference
to memory usage, halving maximum memory used in some cases.

See !5492 and #13586
-}

-- Runs the post-typechecking frontend (desugar and simplify). We want to
-- generate most of the interface as late as possible. This gets us up-to-date
-- and good unfoldings and other info in the interface file.
--
-- We might create a interface right away, in which case we also return the
-- updated HomeModInfo. But we might also need to run the backend first. In the
-- later case Status will be HscRecomp and we return a function from ModIface ->
-- HomeModInfo.
--
-- HscRecomp in turn will carry the information required to compute a interface
-- when passed the result of the code generator. So all this can and is done at
-- the call site of the backend code gen if it is run.
hscDesugarAndSimplify :: ModSummary
       -> FrontendResult
       -> Messages GhcMessage
       -> Maybe Fingerprint
       -> Hsc HscBackendAction
hscDesugarAndSimplify :: ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> Hsc HscBackendAction
hscDesugarAndSimplify ModSummary
summary (FrontendTypecheck TcGblEnv
tc_result) Messages GhcMessage
tc_warnings Maybe Fingerprint
mb_old_hash = do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
  Logger
logger <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
  let bcknd :: Backend
bcknd  = DynFlags -> Backend
backend DynFlags
dflags
      hsc_src :: HscSource
hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
summary
      diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags

  -- Desugar, if appropriate
  --
  -- We usually desugar even when we are not generating code, otherwise we
  -- would miss errors thrown by the desugaring (see #10600). The only
  -- exceptions are when the Module is Ghc.Prim or when it is not a
  -- HsSrcFile Module.
  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

  -- Report the warnings from both typechecking and desugar together
  Messages GhcMessage
w <- Hsc (Messages GhcMessage)
getDiagnostics
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DiagOpts -> Messages GhcMessage -> IO ()
printOrThrowDiagnostics Logger
logger DiagOpts
diag_opts (forall e. Messages e -> Messages e -> Messages e
unionMessages Messages GhcMessage
tc_warnings Messages GhcMessage
w)
  Hsc ()
clearDiagnostics

  -- Simplify, if appropriate, and (whether we simplified or not) generate an
  -- interface file.
  case Maybe ModGuts
mb_desugar of
      -- Just cause we desugared doesn't mean we are generating code, see above.
      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) <-
              forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy HscEnv
hsc_env ModGuts
simplified_guts

          let !partial_iface :: PartialModIface
partial_iface =
                {-# SCC "GHC.Driver.Main.mkPartialIface" #-}
                -- This `force` saves 2M residency in test T10370
                -- See Note [Avoiding space leaks in toIface*] for details.
                forall a. NFData a => a -> a
force (HscEnv -> ModDetails -> ModSummary -> ModGuts -> PartialModIface
mkPartialIface HscEnv
hsc_env ModDetails
details ModSummary
summary ModGuts
simplified_guts)

          forall (m :: * -> *) a. Monad m => a -> m a
return HscRecomp { hscs_guts :: CgGuts
hscs_guts = CgGuts
cg_guts,
                             hscs_mod_location :: ModLocation
hscs_mod_location = ModSummary -> ModLocation
ms_location ModSummary
summary,
                             hscs_partial_iface :: PartialModIface
hscs_partial_iface = PartialModIface
partial_iface,
                             hscs_old_iface_hash :: Maybe Fingerprint
hscs_old_iface_hash = Maybe Fingerprint
mb_old_hash
                           }

      -- We are not generating code, so we can skip simplification
      -- and generate a simple interface.
      Maybe ModGuts
_ -> do
        (ModIface
iface, ModDetails
_details) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
          HscEnv -> TcGblEnv -> ModSummary -> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result ModSummary
summary

        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> Bool
-> ModIface
-> Maybe Fingerprint
-> ModLocation
-> IO ()
hscMaybeWriteIface Logger
logger DynFlags
dflags Bool
True ModIface
iface Maybe Fingerprint
mb_old_hash (ModSummary -> ModLocation
ms_location ModSummary
summary)

        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ModIface -> HscBackendAction
HscUpdate ModIface
iface

{-
Note [Writing interface files]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
We write one interface file per module and per compilation, except with
-dynamic-too where we write two interface files (non-dynamic and dynamic).

We can write two kinds of interfaces (see Note [Interface file stages] in
"GHC.Driver.Types"):

   * simple interface: interface generated after the core pipeline

   * full interface: simple interface completed with information from the
     backend

Depending on the situation, we write one or the other (using
`hscMaybeWriteIface`). We must be careful with `-dynamic-too` because only the
backend is run twice, so if we write a simple interface we need to write both
the non-dynamic and the dynamic interfaces at the same time (with the same
contents).

Cases for which we generate simple interfaces:

   * GHC.Driver.Main.hscDesugarAndSimplify: when a compilation does NOT require (re)compilation
   of the hard code

   * GHC.Driver.Pipeline.compileOne': when we run in One Shot mode and target
   bytecode (if interface writing is forced).

   * GHC.Driver.Backpack uses simple interfaces for indefinite units
   (units with module holes). It writes them indirectly by forcing the
   -fwrite-interface flag while setting backend to NoBackend.

Cases for which we generate full interfaces:

   * GHC.Driver.Pipeline.runPhase: when we must be compiling to regular hard
   code and/or require recompilation.

By default interface file names are derived from module file names by adding
suffixes. The interface file name can be overloaded with "-ohi", except when
`-dynamic-too` is used.

-}

-- | Write interface files
hscMaybeWriteIface
  :: Logger
  -> DynFlags
  -> Bool
  -- ^ Is this a simple interface generated after the core pipeline, or one
  -- with information from the backend? See: Note [Writing interface files]
  -> ModIface
  -> Maybe Fingerprint
  -- ^ The old interface hash, used to decide if we need to actually write the
  -- new interface.
  -> 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

        write_iface :: DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags' ModIface
iface =
          let !iface_name :: [Char]
iface_name = if DynFlags -> Bool
dynamicNow DynFlags
dflags' then ModLocation -> [Char]
ml_dyn_hi_file ModLocation
mod_location else ModLocation -> [Char]
ml_hi_file ModLocation
mod_location
              profile :: Profile
profile     = DynFlags -> Profile
targetProfile DynFlags
dflags'
          in
          {-# SCC "writeIface" #-}
          forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
              ([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 -> Profile -> [Char] -> ModIface -> IO ()
writeIface Logger
logger Profile
profile [Char]
iface_name ModIface
iface)

    if (Bool
write_interface Bool -> Bool -> Bool
|| Bool
force_write_interface) then do

      -- FIXME: with -dynamic-too, "change" is only meaningful for the
      -- non-dynamic interface, not for the dynamic one. We should have another
      -- flag for the dynamic interface. In the meantime:
      --
      --    * when we write a single full interface, we check if we are
      --    currently writing the dynamic interface due to -dynamic-too, in
      --    which case we ignore "change".
      --
      --    * when we write two simple interfaces at once because of
      --    dynamic-too, we use "change" both for the non-dynamic and the
      --    dynamic interfaces. Hopefully both the dynamic and the non-dynamic
      --    interfaces stay in sync...
      --
      let change :: Bool
change = Maybe Fingerprint
old_iface forall a. Eq a => a -> a -> Bool
/= forall a. a -> Maybe a
Just (ModIfaceBackend -> Fingerprint
mi_iface_hash (forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))

      let dt :: DynamicTooState
dt = DynFlags -> DynamicTooState
dynamicTooState DynFlags
dflags

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_if_trace) forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger forall a b. (a -> b) -> a -> b
$
        SDoc -> Int -> SDoc -> SDoc
hang ([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
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 ()
when Bool
change forall a b. (a -> b) -> a -> b
$ do -- FIXME: see 'change' comment above
            DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
            case DynamicTooState
dt of
               DynamicTooState
DT_Dont   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
               DynamicTooState
DT_Dyn    -> forall a. [Char] -> a
panic [Char]
"Unexpected DT_Dyn state when writing simple interface"
               DynamicTooState
DT_OK     -> DynFlags -> ModIface -> IO ()
write_iface (DynFlags -> DynFlags
setDynamicNow DynFlags
dflags) ModIface
iface
         else case DynamicTooState
dt of
               DynamicTooState
DT_Dont | Bool
change                    -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
               DynamicTooState
DT_OK   | Bool
change                    -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
               -- FIXME: see change' comment above
               DynamicTooState
DT_Dyn                              -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
               DynamicTooState
_                                   -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ do
          -- This is slightly hacky. A hie file is considered to be up to date
          -- if its modification time on disk is greater than or equal to that
          -- of the .hi file (since we should always write a .hi file if we are
          -- writing a .hie file). However, with the way this code is
          -- structured at the moment, the .hie file is often written before
          -- the .hi file; by touching the file here, we ensure that it is
          -- correctly considered up-to-date.
          --
          -- The file should exist by the time we get here, but we check for
          -- existence just in case, so that we don't accidentally create empty
          -- .hie files.
          let hie_file :: [Char]
hie_file = ModLocation -> [Char]
ml_hie_file ModLocation
mod_location
          forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([Char] -> IO Bool
doesFileExist [Char]
hie_file) forall a b. (a -> b) -> a -> b
$
            Logger -> DynFlags -> [Char] -> [Char] -> IO ()
GHC.SysTools.touch Logger
logger DynFlags
dflags [Char]
"Touching hie file" [Char]
hie_file
    else
        -- See Note [Strictness in ModIface]
        ModIface -> IO ()
forceModIface ModIface
iface

--------------------------------------------------------------
-- NoRecomp handlers
--------------------------------------------------------------


-- | genModDetails is used to initialise 'ModDetails' at the end of compilation.
-- This has two main effects:
-- 1. Increases memory usage by unloading a lot of the TypeEnv
-- 2. Globalising certain parts (DFunIds) in the TypeEnv (which used to be achieved using UpdateIdInfos)
-- For the second part to work, it's critical that we use 'initIfaceLoadModule' here rather than
-- 'initIfaceCheck' as 'initIfaceLoadModule' removes the module from the KnotVars, otherwise name lookups
-- succeed by hitting the old TypeEnv, which missing out the critical globalisation step for DFuns.

-- After the DFunIds are globalised, it's critical to overwrite the old TypeEnv with the new
-- more compact and more correct version. This reduces memory usage whilst compiling the rest of
-- the module loop.
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails :: HscEnv -> ModIface -> IO ModDetails
genModDetails HscEnv
hsc_env ModIface
old_iface
  = do
    -- CRITICAL: To use initIfaceLoadModule as that removes the current module from the KnotVars and
    -- hence properly globalises DFunIds.
    ModDetails
new_details <- {-# SCC "tcRnIface" #-}
                  forall a. HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule HscEnv
hsc_env (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
old_iface) (ModIface -> IfG ModDetails
typecheckIface ModIface
old_iface)
    case forall a. KnotVars a -> Module -> Maybe a
lookupKnotVars (HscEnv -> KnotVars (IORef TypeEnv)
hsc_type_env_vars HscEnv
hsc_env) (forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
old_iface) of
      Maybe (IORef TypeEnv)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just IORef TypeEnv
te_var -> forall a. IORef a -> a -> IO ()
writeIORef IORef TypeEnv
te_var (ModDetails -> TypeEnv
md_types ModDetails
new_details)
    HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
    forall (m :: * -> *) a. Monad m => a -> m a
return ModDetails
new_details

--------------------------------------------------------------
-- Progress displayers.
--------------------------------------------------------------

oneShotMsg :: Logger -> RecompileRequired -> IO ()
oneShotMsg :: Logger -> RecompileRequired -> IO ()
oneShotMsg Logger
logger RecompileRequired
recomp =
    case RecompileRequired
recomp of
        RecompileRequired
UpToDate -> Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
text [Char]
"compilation IS NOT required"
        NeedsRecompile CompileReason
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

batchMsg :: Messager
batchMsg :: Messager
batchMsg = (HscEnv
 -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith (\HscEnv
_ (Int, Int)
_ RecompileRequired
_ ModuleGraphNode
_ -> SDoc
empty)
batchMultiMsg :: Messager
batchMultiMsg :: Messager
batchMultiMsg = (HscEnv
 -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith (\HscEnv
_ (Int, Int)
_ RecompileRequired
_ ModuleGraphNode
node -> SDoc -> SDoc
brackets (forall a. Outputable a => a -> SDoc
ppr (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
node)))

batchMsgWith :: (HscEnv -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc) -> Messager
batchMsgWith :: (HscEnv
 -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc
extra HscEnv
hsc_env_start (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node =
      case RecompileRequired
recomp of
        RecompileRequired
UpToDate
          | Logger -> Int -> Bool
logVerbAtLeast Logger
logger Int
2 -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
text [Char]
"Skipping") SDoc
empty
          | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        NeedsRecompile CompileReason
reason0 -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
text [Char]
herald) forall a b. (a -> b) -> a -> b
$ case CompileReason
reason0 of
          CompileReason
MustCompile            -> SDoc
empty
          (RecompBecause RecompReason
reason) -> [Char] -> SDoc
text [Char]
" [" SDoc -> SDoc -> SDoc
<> UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (forall a. Outputable a => a -> SDoc
ppr RecompReason
reason) SDoc -> SDoc -> SDoc
<> [Char] -> SDoc
text [Char]
"]"
    where
        herald :: [Char]
herald = case ModuleGraphNode
node of
                    LinkNode {} -> [Char]
"Linking"
                    InstantiationNode {} -> [Char]
"Instantiating"
                    ModuleNode {} -> [Char]
"Compiling"
        hsc_env :: HscEnv
hsc_env = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
hscSetActiveUnitId (ModuleGraphNode -> UnitId
moduleGraphNodeUnitId ModuleGraphNode
node) HscEnv
hsc_env_start
        dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        state :: UnitState
state  = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
        showMsg :: SDoc -> SDoc -> IO ()
showMsg SDoc
msg SDoc
reason =
            Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger forall a b. (a -> b) -> a -> b
$
            ((Int, Int) -> SDoc
showModuleIndex (Int, Int)
mod_index 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
<> HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc
extra HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node
                SDoc -> SDoc -> SDoc
<> SDoc
reason

--------------------------------------------------------------
-- Safe Haskell
--------------------------------------------------------------

-- Note [Safe Haskell Trust Check]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Safe Haskell checks that an import is trusted according to the following
-- rules for an import of module M that resides in Package P:
--
--   * If M is recorded as Safe and all its trust dependencies are OK
--     then M is considered safe.
--   * If M is recorded as Trustworthy and P is considered trusted and
--     all M's trust dependencies are OK then M is considered safe.
--
-- By trust dependencies we mean that the check is transitive. So if
-- a module M that is Safe relies on a module N that is trustworthy,
-- importing module M will first check (according to the second case)
-- that N is trusted before checking M is trusted.
--
-- This is a minimal description, so please refer to the user guide
-- for more details. The user guide is also considered the authoritative
-- source in this matter, not the comments or code.


-- Note [Safe Haskell Inference]
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Safe Haskell does Safe inference on modules that don't have any specific
-- safe haskell mode flag. The basic approach to this is:
--   * When deciding if we need to do a Safe language check, treat
--     an unmarked module as having -XSafe mode specified.
--   * For checks, don't throw errors but return them to the caller.
--   * Caller checks if there are errors:
--     * For modules explicitly marked -XSafe, we throw the errors.
--     * For unmarked modules (inference mode), we drop the errors
--       and mark the module as being Unsafe.
--
-- It used to be that we only did safe inference on modules that had no Safe
-- Haskell flags, but now we perform safe inference on all modules as we want
-- to allow users to set the `-Wsafe`, `-Wunsafe` and
-- `-Wtrustworthy-safe` flags on Trustworthy and Unsafe modules so that a
-- user can ensure their assumptions are correct and see reasons for why a
-- module is safe or unsafe.
--
-- This is tricky as we must be careful when we should throw an error compared
-- to just warnings. For checking safe imports we manage it as two steps. First
-- we check any imports that are required to be safe, then we check all other
-- imports to see if we can infer them to be safe.


-- | Check that the safe imports of the module being compiled are valid.
-- If not we either issue a compilation error if the module is explicitly
-- using Safe Haskell, or mark the module as unsafe if we're in safe
-- inference mode.
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports :: TcGblEnv -> Hsc TcGblEnv
hscCheckSafeImports TcGblEnv
tcg_env = do
    DynFlags
dflags   <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    TcGblEnv
tcg_env' <- TcGblEnv -> Hsc TcGblEnv
checkSafeImports TcGblEnv
tcg_env
    DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkRULES DynFlags
dflags TcGblEnv
tcg_env'

  where
    checkRULES :: DynFlags -> TcGblEnv -> Hsc TcGblEnv
checkRULES DynFlags
dflags TcGblEnv
tcg_env' =
      let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
      in case DynFlags -> Bool
safeLanguageOn DynFlags
dflags of
          Bool
True -> do
              -- XSafe: we nuke user written RULES
              Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ DiagOpts
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DiagOpts
diag_opts (TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
              forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_rules :: [LRuleDecl GhcTc]
tcg_rules = [] }
          Bool
False
                -- SafeInferred: user defined RULES, so not safe
              | DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
              -> forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env' forall a b. (a -> b) -> a -> b
$ DiagOpts
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DiagOpts
diag_opts (TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')

                -- Trustworthy OR SafeInferred: with no RULES
              | Bool
otherwise
              -> forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env'

    warns :: DiagOpts
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> Messages DriverMessage
warns DiagOpts
diag_opts [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules = forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Bag a
listToBag forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules DiagOpts
diag_opts) [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
rules

    warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
    warnRules :: DiagOpts -> LRuleDecl GhcTc -> MsgEnvelope DriverMessage
warnRules DiagOpts
diag_opts (L SrcSpanAnnA
loc RuleDecl GhcTc
rule) =
        forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (forall a. SrcSpanAnn' a -> SrcSpan
locA SrcSpanAnnA
loc) forall a b. (a -> b) -> a -> b
$ RuleDecl GhcTc -> DriverMessage
DriverUserDefinedRuleIgnored RuleDecl GhcTc
rule

-- | Validate that safe imported modules are actually safe.  For modules in the
-- HomePackage (the package the module we are compiling in resides) this just
-- involves checking its trust type is 'Safe' or 'Trustworthy'. For modules
-- that reside in another package we also must check that the external package
-- is trusted. See the Note [Safe Haskell Trust Check] above for more
-- information.
--
-- The code for this is quite tricky as the whole algorithm is done in a few
-- distinct phases in different parts of the code base. See
-- 'GHC.Rename.Names.rnImportDecl' for where package trust dependencies for a
-- module are collected and unioned.  Specifically see the Note [Tracking Trust
-- Transitively] in "GHC.Rename.Names" and the Note [Trust Own Package] in
-- "GHC.Rename.Names".
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

        -- We want to use the warning state specifically for detecting if safe
        -- inference has failed, so store and clear any existing warnings.
        Messages GhcMessage
oldErrs <- Hsc (Messages GhcMessage)
getDiagnostics
        Hsc ()
clearDiagnostics

        -- Check safe imports are correct
        Set UnitId
safePkgs <- forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall a. (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe [(Module, SrcSpan, Bool)]
safeImps
        Messages GhcMessage
safeErrs <- Hsc (Messages GhcMessage)
getDiagnostics
        Hsc ()
clearDiagnostics

        -- Check non-safe imports are correct if inferring safety
        -- See the Note [Safe Haskell Inference]
        (Messages GhcMessage
infErrs, Set UnitId
infPkgs) <- case (DynFlags -> Bool
safeInferOn DynFlags
dflags) of
          Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall e. Messages e
emptyMessages, forall a. Set a
S.empty)
          Bool
True -> do Set UnitId
infPkgs <- forall a. Ord a => [a] -> Set a
S.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a b.
Applicative m =>
(a -> m (Maybe b)) -> [a] -> m [b]
mapMaybeM forall a. (Module, SrcSpan, a) -> Hsc (Maybe UnitId)
checkSafe [(Module, SrcSpan, Bool)]
regImps
                     Messages GhcMessage
infErrs <- Hsc (Messages GhcMessage)
getDiagnostics
                     Hsc ()
clearDiagnostics
                     forall (m :: * -> *) a. Monad m => a -> m a
return (Messages GhcMessage
infErrs, Set UnitId
infPkgs)

        -- restore old errors
        Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
oldErrs

        case (forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
safeErrs) of
          -- Failed safe check
          Bool
False -> forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors forall a b. (a -> b) -> a -> b
$ Messages GhcMessage
safeErrs

          -- Passed safe check
          Bool
True -> do
            let infPassed :: Bool
infPassed = forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
infErrs
            TcGblEnv
tcg_env' <- case (Bool -> Bool
not Bool
infPassed) of
              Bool
True  -> forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env Messages GhcMessage
infErrs
              Bool
False -> forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
packageTrustOn DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgReqs
            let newTrust :: ImportAvails
newTrust = DynFlags -> Set UnitId -> Set UnitId -> Bool -> ImportAvails
pkgTrustReqs DynFlags
dflags Set UnitId
safePkgs Set UnitId
infPkgs Bool
infPassed
            forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_imports :: ImportAvails
tcg_imports = ImportAvails
impInfo ImportAvails -> ImportAvails -> ImportAvails
`plusImportAvails` ImportAvails
newTrust }

  where
    impInfo :: ImportAvails
impInfo  = TcGblEnv -> ImportAvails
tcg_imports TcGblEnv
tcg_env     -- ImportAvails
    imports :: ImportedMods
imports  = ImportAvails -> ImportedMods
imp_mods ImportAvails
impInfo        -- ImportedMods
    imports1 :: [(Module, [ImportedBy])]
imports1 = forall a. ModuleEnv a -> [(Module, a)]
moduleEnvToList ImportedMods
imports -- (Module, [ImportedBy])
    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 -- (Module, [ImportedModsVal])
    pkgReqs :: Set UnitId
pkgReqs  = ImportAvails -> Set UnitId
imp_trust_pkgs ImportAvails
impInfo  -- [Unit]

    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)

    -- ImportedModsVal = (ModuleName, Bool, SrcSpan, IsSafeImport)
    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
    cond' :: ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal
cond' ImportedModsVal
v1 ImportedModsVal
v2
        | ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v1 forall a. Eq a => a -> a -> Bool
/= ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v2
        = forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
            forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
v1) forall a b. (a -> b) -> a -> b
$
            DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ ModuleName -> DriverMessage
DriverMixedSafetyImport (ImportedModsVal -> ModuleName
imv_name ImportedModsVal
v1)
        | Bool
otherwise
        = forall (m :: * -> *) a. Monad m => a -> m a
return ImportedModsVal
v1

    -- easier interface to work with
    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

    -- what pkg's to add to our trust requirements
    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 }

-- | Check that a module is safe to import.
--
-- We return True to indicate the import is safe and False otherwise
-- although in the False case an exception may be thrown first.
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe :: HscEnv -> Module -> SrcSpan -> IO Bool
hscCheckSafe HscEnv
hsc_env Module
m SrcSpan
l = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    Set UnitId
pkgs <- forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DynFlags -> Bool
packageTrustOn DynFlags
dflags) forall a b. (a -> b) -> a -> b
$ Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgs
    Messages GhcMessage
errs <- Hsc (Messages GhcMessage)
getDiagnostics
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
errs

-- | Return if a module is trusted and the pkgs it depends on to be trusted.
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe :: HscEnv -> Module -> SrcSpan -> IO (Bool, Set UnitId)
hscGetSafe HscEnv
hsc_env Module
m SrcSpan
l = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
    (Maybe UnitId
self, Set UnitId
pkgs) <- Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
    Bool
good         <- forall e. Messages e -> Bool
isEmptyMessages forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` Hsc (Messages GhcMessage)
getDiagnostics
    Hsc ()
clearDiagnostics -- don't want them printed...
    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')

-- | Is a module trusted? If not, throw or log errors depending on the type.
-- Return (regardless of trusted or not) if the trust type requires the modules
-- own package be trusted and a list of other packages required to be trusted
-- (these later ones haven't been checked) but the own package trust has been.
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)
             -- TODO: do we also have to check the trust of the instantiation?
             -- Not necessary if that is reflected in dependencies
             | Bool
otherwise   -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ GenUnit UnitId -> UnitId
toUnitId (forall unit. GenModule unit -> unit
moduleUnit Module
m), Set UnitId
pkgs)
  where
    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
    isModSafe :: HomeUnit -> Module -> SrcSpan -> Hsc (Bool, Set UnitId)
isModSafe HomeUnit
home_unit Module
m SrcSpan
l = do
        HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
        DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        Maybe ModIface
iface <- Module -> Hsc (Maybe ModIface)
lookup' Module
m
        let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
        case Maybe ModIface
iface of
            -- can't load iface to check trust!
            Maybe ModIface
Nothing -> forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
                         forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l forall a b. (a -> b) -> a -> b
$
                         DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverCannotLoadInterfaceFile Module
m

            -- got iface, check trust
            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'
                    -- check module is trusted
                    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]
                    -- check package is trusted
                    safeP :: Bool
safeP = DynFlags
-> UnitState
-> HomeUnit
-> SafeHaskellMode
-> Bool
-> Module
-> Bool
packageTrusted DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) HomeUnit
home_unit SafeHaskellMode
trust Bool
trust_own_pkg Module
m
                    -- pkg trust reqs
                    pkgRs :: Set UnitId
pkgRs = Dependencies -> Set UnitId
dep_trusted_pkgs forall a b. (a -> b) -> a -> b
$ forall (phase :: ModIfacePhase). ModIface_ phase -> Dependencies
mi_deps ModIface
iface'
                    -- warn if Safe module imports Safe-Inferred module.
                    warns :: Messages GhcMessage
warns = if WarningFlag -> DynFlags -> Bool
wopt WarningFlag
Opt_WarnInferredSafeImports DynFlags
dflags
                                Bool -> Bool -> Bool
&& DynFlags -> Bool
safeLanguageOn DynFlags
dflags
                                Bool -> Bool -> Bool
&& SafeHaskellMode
trust forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_SafeInferred
                                then DiagOpts -> Messages GhcMessage
inferredImportWarn DiagOpts
diag_opts
                                else forall e. Messages e
emptyMessages
                    -- General errors we throw but Safe errors we log
                    errs :: Messages GhcMessage
errs = case (Bool
safeM, Bool
safeP) of
                        (Bool
True, Bool
True ) -> forall e. Messages e
emptyMessages
                        (Bool
True, Bool
False) -> Messages GhcMessage
pkgTrustErr
                        (Bool
False, Bool
_   ) -> Messages GhcMessage
modTrustErr
                in do
                    Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
warns
                    Messages GhcMessage -> Hsc ()
logDiagnostics Messages GhcMessage
errs
                    forall (m :: * -> *) a. Monad m => a -> m a
return (SafeHaskellMode
trust forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy, Set UnitId
pkgRs)

                where
                    state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
                    inferredImportWarn :: DiagOpts -> Messages GhcMessage
inferredImportWarn DiagOpts
diag_opts = forall e. MsgEnvelope e -> Messages e
singleMessage
                        forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
diag_opts SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state)
                        forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverInferredSafeImport Module
m
                    pkgTrustErr :: Messages GhcMessage
pkgTrustErr = forall e. MsgEnvelope e -> Messages e
singleMessage
                      forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state)
                      forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ UnitState -> Module -> DriverMessage
DriverCannotImportFromUntrustedPackage UnitState
state Module
m
                    modTrustErr :: Messages GhcMessage
modTrustErr = forall e. MsgEnvelope e -> Messages e
singleMessage
                      forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
l (UnitState -> PrintUnqualified
pkgQual UnitState
state)
                      forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverCannotImportUnsafeModule Module
m

    -- Check the package a module resides in is trusted. Safe compiled
    -- modules are trusted without requiring that their package is trusted. For
    -- trustworthy modules, modules in the home package are trusted but
    -- otherwise we check the package trust flag.
    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 -- shouldn't hit these cases
            SafeHaskellMode
Sf_Ignore    -> Bool
False -- shouldn't hit these cases
            SafeHaskellMode
Sf_Unsafe    -> Bool
False -- prefer for completeness.
            SafeHaskellMode
_ | Bool -> Bool
not (DynFlags -> Bool
packageTrustOn DynFlags
dflags)     -> Bool
True
            SafeHaskellMode
Sf_Safe | Bool -> Bool
not Bool
trust_own_pkg         -> Bool
True
            SafeHaskellMode
Sf_SafeInferred | Bool -> Bool
not Bool
trust_own_pkg -> Bool
True
            SafeHaskellMode
_ | HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
mod      -> Bool
True
            SafeHaskellMode
_ -> forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitState -> GenUnit UnitId -> UnitInfo
unsafeLookupUnit UnitState
unit_state (forall unit. GenModule unit -> unit
moduleUnit Module
m)

    lookup' :: Module -> Hsc (Maybe ModIface)
    lookup' :: Module -> Hsc (Maybe ModIface)
lookup' Module
m = do
        HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
        ExternalPackageState
hsc_eps <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
        let pkgIfaceT :: PackageIfaceTable
pkgIfaceT = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
hsc_eps
            hug :: HomeUnitGraph
hug       = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
            iface :: Maybe ModIface
iface     = HomeUnitGraph -> PackageIfaceTable -> Module -> Maybe ModIface
lookupIfaceByModule HomeUnitGraph
hug PackageIfaceTable
pkgIfaceT Module
m
        -- the 'lookupIfaceByModule' method will always fail when calling from GHCi
        -- as the compiler hasn't filled in the various module tables
        -- so we need to call 'getModuleInterface' to load from disk
        case Maybe ModIface
iface of
            Just ModIface
_  -> forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
iface
            Maybe ModIface
Nothing -> forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> Module -> IO (Messages TcRnMessage, Maybe ModIface)
getModuleInterface HscEnv
hsc_env Module
m)


-- | Check the list of packages are trusted.
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust :: Set UnitId -> Hsc ()
checkPkgTrust Set UnitId
pkgs = do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    let errors :: Bag (MsgEnvelope GhcMessage)
errors = forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr UnitId
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
go forall a. Bag a
emptyBag Set UnitId
pkgs
        state :: UnitState
state  = HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env
        go :: UnitId
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
go UnitId
pkg Bag (MsgEnvelope GhcMessage)
acc
            | forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted forall a b. (a -> b) -> a -> b
$ HasDebugCallStack => UnitState -> UnitId -> UnitInfo
unsafeLookupUnitId UnitState
state UnitId
pkg
            = Bag (MsgEnvelope GhcMessage)
acc
            | Bool
otherwise
            = (forall a. a -> Bag a -> Bag a
`consBag` Bag (MsgEnvelope GhcMessage)
acc)
                     forall a b. (a -> b) -> a -> b
$ forall e.
Diagnostic e =>
SrcSpan -> PrintUnqualified -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
noSrcSpan (UnitState -> PrintUnqualified
pkgQual UnitState
state)
                     forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage
                     forall a b. (a -> b) -> a -> b
$ UnitState -> UnitId -> DriverMessage
DriverPackageNotTrusted UnitState
state UnitId
pkg
    if forall a. Bag a -> Bool
isEmptyBag Bag (MsgEnvelope GhcMessage)
errors
      then forall (m :: * -> *) a. Monad m => a -> m a
return ()
      else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors forall a b. (a -> b) -> a -> b
$ forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages Bag (MsgEnvelope GhcMessage)
errors

-- | Set module to unsafe and (potentially) wipe trust information.
--
-- Make sure to call this method to set a module to inferred unsafe, it should
-- be a central and single failure method. We only wipe the trust information
-- when we aren't in a specific Safe Haskell mode.
--
-- While we only use this for recording that a module was inferred unsafe, we
-- may call it on modules using Trustworthy or Unsafe flags so as to allow
-- warning flags for safety to function correctly. See Note [Safe Haskell
-- Inference].
markUnsafeInfer :: Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer :: forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env Messages e
whyUnsafe = do
    DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    let reason :: DiagnosticReason
reason = WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnsafe
    let diag_opts :: DiagOpts
diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WarningFlag -> DiagOpts -> Bool
diag_wopt WarningFlag
Opt_WarnUnsafe DiagOpts
diag_opts)
         (Messages GhcMessage -> Hsc ()
logDiagnostics forall a b. (a -> b) -> a -> b
$ forall e. MsgEnvelope e -> Messages e
singleMessage forall a b. (a -> b) -> a -> b
$
             forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (DynFlags -> SrcSpan
warnUnsafeOnLoc DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
             DriverMessage -> GhcMessage
GhcDriverMessage forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> DriverMessage
DriverUnknownMessage forall a b. (a -> b) -> a -> b
$
             DiagnosticReason -> [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainDiagnostic DiagnosticReason
reason [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
             DynFlags -> SDoc
whyUnsafe' DynFlags
dflags)

    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (TcGblEnv -> TcRef Bool
tcg_safe_infer TcGblEnv
tcg_env) Bool
False
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef (TcGblEnv -> TcRef (Messages TcRnMessage)
tcg_safe_infer_reasons TcGblEnv
tcg_env) forall e. Messages e
emptyMessages
    -- NOTE: Only wipe trust when not in an explicitly safe haskell mode. Other
    -- times inference may be on but we are in Trustworthy mode -- so we want
    -- to record safe-inference failed but not wipe the trust dependencies.
    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
$ forall e. Diagnostic e => Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages e
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     = [MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCOutput (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))
                = [MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCOutput (Name -> SrcSpan
nameSrcSpan forall a b. (a -> b) -> a -> b
$ forall a. NamedThing a => a -> Name
getName forall a b. (a -> b) -> a -> b
$ ClsInst -> Id
is_dfun ClsInst
ins) forall a b. (a -> b) -> a -> b
$
                      forall a. Outputable a => a -> SDoc
ppr (OverlapFlag -> OverlapMode
overlapMode forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
ins) SDoc -> SDoc -> SDoc
<+>
                      [Char] -> SDoc
text [Char]
"overlap mode isn't allowed in Safe Haskell"]
                | Bool
otherwise = []

-- | Figure out the final correct safe haskell mode
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

--------------------------------------------------------------
-- Simplifiers
--------------------------------------------------------------

-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin
-- module names added via TH (cf 'addCorePlugin').
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

-- | Run Core2Core simplifier. The list of String is a list of (Core) plugin
-- module names added via TH (cf 'addCorePlugin').
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 -- fast path
        then forall (m :: * -> *) a. Monad m => a -> m a
return HscEnv
hsc_env
        else forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO HscEnv
initializePlugins
                    forall a b. (a -> b) -> a -> b
$ (DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags (\DynFlags
dflags -> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> DynFlags -> DynFlags
addPluginModuleName DynFlags
dflags [[Char]]
plugins)
                      HscEnv
hsc_env
    {-# SCC "Core2Core" #-}
      forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO ModGuts
core2core HscEnv
hsc_env_with_plugins ModGuts
ds_result

--------------------------------------------------------------
-- Interface generators
--------------------------------------------------------------

-- | Generate a striped down interface file, e.g. for boot files or when ghci
-- generates interface files. See Note [simpleTidyPgm - mkBootModDetailsTc]
hscSimpleIface :: HscEnv
               -> TcGblEnv
               -> ModSummary
               -> IO (ModIface, ModDetails)
hscSimpleIface :: HscEnv -> TcGblEnv -> ModSummary -> IO (ModIface, ModDetails)
hscSimpleIface HscEnv
hsc_env TcGblEnv
tc_result ModSummary
summary
    = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ TcGblEnv -> ModSummary -> Hsc (ModIface, ModDetails)
hscSimpleIface' TcGblEnv
tc_result ModSummary
summary

hscSimpleIface' :: TcGblEnv
                -> ModSummary
                -> Hsc (ModIface, ModDetails)
hscSimpleIface' :: TcGblEnv -> ModSummary -> Hsc (ModIface, ModDetails)
hscSimpleIface' TcGblEnv
tc_result ModSummary
summary = do
    HscEnv
hsc_env   <- Hsc HscEnv
getHscEnv
    Logger
logger    <- forall (m :: * -> *). HasLogger m => m Logger
getLogger
    ModDetails
details   <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> TcGblEnv -> IO ModDetails
mkBootModDetailsTc Logger
logger TcGblEnv
tc_result
    SafeHaskellMode
safe_mode <- TcGblEnv -> Hsc SafeHaskellMode
hscGetSafeMode TcGblEnv
tc_result
    ModIface
new_iface
        <- {-# SCC "MkFinalIface" #-}
           forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$
               HscEnv
-> SafeHaskellMode
-> ModDetails
-> ModSummary
-> TcGblEnv
-> IO ModIface
mkIfaceTc HscEnv
hsc_env SafeHaskellMode
safe_mode ModDetails
details ModSummary
summary TcGblEnv
tc_result
    -- And the answer is ...
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env
    forall (m :: * -> *) a. Monad m => a -> m a
return (ModIface
new_iface, ModDetails
details)

--------------------------------------------------------------
-- BackEnd combinators
--------------------------------------------------------------

-- | Compile to hard-code.
hscGenHardCode :: HscEnv -> CgGuts -> ModLocation -> FilePath
               -> IO (FilePath, Maybe FilePath, [(ForeignSrcLang, FilePath)], Maybe StgCgInfos, Maybe CmmCgInfos )
                -- ^ @Just f@ <=> _stub.c is f
hscGenHardCode :: HscEnv
-> CgGuts
-> ModLocation
-> [Char]
-> IO
     ([Char], Maybe [Char], [(ForeignSrcLang, [Char])],
      Maybe StgCgInfos, Maybe CmmCgInfos)
hscGenHardCode HscEnv
hsc_env CgGuts
cgguts ModLocation
location [Char]
output_filename = do
        let CgGuts{ -- This is the last use of the ModGuts in a compilation.
                    -- From now on, we just use the bits we need.
                    cg_module :: CgGuts -> Module
cg_module   = Module
this_mod,
                    cg_binds :: CgGuts -> CoreProgram
cg_binds    = CoreProgram
core_binds,
                    cg_ccs :: CgGuts -> [CostCentre]
cg_ccs      = [CostCentre]
local_ccs,
                    cg_tycons :: CgGuts -> [TyCon]
cg_tycons   = [TyCon]
tycons,
                    cg_foreign :: CgGuts -> ForeignStubs
cg_foreign  = ForeignStubs
foreign_stubs0,
                    cg_foreign_files :: CgGuts -> [(ForeignSrcLang, [Char])]
cg_foreign_files = [(ForeignSrcLang, [Char])]
foreign_files,
                    cg_dep_pkgs :: CgGuts -> Set UnitId
cg_dep_pkgs = Set UnitId
dependencies,
                    cg_hpc_info :: CgGuts -> HpcInfo
cg_hpc_info = HpcInfo
hpc_info } = 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
            profile :: Profile
profile = DynFlags -> Profile
targetProfile DynFlags
dflags
            data_tycons :: [TyCon]
data_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons
            -- cg_tycons includes newtypes, for the benefit of External Core,
            -- but we don't generate any code for newtypes

        -------------------
        -- Insert late cost centres if enabled.
        -- If `-fprof-late-inline` is enabled we can skip this, as it will have added
        -- a superset of cost centres we would add here already.

        (CoreProgram
late_cc_binds, [CostCentre]
late_local_ccs) <-
              if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateCcs DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateInlineCcs DynFlags
dflags)
                  then  {-# SCC lateCC #-} do
                    (CoreProgram
binds,Set CostCentre
late_ccs) <- DynFlags
-> Logger
-> Module
-> CoreProgram
-> IO (CoreProgram, Set CostCentre)
addLateCostCentresPgm DynFlags
dflags Logger
logger Module
this_mod CoreProgram
core_binds
                    forall (m :: * -> *) a. Monad m => a -> m a
return ( CoreProgram
binds, (forall a. Set a -> [a]
S.toList Set CostCentre
late_ccs forall a. Monoid a => a -> a -> a
`mappend` [CostCentre]
local_ccs ))
                  else
                    forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram
core_binds, [CostCentre]
local_ccs)



        -------------------
        -- PREPARE FOR CODE GENERATION
        -- Do saturation and convert to A-normal form
        (CoreProgram
prepd_binds) <- {-# SCC "CorePrep" #-}
                       HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
location
                                   CoreProgram
late_cc_binds [TyCon]
data_tycons

        -----------------  Convert to STG ------------------
        ([CgStgTopBinding]
stg_binds, InfoTableProvMap
denv, ([CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks), StgCgInfos
stg_cg_infos)
            <- {-# SCC "CoreToStg" #-}
               forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
                   ([Char] -> SDoc
text [Char]
"CoreToStg"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
this_mod))
                   (\([CgStgTopBinding]
a, InfoTableProvMap
b, ([CostCentre]
c,[CostCentreStack]
d), StgCgInfos
tag_env) ->
                        [CgStgTopBinding]
a forall a b. [a] -> b -> b
`seqList`
                        InfoTableProvMap
b seq :: forall a b. a -> b -> b
`seq`
                        [CostCentre]
c forall a b. [a] -> b -> b
`seqList`
                        [CostCentreStack]
d forall a b. [a] -> b -> b
`seqList`
                        (forall elt key. (elt -> ()) -> UniqFM key elt -> ()
seqEltsUFM (TagSig -> ()
seqTagSig) StgCgInfos
tag_env))
                   (Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
     ([CgStgTopBinding], InfoTableProvMap,
      ([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg Logger
logger DynFlags
dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) Bool
False Module
this_mod ModLocation
location CoreProgram
prepd_binds)

        let cost_centre_info :: ([CostCentre], [CostCentreStack])
cost_centre_info =
              ([CostCentre]
late_local_ccs forall a. [a] -> [a] -> [a]
++ [CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks)
            platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
            prof_init :: CStub
prof_init
              | DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags = Platform -> Module -> ([CostCentre], [CostCentreStack]) -> CStub
profilingInitCode Platform
platform Module
this_mod ([CostCentre], [CostCentreStack])
cost_centre_info
              | Bool
otherwise = forall a. Monoid a => a
mempty

        ------------------  Code generation ------------------
        -- The back-end is streamed: each top-level function goes
        -- from Stg all the way to asm before dealing with the next
        -- top-level function, so showPass isn't very useful here.
        -- Hence we have one showPass for the whole backend, the
        -- next showPass after this will be "Assembler".
        forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
                   ([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] CmmCgInfos
cmms <- {-# SCC "StgToCmm" #-}
                            HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> IO
     (Stream
        IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos)
doCodeGen HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons
                                ([CostCentre], [CostCentreStack])
cost_centre_info
                                [CgStgTopBinding]
stg_binds HpcInfo
hpc_info

            ------------------  Code output -----------------------
            Stream
  IO
  [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
  CmmCgInfos
rawcmms0 <- {-# SCC "cmmToRawCmm" #-}
                        case Hooks
-> forall a.
   Maybe
     (DynFlags
      -> Maybe Module
      -> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
      -> IO
           (Stream
              IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a))
cmmToRawCmmHook Hooks
hooks of
                            Maybe
  (DynFlags
   -> Maybe Module
   -> Stream
        IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
   -> IO
        (Stream
           IO
           [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
           CmmCgInfos))
Nothing -> forall a.
Logger
-> Profile
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
-> IO
     (Stream
        IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a)
cmmToRawCmm Logger
logger Profile
profile Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
cmms
                            Just DynFlags
-> Maybe Module
-> Stream
     IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
-> IO
     (Stream
        IO
        [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
        CmmCgInfos)
h  -> DynFlags
-> Maybe Module
-> Stream
     IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
-> IO
     (Stream
        IO
        [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
        CmmCgInfos)
h DynFlags
dflags (forall a. a -> Maybe a
Just Module
this_mod) Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
cmms

            let dump :: [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
dump [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a = do
                  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a) forall a b. (a -> b) -> a -> b
$
                    Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm_raw [Char]
"Raw Cmm" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a)
                  forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a
                rawcmms1 :: Stream
  IO
  [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
  CmmCgInfos
rawcmms1 = forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
dump Stream
  IO
  [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
  CmmCgInfos
rawcmms0

            let foreign_stubs :: CmmCgInfos -> ForeignStubs
foreign_stubs CmmCgInfos
st = ForeignStubs
foreign_stubs0 ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
prof_init
                                                  ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CmmCgInfos -> CStub
cgIPEStub CmmCgInfos
st

            ([Char]
output_filename, (Bool
_stub_h_exists, Maybe [Char]
stub_c_exists), [(ForeignSrcLang, [Char])]
foreign_fps, CmmCgInfos
cmm_cg_infos)
                <- {-# SCC "codeOutput" #-}
                  forall a.
Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> [Char]
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, [Char])]
-> Set UnitId
-> Stream
     IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a
-> IO ([Char], (Bool, Maybe [Char]), [(ForeignSrcLang, [Char])], a)
codeOutput Logger
logger TmpFs
tmpfs DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
this_mod [Char]
output_filename ModLocation
location
                  CmmCgInfos -> ForeignStubs
foreign_stubs [(ForeignSrcLang, [Char])]
foreign_files Set UnitId
dependencies Stream
  IO
  [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
  CmmCgInfos
rawcmms1
            forall (m :: * -> *) a. Monad m => a -> m a
return  ( [Char]
output_filename, Maybe [Char]
stub_c_exists, [(ForeignSrcLang, [Char])]
foreign_fps
                    , forall a. a -> Maybe a
Just StgCgInfos
stg_cg_infos, forall a. a -> Maybe a
Just CmmCgInfos
cmm_cg_infos)


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{ -- This is the last use of the ModGuts in a compilation.
                -- From now on, we just use the bits we need.
               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
        -- cg_tycons includes newtypes, for the benefit of External Core,
        -- but we don't generate any code for newtypes

    -------------------
    -- PREPARE FOR CODE GENERATION
    -- Do saturation and convert to A-normal form
    CoreProgram
prepd_binds <- {-# SCC "CorePrep" #-}
                   HscEnv
-> Module
-> ModLocation
-> CoreProgram
-> [TyCon]
-> IO CoreProgram
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
location CoreProgram
core_binds [TyCon]
data_tycons

    -- The stg cg info only provides a runtime benfit, but is not requires so we just
    -- omit it here
    ([CgStgTopBinding]
stg_binds, InfoTableProvMap
_infotable_prov, ([CostCentre], [CostCentreStack])
_caf_ccs__caf_cc_stacks, StgCgInfos
_ignore_stg_cg_infos)
      <- {-# SCC "CoreToStg" #-}
          Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
     ([CgStgTopBinding], InfoTableProvMap,
      ([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg Logger
logger DynFlags
dflags (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env) Bool
True Module
this_mod ModLocation
location CoreProgram
prepd_binds
    -----------------  Generate byte code ------------------
    CompiledByteCode
comp_bc <- HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod [CgStgTopBinding]
stg_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks
    ------------------ Create f-x-dynamic C-side stuff -----
    (Bool
_istub_h_exists, Maybe [Char]
istub_c_exists)
        <- Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe [Char])
outputForeignStubs Logger
logger TmpFs
tmpfs DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
this_mod ModLocation
location ForeignStubs
foreign_stubs
    forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe [Char]
istub_c_exists, CompiledByteCode
comp_bc, [SptEntry]
spt_entries)

------------------------------

hscCompileCmmFile :: HscEnv -> FilePath -> FilePath -> FilePath -> IO (Maybe FilePath)
hscCompileCmmFile :: HscEnv -> [Char] -> [Char] -> [Char] -> IO (Maybe [Char])
hscCompileCmmFile HscEnv
hsc_env [Char]
original_filename [Char]
filename [Char]
output_filename = forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$ do
    let dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        logger :: Logger
logger   = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        hooks :: Hooks
hooks    = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
        tmpfs :: TmpFs
tmpfs    = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
        profile :: Profile
profile  = DynFlags -> Profile
targetProfile DynFlags
dflags
        home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
        platform :: Platform
platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
        do_info_table :: Bool
do_info_table = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags
        -- Make up a module name to give the NCG. We can't pass bottom here
        -- lest we reproduce #11784.
        mod_name :: ModuleName
mod_name = [Char] -> ModuleName
mkModuleName forall a b. (a -> b) -> a -> b
$ [Char]
"Cmm$" forall a. [a] -> [a] -> [a]
++ [Char]
original_filename
        cmm_mod :: Module
cmm_mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
    ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
cmm, [InfoProvEnt]
ipe_ents) <- forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe
               forall a b. (a -> b) -> a -> b
$ do
                  (Messages PsWarning
warns,Messages PsWarning
errs,Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt])
cmm) <- forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger ([Char] -> SDoc
text [Char]
"ParseCmm"SDoc -> SDoc -> SDoc
<+>SDoc -> SDoc
brackets ([Char] -> SDoc
text [Char]
filename)) (\(Messages PsWarning, Messages PsWarning,
 Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt]))
_ -> ())
                                       forall a b. (a -> b) -> a -> b
$ DynFlags
-> Module
-> HomeUnit
-> [Char]
-> IO
     (Messages PsWarning, Messages PsWarning,
      Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt]))
parseCmmFile DynFlags
dflags Module
cmm_mod HomeUnit
home_unit [Char]
filename
                  let msgs :: Messages PsWarning
msgs = Messages PsWarning
warns forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages PsWarning
errs
                  forall (m :: * -> *) a. Monad m => a -> m a
return (PsWarning -> GhcMessage
GhcPsMessage forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
msgs, Maybe ([GenCmmDecl CmmStatics CmmTopInfo CmmGraph], [InfoProvEnt])
cmm)
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
        Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm_verbose_by_proc [Char]
"Parsed Cmm" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
cmm)

        -- Compile decls in Cmm files one decl at a time, to avoid re-ordering
        -- them in SRT analysis.
        --
        -- Re-ordering here causes breakage when booting with C backend because
        -- in C we must declare before use, but SRT algorithm is free to
        -- re-order [A, B] (B refers to A) when A is not CAFFY and return [B, A]
        [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 -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm [Char]
"Output Cmm"
            DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
cmmgroup)

        Stream
  IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ()
rawCmms <- case Hooks
-> forall a.
   Maybe
     (DynFlags
      -> Maybe Module
      -> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
      -> IO
           (Stream
              IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a))
cmmToRawCmmHook Hooks
hooks of
          Maybe
  (DynFlags
   -> Maybe Module
   -> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] ()
   -> IO
        (Stream
           IO
           [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
           ()))
Nothing -> forall a.
Logger
-> Profile
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] a
-> IO
     (Stream
        IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a)
cmmToRawCmm Logger
logger Profile
profile (forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
cmmgroup)
          Just DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] ()
-> IO
     (Stream
        IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ())
h  -> DynFlags
-> Maybe Module
-> Stream IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] ()
-> IO
     (Stream
        IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ())
h           DynFlags
dflags forall a. Maybe a
Nothing (forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
cmmgroup)

        let foreign_stubs :: () -> ForeignStubs
foreign_stubs ()
_
              | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t a -> Bool
null [InfoProvEnt]
ipe_ents =
                  let ip_init :: CStub
ip_init = Bool -> Platform -> Module -> CStub
ipInitCode Bool
do_info_table Platform
platform Module
cmm_mod
                  in ForeignStubs
NoStubs ForeignStubs -> CStub -> ForeignStubs
`appendStubC` CStub
ip_init
              | Bool
otherwise     = ForeignStubs
NoStubs
        ([Char]
_output_filename, (Bool
_stub_h_exists, Maybe [Char]
stub_c_exists), [(ForeignSrcLang, [Char])]
_foreign_fps, ()
_caf_infos)
          <- forall a.
Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> [Char]
-> ModLocation
-> (a -> ForeignStubs)
-> [(ForeignSrcLang, [Char])]
-> Set UnitId
-> Stream
     IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] a
-> IO ([Char], (Bool, Maybe [Char]), [(ForeignSrcLang, [Char])], a)
codeOutput Logger
logger TmpFs
tmpfs DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
cmm_mod [Char]
output_filename ModLocation
no_loc () -> ForeignStubs
foreign_stubs [] forall a. Set a
S.empty
             Stream
  IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ()
rawCmms
        forall (m :: * -> *) a. Monad m => a -> m a
return Maybe [Char]
stub_c_exists
  where
    no_loc :: ModLocation
no_loc = ModLocation{ ml_hs_file :: Maybe [Char]
ml_hs_file  = forall a. a -> Maybe a
Just [Char]
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_dyn_obj_file :: [Char]
ml_dyn_obj_file = forall a. [Char] -> a
panic [Char]
"hscCompileCmmFile: no dyn obj file",
                          ml_dyn_hi_file :: [Char]
ml_dyn_hi_file  = forall a. [Char] -> a
panic [Char]
"hscCompileCmmFile: no dyn obj file",
                          ml_hie_file :: [Char]
ml_hie_file = forall a. [Char] -> a
panic [Char]
"hscCompileCmmFile: no hie file"}

-------------------- Stuff for new code gen ---------------------

{-
Note [Forcing of stg_binds]
~~~~~~~~~~~~~~~~~~~~~~~~~~~
The two last steps in the STG pipeline are:

* Sorting the bindings in dependency order.
* Annotating them with free variables.

We want to make sure we do not keep references to unannotated STG bindings
alive, nor references to bindings which have already been compiled to Cmm.

We explicitly force the bindings to avoid this.

This reduces residency towards the end of the CodeGen phase significantly
(5-10%).
-}

doCodeGen :: HscEnv -> Module -> InfoTableProvMap -> [TyCon]
          -> CollectedCCs
          -> [CgStgTopBinding] -- ^ Bindings come already annotated with fvs
          -> HpcInfo
          -> IO (Stream IO CmmGroupSRTs CmmCgInfos)
         -- Note we produce a 'Stream' of CmmGroups, so that the
         -- backend can be run incrementally.  Otherwise it generates all
         -- the C-- up front, which has a significant space cost.
doCodeGen :: HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> IO
     (Stream
        IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos)
doCodeGen HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons
              ([CostCentre], [CostCentreStack])
cost_centre_info [CgStgTopBinding]
stg_binds_w_fvs HpcInfo
hpc_info = do
    let dflags :: DynFlags
dflags     = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        logger :: Logger
logger     = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        hooks :: Hooks
hooks      = HscEnv -> Hooks
hsc_hooks  HscEnv
hsc_env
        tmpfs :: TmpFs
tmpfs      = HscEnv -> TmpFs
hsc_tmpfs  HscEnv
hsc_env
        platform :: Platform
platform   = DynFlags -> Platform
targetPlatform DynFlags
dflags
        stg_ppr_opts :: StgPprOpts
stg_ppr_opts = (DynFlags -> StgPprOpts
initStgPprOpts DynFlags
dflags)

    Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_stg_final [Char]
"Final STG:" DumpFormat
FormatSTG
        (forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings StgPprOpts
stg_ppr_opts [CgStgTopBinding]
stg_binds_w_fvs)

    let stg_to_cmm :: DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
     IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
stg_to_cmm DynFlags
dflags Module
mod = case Hooks
-> Maybe
     (StgToCmmConfig
      -> InfoTableProvMap
      -> [TyCon]
      -> ([CostCentre], [CostCentreStack])
      -> [CgStgTopBinding]
      -> HpcInfo
      -> Stream
           IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos)
stgToCmmHook Hooks
hooks of
                        Maybe
  (StgToCmmConfig
   -> InfoTableProvMap
   -> [TyCon]
   -> ([CostCentre], [CostCentreStack])
   -> [CgStgTopBinding]
   -> HpcInfo
   -> Stream
        IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos)
Nothing -> Logger
-> TmpFs
-> StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
     IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
StgToCmm.codeGen Logger
logger TmpFs
tmpfs (DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig DynFlags
dflags Module
mod)
                        Just StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
     IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
h  -> StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
     IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
h                             (DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig DynFlags
dflags Module
mod)

    let cmm_stream :: Stream IO CmmGroup ModuleLFInfos
        -- See Note [Forcing of stg_binds]
        cmm_stream :: Stream IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
cmm_stream = [CgStgTopBinding]
stg_binds_w_fvs forall a b. [a] -> b -> b
`seqList` {-# SCC "StgToCmm" #-}
            DynFlags
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> HpcInfo
-> Stream
     IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
stg_to_cmm DynFlags
dflags Module
this_mod InfoTableProvMap
denv [TyCon]
data_tycons ([CostCentre], [CostCentreStack])
cost_centre_info [CgStgTopBinding]
stg_binds_w_fvs HpcInfo
hpc_info

        -- codegen consumes a stream of CmmGroup, and produces a new
        -- stream of CmmGroup (not necessarily synchronised: one
        -- CmmGroup on input may produce many CmmGroups on output due
        -- to proc-point splitting).

    let dump1 :: [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
dump1 [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
a = do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
a) forall a b. (a -> b) -> a -> b
$
            Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm_from_stg
              [Char]
"Cmm produced by codegen" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
a)
          forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
a

        ppr_stream1 :: Stream IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
ppr_stream1 = forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph]
dump1 Stream IO [GenCmmDecl CmmStatics CmmTopInfo CmmGraph] ModuleLFInfos
cmm_stream

        pipeline_stream :: Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
        pipeline_stream :: Stream
  IO
  [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
  (NonCaffySet, ModuleLFInfos)
pipeline_stream = do
          (NonCaffySet
non_cafs,  ModuleLFInfos
lf_infos) <-
            {-# SCC "cmmPipeline" #-}
            forall (m :: * -> *) a b c r.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)
Stream.mapAccumL_ (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] ModuleLFInfos
ppr_stream1
              forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (SRTMap -> NonCaffySet
srtMapNonCAFs forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleSRTInfo -> SRTMap
moduleSRTMap)

          forall (m :: * -> *) a. Monad m => a -> m a
return (NonCaffySet
non_cafs, ModuleLFInfos
lf_infos)

        dump2 :: [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
dump2 [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a = do
          forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a) forall a b. (a -> b) -> a -> b
$
            Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_cmm [Char]
"Output Cmm" DumpFormat
FormatCMM (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a)
          forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
dump2 forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> InfoTableProvMap
-> Stream
     IO
     [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
     (NonCaffySet, ModuleLFInfos)
-> Stream
     IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
generateCgIPEStub HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv Stream
  IO
  [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
  (NonCaffySet, ModuleLFInfos)
pipeline_stream

myCoreToStgExpr :: Logger -> DynFlags -> InteractiveContext
                -> Bool
                -> Module -> ModLocation -> CoreExpr
                -> IO ( Id
                      , [CgStgTopBinding]
                      , InfoTableProvMap
                      , CollectedCCs
                      , StgCgInfos )
myCoreToStgExpr :: Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreExpr
-> IO
     (Id, [CgStgTopBinding], InfoTableProvMap,
      ([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStgExpr Logger
logger DynFlags
dflags InteractiveContext
ictxt Bool
for_bytecode Module
this_mod ModLocation
ml CoreExpr
prepd_expr = do
    {- Create a temporary binding (just because myCoreToStg needs a
       binding for the stg2stg step) -}
    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
                                (HasDebugCallStack => CoreExpr -> Mult
exprType CoreExpr
prepd_expr)
    ([CgStgTopBinding]
stg_binds, InfoTableProvMap
prov_map, ([CostCentre], [CostCentreStack])
collected_ccs, StgCgInfos
stg_cg_infos) <-
       Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
     ([CgStgTopBinding], InfoTableProvMap,
      ([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg Logger
logger
                   DynFlags
dflags
                   InteractiveContext
ictxt
                   Bool
for_bytecode
                   Module
this_mod
                   ModLocation
ml
                   [forall b. b -> Expr b -> Bind b
NonRec Id
bco_tmp_id CoreExpr
prepd_expr]
    forall (m :: * -> *) a. Monad m => a -> m a
return (Id
bco_tmp_id, [CgStgTopBinding]
stg_binds, InfoTableProvMap
prov_map, ([CostCentre], [CostCentreStack])
collected_ccs, StgCgInfos
stg_cg_infos)

myCoreToStg :: Logger -> DynFlags -> InteractiveContext
            -> Bool
            -> Module -> ModLocation -> CoreProgram
            -> IO ( [CgStgTopBinding] -- output program
                  , InfoTableProvMap
                  , CollectedCCs -- CAF cost centre info (declared and used)
                  , StgCgInfos )
myCoreToStg :: Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
     ([CgStgTopBinding], InfoTableProvMap,
      ([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg Logger
logger DynFlags
dflags InteractiveContext
ictxt Bool
for_bytecode Module
this_mod ModLocation
ml CoreProgram
prepd_binds = do
    let ([StgTopBinding]
stg_binds, InfoTableProvMap
denv, ([CostCentre], [CostCentreStack])
cost_centre_info)
         = {-# SCC "Core2Stg" #-}
           DynFlags
-> Module
-> ModLocation
-> CoreProgram
-> ([StgTopBinding], InfoTableProvMap,
    ([CostCentre], [CostCentreStack]))
coreToStg DynFlags
dflags Module
this_mod ModLocation
ml CoreProgram
prepd_binds

    ([CgStgTopBinding]
stg_binds_with_fvs,StgCgInfos
stg_cg_info)
        <- {-# SCC "Stg2Stg" #-}
           Logger
-> InteractiveContext
-> StgPipelineOpts
-> Module
-> [StgTopBinding]
-> IO ([CgStgTopBinding], StgCgInfos)
stg2stg Logger
logger InteractiveContext
ictxt (DynFlags -> Bool -> StgPipelineOpts
initStgPipelineOpts DynFlags
dflags Bool
for_bytecode)
                   Module
this_mod [StgTopBinding]
stg_binds

    Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_stg_cg [Char]
"CodeGenInput STG:" DumpFormat
FormatSTG
        (forall (pass :: StgPass).
OutputablePass pass =>
StgPprOpts -> [GenStgTopBinding pass] -> SDoc
pprGenStgTopBindings (DynFlags -> StgPprOpts
initStgPprOpts DynFlags
dflags) [CgStgTopBinding]
stg_binds_with_fvs)

    forall (m :: * -> *) a. Monad m => a -> m a
return ([CgStgTopBinding]
stg_binds_with_fvs, InfoTableProvMap
denv, ([CostCentre], [CostCentreStack])
cost_centre_info, StgCgInfos
stg_cg_info)

{- **********************************************************************
%*                                                                      *
\subsection{Compiling a do-statement}
%*                                                                      *
%********************************************************************* -}

{-
When the UnlinkedBCOExpr is linked you get an HValue of type *IO [HValue]* When
you run it you get a list of HValues that should be the same length as the list
of names; add them to the ClosureEnv.

A naked expression returns a singleton Name [it]. The stmt is lifted into the
IO monad as explained in Note [Interactively-bound Ids in GHCi] in GHC.Runtime.Context
-}

-- | Compile a stmt all the way to an HValue, but don't run it
--
-- We return Nothing to indicate an empty statement (or comment only), not a
-- parse error.
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

-- | Compile a stmt all the way to an HValue, but don't run it
--
-- We return Nothing to indicate an empty statement (or comment only), not a
-- parse error.
hscStmtWithLocation :: HscEnv
                    -> String -- ^ The statement
                    -> String -- ^ The source
                    -> Int    -- ^ Starting line
                    -> IO ( Maybe ([Id]
                          , ForeignHValue {- IO [HValue] -}
                          , 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  -- ^ The parsed statement
              -> IO ( Maybe ([Id]
                    , ForeignHValue {- IO [HValue] -}
                    , 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
  -- Rename and typecheck it
  ([Id]
ids, GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr, FixityEnv
fix_env) <- forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> GhciLStmt GhcPs
-> IO
     (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
tcRnStmt HscEnv
hsc_env GhciLStmt GhcPs
stmt

  -- Desugar it
  CoreExpr
ds_expr <- forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages DsMessage, a) -> m (Messages GhcMessage, a)
hoistDsMessage forall a b. (a -> b) -> a -> b
$ HscEnv -> LHsExpr GhcTc -> IO (Messages DsMessage, Maybe CoreExpr)
deSugarExpr HscEnv
hsc_env GenLocated SrcSpanAnnA (HsExpr GhcTc)
tc_expr
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (SDoc -> HscEnv -> CoreExpr -> IO ()
lintInteractiveExpr ([Char] -> SDoc
text [Char]
"desugar expression") HscEnv
hsc_env CoreExpr
ds_expr)
  Hsc ()
handleWarnings

  -- Then code-gen, and link it
  -- It's important NOT to have package 'interactive' as thisUnitId
  -- for linking, else we try to link 'main' and can't find it.
  -- Whereas the linker already knows to ignore 'interactive'
  let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
  (ForeignHValue
hval,[Linkable]
_,PkgsLoaded
_) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
src_span CoreExpr
ds_expr

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ([Id]
ids, ForeignHValue
hval, FixityEnv
fix_env)

-- | Compile a decls
hscDecls :: HscEnv
         -> String -- ^ The statement
         -> IO ([TyThing], InteractiveContext)
hscDecls :: HscEnv -> [Char] -> IO ([TyThing], InteractiveContext)
hscDecls HscEnv
hsc_env [Char]
str = HscEnv
-> [Char] -> [Char] -> Int -> IO ([TyThing], InteractiveContext)
hscDeclsWithLocation HscEnv
hsc_env [Char]
str [Char]
"<interactive>" Int
1

hscParseModuleWithLocation :: HscEnv -> String -> Int -> String -> IO HsModule
hscParseModuleWithLocation :: HscEnv -> [Char] -> Int -> [Char] -> IO HsModule
hscParseModuleWithLocation HscEnv
hsc_env [Char]
source Int
line_num [Char]
str = do
    L SrcSpan
_ HsModule
mod <-
      forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env forall a b. (a -> b) -> a -> b
$
        forall thing.
(Outputable thing, Data thing) =>
[Char] -> Int -> P thing -> [Char] -> Hsc thing
hscParseThingWithLocation [Char]
source Int
line_num P (Located HsModule)
parseModule [Char]
str
    forall (m :: * -> *) a. Monad m => a -> m a
return HsModule
mod

hscParseDeclsWithLocation :: HscEnv -> String -> Int -> String -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation :: HscEnv -> [Char] -> Int -> [Char] -> IO [LHsDecl GhcPs]
hscParseDeclsWithLocation HscEnv
hsc_env [Char]
source Int
line_num [Char]
str = do
  HsModule { hsmodDecls :: HsModule -> [LHsDecl GhcPs]
hsmodDecls = [LHsDecl GhcPs]
decls } <- HscEnv -> [Char] -> Int -> [Char] -> IO HsModule
hscParseModuleWithLocation HscEnv
hsc_env [Char]
source Int
line_num [Char]
str
  forall (m :: * -> *) a. Monad m => a -> m a
return [LHsDecl GhcPs]
decls

-- | Compile a decls
hscDeclsWithLocation :: HscEnv
                     -> String -- ^ The statement
                     -> String -- ^ The source
                     -> Int    -- ^ Starting line
                     -> 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

    {- Rename and typecheck it -}
    TcGblEnv
tc_gblenv <- forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> [LHsDecl GhcPs] -> IO (Messages TcRnMessage, Maybe TcGblEnv)
tcRnDeclsi HscEnv
hsc_env [LHsDecl GhcPs]
decls

    {- Grab the new instances -}
    -- We grab the whole environment because of the overlapping that may have
    -- been done. See the notes at the definition of InteractiveContext
    -- (ic_instances) for more details.
    let defaults :: Maybe [Mult]
defaults = TcGblEnv -> Maybe [Mult]
tcg_default TcGblEnv
tc_gblenv

    {- Desugar it -}
    -- We use a basically null location for iNTERACTIVE
    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_dyn_obj_file :: [Char]
ml_dyn_obj_file = forall a. [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_dyn_obj_file",
                                      ml_dyn_hi_file :: [Char]
ml_dyn_hi_file = forall a. [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_dyn_hi_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

    {- Simplify -}
    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

    {- Tidy -}
    (CgGuts
tidy_cg, ModDetails
mod_details) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy HscEnv
hsc_env ModGuts
simpl_mg

    let !CgGuts{ cg_module :: CgGuts -> Module
cg_module    = Module
this_mod,
                 cg_binds :: CgGuts -> CoreProgram
cg_binds     = CoreProgram
core_binds,
                 cg_tycons :: CgGuts -> [TyCon]
cg_tycons    = [TyCon]
tycons,
                 cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks = Maybe ModBreaks
mod_breaks } = CgGuts
tidy_cg

        !ModDetails { md_insts :: ModDetails -> InstEnv
md_insts     = InstEnv
cls_insts
                    , md_fam_insts :: ModDetails -> [FamInst]
md_fam_insts = [FamInst]
fam_insts } = ModDetails
mod_details
            -- Get the *tidied* cls_insts and fam_insts

        data_tycons :: [TyCon]
data_tycons = forall a. (a -> Bool) -> [a] -> [a]
filter TyCon -> Bool
isDataTyCon [TyCon]
tycons

    {- Prepare For Code Generation -}
    -- Do saturation and convert to A-normal form
    CoreProgram
prepd_binds <- {-# 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
corePrepPgm HscEnv
hsc_env Module
this_mod ModLocation
iNTERACTIVELoc CoreProgram
core_binds [TyCon]
data_tycons

    ([CgStgTopBinding]
stg_binds, InfoTableProvMap
_infotable_prov, ([CostCentre], [CostCentreStack])
_caf_ccs__caf_cc_stacks, StgCgInfos
_stg_cg_info)
        <- {-# SCC "CoreToStg" #-}
           forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreProgram
-> IO
     ([CgStgTopBinding], InfoTableProvMap,
      ([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStg (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
                                (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                                (HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env)
                                Bool
True
                                Module
this_mod
                                ModLocation
iNTERACTIVELoc
                                CoreProgram
prepd_binds

    {- Generate byte code -}
    CompiledByteCode
cbc <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env Module
this_mod
                                [CgStgTopBinding]
stg_binds [TyCon]
data_tycons Maybe ModBreaks
mod_breaks

    let src_span :: SrcSpan
src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
    ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
_ <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Interp
-> HscEnv
-> SrcSpan
-> CompiledByteCode
-> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
loadDecls Interp
interp HscEnv
hsc_env SrcSpan
src_span CompiledByteCode
cbc

    {- Load static pointer table entries -}
    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) ]
            -- We only need to keep around the external bindings
            -- (as decided by GHC.Iface.Tidy), since those are the only ones
            -- that might later be looked up by name.  But we can exclude
            --    - DFunIds, which are in 'cls_insts' (see Note [ic_tythings] in GHC.Runtime.Context
            --    - Implicit Ids, which are implicit in tcs
            -- c.f. GHC.Tc.Module.runTcInteractive, which reconstructs the TypeEnv

        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
        -- See Note [Fixity declarations in GHCi]
        fix_env :: FixityEnv
fix_env      = TcGblEnv -> FixityEnv
tcg_fix_env TcGblEnv
tc_gblenv
        new_ictxt :: InteractiveContext
new_ictxt    = InteractiveContext
-> [TyThing]
-> InstEnv
-> [FamInst]
-> Maybe [Mult]
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings InstEnv
cls_insts
                                                [FamInst]
fam_insts Maybe [Mult]
defaults FixityEnv
fix_env
    forall (m :: * -> *) a. Monad m => a -> m a
return ([TyThing]
new_tythings, InteractiveContext
new_ictxt)

-- | Load the given static-pointer table entries into the interpreter.
-- See Note [Grand plan for static forms] in "GHC.Iface.Tidy.StaticPtrTable".
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
            -- These are only names from the current module
            (ForeignHValue
val, [Linkable]
_, PkgsLoaded
_) <- Interp
-> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
loadName Interp
interp HscEnv
hsc_env (Id -> Name
idName Id
i)
            Interp -> Fingerprint -> ForeignHValue -> IO ()
addSptEntry Interp
interp Fingerprint
fpr ForeignHValue
val
    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SptEntry -> IO ()
add_spt_entry [SptEntry]
entries

{-
  Note [Fixity declarations in GHCi]
  ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
  To support fixity declarations on types defined within GHCi (as requested
  in #10018) we record the fixity environment in InteractiveContext.
  When we want to evaluate something GHC.Tc.Module.runTcInteractive pulls out this
  fixity environment and uses it to initialize the global typechecker environment.
  After the typechecker has finished its business, an updated fixity environment
  (reflecting whatever fixity declarations were present in the statements we
  passed it) will be returned from hscParsedStmt. This is passed to
  updateFixityEnv, which will stuff it back into InteractiveContext, to be
  used in evaluating the next statement.

-}

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 GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
                 forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
                 PsWarning -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> PsWarning
PsUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
                     [Char] -> SDoc
text [Char]
"parse error in import declaration"

-- | Typecheck an expression (but don't run it)
hscTcExpr :: HscEnv
          -> TcRnExprMode
          -> String -- ^ The expression
          -> IO Type
hscTcExpr :: HscEnv -> TcRnExprMode -> [Char] -> IO Mult
hscTcExpr HscEnv
hsc_env0 TcRnExprMode
mode [Char]
expr = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
  HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
  GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr <- [Char] -> Hsc (LHsExpr GhcPs)
hscParseExpr [Char]
expr
  forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcRnExprMode
-> LHsExpr GhcPs
-> IO (Messages TcRnMessage, Maybe Mult)
tcRnExpr HscEnv
hsc_env TcRnExprMode
mode GenLocated SrcSpanAnnA (HsExpr GhcPs)
parsed_expr

-- | Find the kind of a type, after generalisation
hscKcType
  :: HscEnv
  -> Bool            -- ^ Normalise the type
  -> String          -- ^ The type as a string
  -> IO (Type, Kind) -- ^ Resulting type (possibly normalised) and kind
hscKcType :: HscEnv -> Bool -> [Char] -> IO (Mult, Mult)
hscKcType HscEnv
hsc_env0 Bool
normalise [Char]
str = forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 forall a b. (a -> b) -> a -> b
$ do
    HscEnv
hsc_env <- Hsc HscEnv
getHscEnv
    GenLocated SrcSpanAnnA (HsType GhcPs)
ty <- [Char] -> Hsc (LHsType GhcPs)
hscParseType [Char]
str
    forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage forall a b. (a -> b) -> a -> b
$ HscEnv
-> ZonkFlexi
-> Bool
-> LHsType GhcPs
-> IO (Messages TcRnMessage, Maybe (Mult, Mult))
tcRnType HscEnv
hsc_env ZonkFlexi
DefaultFlexi Bool
normalise GenLocated SrcSpanAnnA (HsType GhcPs)
ty

hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr :: [Char] -> Hsc (LHsExpr GhcPs)
hscParseExpr [Char]
expr = do
  Maybe
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt <- [Char] -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt [Char]
expr
  case Maybe
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
maybe_stmt of
    Just (L SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) -> forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
    Maybe
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
_ -> forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError forall a b. (a -> b) -> a -> b
$
           forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan forall a b. (a -> b) -> a -> b
$
           PsWarning -> GhcMessage
GhcPsMessage forall a b. (a -> b) -> a -> b
$ forall a. (Diagnostic a, Typeable a) => a -> PsWarning
PsUnknownMessage forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints forall a b. (a -> b) -> a -> b
$
             [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 -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
               ([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. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst)
            POk PState
pst thing
thing -> do
                (Messages PsWarning, Messages PsWarning) -> Hsc ()
logWarningsReportErrors (PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst)
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_parsed [Char]
"Parser"
                            DumpFormat
FormatHaskell (forall a. Outputable a => a -> SDoc
ppr thing
thing)
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_parsed_ast [Char]
"Parser AST"
                            DumpFormat
FormatHaskell (forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations thing
thing)
                forall (m :: * -> *) a. Monad m => a -> m a
return thing
thing

hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
hscTidy HscEnv
hsc_env ModGuts
guts = do
  let logger :: Logger
logger   = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
  let this_mod :: Module
this_mod = ModGuts -> Module
mg_module ModGuts
guts

  TidyOpts
opts <- HscEnv -> IO TidyOpts
initTidyOpts HscEnv
hsc_env
  (CgGuts
cgguts, ModDetails
details) <- forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
    ([Char] -> SDoc
text [Char]
"CoreTidy"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
$! {-# SCC "CoreTidy" #-} TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)
tidyProgram TidyOpts
opts ModGuts
guts

  -- post tidy pretty-printing and linting...
  let tidy_rules :: [CoreRule]
tidy_rules     = ModDetails -> [CoreRule]
md_rules ModDetails
details
  let all_tidy_binds :: CoreProgram
all_tidy_binds = CgGuts -> CoreProgram
cg_binds CgGuts
cgguts
  let print_unqual :: PrintUnqualified
print_unqual   = UnitEnv -> GlobalRdrEnv -> PrintUnqualified
mkPrintUnqualified (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts)

  HscEnv
-> PrintUnqualified
-> CoreToDo
-> CoreProgram
-> [CoreRule]
-> IO ()
endPassIO HscEnv
hsc_env PrintUnqualified
print_unqual CoreToDo
CoreTidy CoreProgram
all_tidy_binds [CoreRule]
tidy_rules

  -- If the endPass didn't print the rules, but ddump-rules is
  -- on, print now
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_simpl) forall a b. (a -> b) -> a -> b
$
    Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_rules
      (SDocContext -> SDoc -> [Char]
renderWithContext SDocContext
defaultSDocContext (forall a. Outputable a => a -> SDoc
ppr CoreToDo
CoreTidy SDoc -> SDoc -> SDoc
<+> [Char] -> SDoc
text [Char]
"rules"))
      DumpFormat
FormatText
      ([CoreRule] -> SDoc
pprRulesForUser [CoreRule]
tidy_rules)

  -- Print one-line size info
  let cs :: CoreStats
cs = CoreProgram -> CoreStats
coreBindsStats CoreProgram
all_tidy_binds
  Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_core_stats [Char]
"Core Stats"
    DumpFormat
FormatText
    ([Char] -> SDoc
text [Char]
"Tidy size (terms,types,coercions)"
     SDoc -> SDoc -> SDoc
<+> forall a. Outputable a => a -> SDoc
ppr (forall unit. GenModule unit -> ModuleName
moduleName Module
this_mod) SDoc -> SDoc -> SDoc
<> SDoc
colon
     SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (CoreStats -> Int
cs_tm CoreStats
cs)
     SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (CoreStats -> Int
cs_ty CoreStats
cs)
     SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int (CoreStats -> Int
cs_co CoreStats
cs))

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (CgGuts
cgguts, ModDetails
details)


{- **********************************************************************
%*                                                                      *
        Desugar, simplify, convert to bytecode, and link an expression
%*                                                                      *
%********************************************************************* -}

hscCompileCoreExpr :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr :: HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr HscEnv
hsc_env SrcSpan
loc CoreExpr
expr =
  case Hooks
-> Maybe
     (HscEnv
      -> SrcSpan
      -> CoreExpr
      -> IO (ForeignHValue, [Linkable], PkgsLoaded))
hscCompileCoreExprHook (HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env) of
      Maybe
  (HscEnv
   -> SrcSpan
   -> CoreExpr
   -> IO (ForeignHValue, [Linkable], PkgsLoaded))
Nothing -> HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
loc CoreExpr
expr
      Just HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
h  -> HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
h                   HscEnv
hsc_env SrcSpan
loc CoreExpr
expr

hscCompileCoreExpr' :: HscEnv -> SrcSpan -> CoreExpr -> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr' :: HscEnv
-> SrcSpan
-> CoreExpr
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
hscCompileCoreExpr' HscEnv
hsc_env SrcSpan
srcspan CoreExpr
ds_expr
    = do { {- Simplify it -}
           -- Question: should we call SimpleOpt.simpleOptExpr here instead?
           -- It is, well, simpler, and does less inlining etc.
           CoreExpr
simpl_expr <- HscEnv -> CoreExpr -> IO CoreExpr
simplifyExpr HscEnv
hsc_env CoreExpr
ds_expr

           {- Tidy it (temporary, until coreSat does cloning) -}
         ; let tidy_expr :: CoreExpr
tidy_expr = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
emptyTidyEnv CoreExpr
simpl_expr

           {- Prepare for codegen -}
         ; CoreExpr
prepd_expr <- HscEnv -> CoreExpr -> IO CoreExpr
corePrepExpr HscEnv
hsc_env CoreExpr
tidy_expr

           {- Lint if necessary -}
         ; 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_dyn_obj_file :: [Char]
ml_dyn_obj_file = forall a. [Char] -> a
panic [Char]
"hscCompileCoreExpr': ml_obj_file",
                                      ml_dyn_hi_file :: [Char]
ml_dyn_hi_file  = forall a. [Char] -> a
panic [Char]
"hscCompileCoreExpr': ml_dyn_hi_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, [CgStgTopBinding]
stg_expr, InfoTableProvMap
_, ([CostCentre], [CostCentreStack])
_, StgCgInfos
_stg_cg_info) <-
             Logger
-> DynFlags
-> InteractiveContext
-> Bool
-> Module
-> ModLocation
-> CoreExpr
-> IO
     (Id, [CgStgTopBinding], InfoTableProvMap,
      ([CostCentre], [CostCentreStack]), StgCgInfos)
myCoreToStgExpr (HscEnv -> Logger
hsc_logger HscEnv
hsc_env)
                             (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)
                             InteractiveContext
ictxt
                             Bool
True
                             (InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
                             ModLocation
iNTERACTIVELoc
                             CoreExpr
prepd_expr

           {- Convert to BCOs -}
         ; CompiledByteCode
bcos <- HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env
                     (InteractiveContext -> Module
icInteractiveModule InteractiveContext
ictxt)
                     [CgStgTopBinding]
stg_expr
                     [] forall a. Maybe a
Nothing

           {- load it -}
         ; ([(Name, ForeignHValue)]
fv_hvs, [Linkable]
mods_needed, PkgsLoaded
units_needed) <- Interp
-> HscEnv
-> SrcSpan
-> CompiledByteCode
-> IO ([(Name, ForeignHValue)], [Linkable], PkgsLoaded)
loadDecls (HscEnv -> Interp
hscInterp HscEnv
hsc_env) HscEnv
hsc_env SrcSpan
srcspan CompiledByteCode
bcos
           {- Get the HValue for the root -}
         ; forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. HasCallStack => [Char] -> Maybe a -> a
expectJust [Char]
"hscCompileCoreExpr'"
              forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup (Id -> Name
idName Id
binding_id) [(Name, ForeignHValue)]
fv_hvs, [Linkable]
mods_needed, PkgsLoaded
units_needed) }


{- **********************************************************************
%*                                                                      *
        Statistics on reading interfaces
%*                                                                      *
%********************************************************************* -}

dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env = do
  ExternalPackageState
eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
  let
    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    dump_rn_stats :: Bool
dump_rn_stats = Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_rn_stats
    dump_if_trace :: Bool
dump_if_trace = Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_if_trace
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
dump_if_trace Bool -> Bool -> Bool
|| Bool
dump_rn_stats) forall a b. (a -> b) -> a -> b
$
    Logger -> [Char] -> SDoc -> IO ()
logDumpMsg Logger
logger [Char]
"Interface statistics" (ExternalPackageState -> SDoc
ifaceStats ExternalPackageState
eps)


{- **********************************************************************
%*                                                                      *
        Progress Messages: Module i of n
%*                                                                      *
%********************************************************************* -}

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
    -- compute the length of x > 0 in base 10
    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
' ') -- TODO: use GHC.Utils.Ppr.RStr

writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode :: DynFlags -> Bool
writeInterfaceOnlyMode DynFlags
dflags =
 GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteInterface DynFlags
dflags Bool -> Bool -> Bool
&&
 Backend
NoBackend forall a. Eq a => a -> a -> Bool
== DynFlags -> Backend
backend DynFlags
dflags