{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}

{-# 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
    , initHscEnv

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

    , hscGenHardCode
    , hscInteractive
    , mkCgInteractiveGuts
    , CgInteractiveGuts
    , generateByteCode
    , generateFreshByteCode

    -- * Running passes separately
    , hscRecompStatus
    , hscParse
    , hscTypecheckRename
    , hscTypecheckRenameWithDiagnostics
    , 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
    , loadByteCode
    ) where

import GHC.Prelude

import GHC.Platform

import GHC.Driver.Plugins
import GHC.Driver.Session
import GHC.Driver.Backend
import GHC.Driver.Env
import GHC.Driver.Env.KnotVars
import GHC.Driver.Errors
import GHC.Driver.Errors.Types
import GHC.Driver.CodeOutput
import GHC.Driver.Config.Cmm.Parser (initCmmParserConfig)
import GHC.Driver.Config.Core.Opt.Simplify ( initSimplifyExprOpts )
import GHC.Driver.Config.Core.Lint ( endPassHscEnvIO )
import GHC.Driver.Config.Core.Lint.Interactive ( lintInteractiveExpr )
import GHC.Driver.Config.CoreToStg
import GHC.Driver.Config.CoreToStg.Prep
import GHC.Driver.Config.Logger   (initLogFlags)
import GHC.Driver.Config.Parser   (initParserOpts)
import GHC.Driver.Config.Stg.Ppr  (initStgPprOpts)
import GHC.Driver.Config.Stg.Pipeline (initStgPipelineOpts)
import GHC.Driver.Config.StgToCmm  (initStgToCmmConfig)
import GHC.Driver.Config.Cmm       (initCmmConfig)
import GHC.Driver.LlvmConfigCache  (initLlvmConfigCache)
import GHC.Driver.Config.StgToJS  (initStgToJSConfig)
import GHC.Driver.Config.Diagnostic
import GHC.Driver.Config.Tidy
import GHC.Driver.Hooks
import GHC.Driver.GenerateCgIPEStub (generateCgIPEStub, lookupEstimatedTicks)

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

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

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

import GHC.HsToCore

import GHC.StgToByteCode    ( byteCodeGen )
import GHC.StgToJS          ( stgToJS )
import GHC.StgToJS.Ids
import GHC.StgToJS.Types
import GHC.JS.Syntax

import GHC.IfaceToCore  ( typecheckIface, typecheckWholeCoreBindings )

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

import GHC.Core
import GHC.Core.Lint.Interactive ( interactiveInScope )
import GHC.Core.Tidy           ( tidyExpr )
import GHC.Core.Utils          ( exprType )
import GHC.Core.ConLike
import GHC.Core.Opt.Pipeline
import GHC.Core.Opt.Pipeline.Types      ( CoreToDo (..))
import GHC.Core.TyCon
import GHC.Core.InstEnv
import GHC.Core.FamInstEnv
import GHC.Core.Rules
import GHC.Core.Stats
import GHC.Core.LateCC
import GHC.Core.LateCC.Types


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.TcType
import GHC.Tc.Zonk.Env ( ZonkFlexi (DefaultFlexi) )

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

import GHC.Builtin.Utils
import GHC.Builtin.Names

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

import GHC.Cmm
import GHC.Cmm.Info.Build
import GHC.Cmm.Pipeline
import GHC.Cmm.Info
import GHC.Cmm.Parser
import GHC.Cmm.UniqueRenamer

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.Name.Env      ( mkNameEnv )
import GHC.Types.Var.Env       ( mkEmptyTidyEnv )
import GHC.Types.Var.Set
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.Unique.Supply (uniqFromTag)
import GHC.Types.Unique.Set

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

import qualified GHC.LanguageExtensions as LangExt

import GHC.Data.FastString
import GHC.Data.Bag
import GHC.Data.OsPath (unsafeEncodeUtf)
import GHC.Data.StringBuffer
import qualified GHC.Data.Stream as Stream
import GHC.Data.Maybe

import GHC.SysTools (initSysTools)
import GHC.SysTools.BaseDir (findTopDir)

import Data.Data hiding (Fixity, TyCon)
import Data.Functor ((<&>))
import Data.List ( nub, isPrefixOf, partition )
import qualified Data.List.NonEmpty as NE
import Control.Monad
import Data.IORef
import System.FilePath as FilePath
import System.Directory
import qualified Data.Map as M
import Data.Map (Map)
import qualified Data.Set as S
import Data.Set (Set)
import Control.DeepSeq (force)
import Data.List.NonEmpty (NonEmpty ((:|)))
import GHC.Unit.Module.WholeCoreBindings
import GHC.Types.TypeEnv
import System.IO
import {-# SOURCE #-} GHC.Driver.Pipeline
import Data.Time

import System.IO.Unsafe ( unsafeInterleaveIO )
import GHC.Iface.Env ( trace_if )
import GHC.Platform.Ways
import GHC.Stg.InferTags.TagSig (seqTagSig)
import GHC.StgToCmm.Utils (IPEStats)
import GHC.Types.Unique.FM
import GHC.Types.Unique.DFM
import GHC.Cmm.Config (CmmConfig)
import Data.Bifunctor

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

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

newHscEnvWithHUG :: FilePath -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG :: [Char] -> DynFlags -> UnitId -> HomeUnitGraph -> IO HscEnv
newHscEnvWithHUG [Char]
top_dir DynFlags
top_dynflags UnitId
cur_unit HomeUnitGraph
home_unit_graph = do
    nc_var  <- Char -> [Name] -> IO NameCache
initNameCache Char
'r' [Name]
knownKeyNames
    fc_var  <- initFinderCache
    logger  <- initLogger
    tmpfs   <- initTmpFs
    let dflags = HomeUnitEnv -> DynFlags
homeUnitEnv_dflags (HomeUnitEnv -> DynFlags) -> HomeUnitEnv -> DynFlags
forall a b. (a -> b) -> a -> b
$ UnitId -> HomeUnitGraph -> HomeUnitEnv
forall v. UnitId -> UnitEnvGraph v -> v
unitEnv_lookup UnitId
cur_unit HomeUnitGraph
home_unit_graph
    unit_env <- initUnitEnv cur_unit home_unit_graph (ghcNameVersion dflags) (targetPlatform dflags)
    llvm_config <- initLlvmConfigCache top_dir
    return HscEnv { hsc_dflags         = top_dynflags
                  , hsc_logger         = setLogFlags logger (initLogFlags top_dynflags)
                  , hsc_targets        = []
                  , hsc_mod_graph      = emptyMG
                  , hsc_IC             = emptyInteractiveContext dflags
                  , hsc_NC             = nc_var
                  , hsc_FC             = fc_var
                  , hsc_type_env_vars  = emptyKnotVars
                  , hsc_interp         = Nothing
                  , hsc_unit_env       = unit_env
                  , hsc_plugins        = emptyPlugins
                  , hsc_hooks          = emptyHooks
                  , hsc_tmpfs          = tmpfs
                  , hsc_llvm_config    = llvm_config
                  }

-- | Initialize HscEnv from an optional top_dir path
initHscEnv :: Maybe FilePath -> IO HscEnv
initHscEnv :: Maybe [Char] -> IO HscEnv
initHscEnv Maybe [Char]
mb_top_dir = do
  top_dir <- Maybe [Char] -> IO [Char]
findTopDir Maybe [Char]
mb_top_dir
  mySettings <- initSysTools top_dir
  dflags <- initDynFlags (defaultDynFlags mySettings)
  hsc_env <- newHscEnv top_dir dflags
  setUnsafeGlobalDynFlags dflags
   -- c.f. DynFlags.parseDynamicFlagsFull, which
   -- creates DynFlags and sets the UnsafeGlobalDynFlags
  return hsc_env

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

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

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

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

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

handleWarnings :: Hsc ()
handleWarnings :: Hsc ()
handleWarnings = do
    diag_opts <- DynFlags -> DiagOpts
initDiagOpts (DynFlags -> DiagOpts) -> Hsc DynFlags -> Hsc DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    print_config <- initPrintConfig <$> getDynFlags
    logger <- getLogger
    w <- getDiagnostics
    liftIO $ printOrThrowDiagnostics logger print_config diag_opts w
    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 (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Messages PsWarning
warnings)
    Bool -> Hsc () -> Hsc ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Messages PsWarning -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages PsWarning
errors) (Hsc () -> Hsc ()) -> Hsc () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> Hsc ()
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors (PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage)
-> Messages PsWarning -> Messages GhcMessage
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
    diag_opts <- DynFlags -> DiagOpts
initDiagOpts (DynFlags -> DiagOpts) -> Hsc DynFlags -> Hsc DiagOpts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    logDiagnostics (GhcPsMessage <$> warnings)
    logger <- getLogger
    let (wWarns, wErrs) = partitionMessages warnings
    liftIO $ printMessages logger NoDiagnosticOpts diag_opts wWarns
    throwErrors $ fmap GhcPsMessage $ errors `unionMessages` 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
    (msgs, mb_r) <- IO (Messages GhcMessage, Maybe a)
-> Hsc (Messages GhcMessage, Maybe a)
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO (Messages GhcMessage, Maybe a)
ioA
    let (warns, errs) = partitionMessages msgs
    logDiagnostics warns
    case mb_r of
        Maybe a
Nothing -> Messages GhcMessage -> Hsc a
forall (io :: * -> *) a. MonadIO io => Messages GhcMessage -> io a
throwErrors Messages GhcMessage
errs
        Just a
r  -> Bool -> (a -> Hsc a) -> a -> Hsc a
forall a. HasCallStack => Bool -> a -> a
assert (Messages GhcMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
errs ) a -> Hsc a
forall a. a -> Hsc a
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
    (msgs, mb_r) <- IO (Messages GhcMessage, Maybe a)
-> Hsc (Messages GhcMessage, Maybe a)
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages GhcMessage, Maybe a)
 -> Hsc (Messages GhcMessage, Maybe a))
-> IO (Messages GhcMessage, Maybe a)
-> Hsc (Messages GhcMessage, Maybe a)
forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe a)
ioA
    logDiagnostics (mkMessages $ getWarningMessages msgs)
    return mb_r

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

hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)
hscTcRnLookupRdrName :: HscEnv -> LocatedN RdrName -> IO (NonEmpty Name)
hscTcRnLookupRdrName HscEnv
hsc_env0 LocatedN RdrName
rdr_name
  = HscEnv -> Hsc (NonEmpty Name) -> IO (NonEmpty Name)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (NonEmpty Name) -> IO (NonEmpty Name))
-> Hsc (NonEmpty Name) -> IO (NonEmpty Name)
forall a b. (a -> b) -> a -> b
$
    do { hsc_env <- Hsc HscEnv
getHscEnv
       -- tcRnLookupRdrName can return empty list only together with TcRnUnknownMessage.
       -- Once errors has been dealt with in hoistTcRnMessage, we can enforce
       -- this invariant in types by converting to NonEmpty.
       ; ioMsgMaybe $ fmap (fmap (>>= NE.nonEmpty)) $ hoistTcRnMessage $
          tcRnLookupRdrName hsc_env rdr_name }

hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName :: HscEnv -> Name -> IO (Maybe TyThing)
hscTcRcLookupName HscEnv
hsc_env0 Name
name = HscEnv -> Hsc (Maybe TyThing) -> IO (Maybe TyThing)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe TyThing) -> IO (Maybe TyThing))
-> Hsc (Maybe TyThing) -> IO (Maybe TyThing)
forall a b. (a -> b) -> a -> b
$ do
  hsc_env <- Hsc HscEnv
getHscEnv
  ioMsgMaybe' $ hoistTcRnMessage $ tcRnLookupName hsc_env 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
  = HscEnv
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
 -> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc)))
-> Hsc (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
-> IO (Maybe (TyThing, Fixity, [ClsInst], [FamInst], SDoc))
forall a b. (a -> b) -> a -> b
$
    do { hsc_env <- Hsc HscEnv
getHscEnv
       ; ioMsgMaybe' $ hoistTcRnMessage $ tcRnGetInfo hsc_env name }

hscIsGHCiMonad :: HscEnv -> String -> IO Name
hscIsGHCiMonad :: HscEnv -> [Char] -> IO Name
hscIsGHCiMonad HscEnv
hsc_env [Char]
name
  = HscEnv -> Hsc Name -> IO Name
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc Name -> IO Name) -> Hsc Name -> IO Name
forall a b. (a -> b) -> a -> b
$ IO (Messages GhcMessage, Maybe Name) -> Hsc Name
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe Name) -> Hsc Name)
-> IO (Messages GhcMessage, Maybe Name) -> Hsc Name
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe Name)
-> IO (Messages GhcMessage, Maybe Name)
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe Name)
 -> IO (Messages GhcMessage, Maybe Name))
-> IO (Messages TcRnMessage, Maybe Name)
-> IO (Messages GhcMessage, Maybe Name)
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 = HscEnv -> Hsc ModIface -> IO ModIface
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc ModIface -> IO ModIface) -> Hsc ModIface -> IO ModIface
forall a b. (a -> b) -> a -> b
$ do
  hsc_env <- Hsc HscEnv
getHscEnv
  ioMsgMaybe $ hoistTcRnMessage $ getModuleInterface hsc_env 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 = HscEnv -> Hsc GlobalRdrEnv -> IO GlobalRdrEnv
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc GlobalRdrEnv -> IO GlobalRdrEnv)
-> Hsc GlobalRdrEnv -> IO GlobalRdrEnv
forall a b. (a -> b) -> a -> b
$ do
  hsc_env <- Hsc HscEnv
getHscEnv
  ioMsgMaybe $ hoistTcRnMessage $ tcRnImportDecls hsc_env 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 = HscEnv -> Hsc HsParsedModule -> IO HsParsedModule
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc HsParsedModule -> IO HsParsedModule)
-> Hsc HsParsedModule -> IO HsParsedModule
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 = HsParsedModule -> Hsc HsParsedModule
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
r
 | Bool
otherwise = do
    dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    logger <- getLogger
    {-# SCC "Parser" #-} withTiming logger
                (text "Parser"<+>brackets (ppr $ ms_mod mod_summary))
                (const ()) $ do
    let src_filename  = ModSummary -> [Char]
ms_hspp_file ModSummary
mod_summary
        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.
    buf <- case maybe_src_buf of
               Just StringBuffer
b  -> StringBuffer -> Hsc StringBuffer
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return StringBuffer
b
               Maybe StringBuffer
Nothing -> IO StringBuffer -> Hsc StringBuffer
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO StringBuffer -> Hsc StringBuffer)
-> IO StringBuffer -> Hsc StringBuffer
forall a b. (a -> b) -> a -> b
$ [Char] -> IO StringBuffer
hGetStringBuffer [Char]
src_filename

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

    let diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
    when (wopt Opt_WarnUnicodeBidirectionalFormatCharacters dflags) $ do
      case checkBidirectionFormatChars (PsLoc loc (BufPos 0)) buf of
        Maybe (NonEmpty (PsLoc, Char, [Char]))
Nothing -> () -> Hsc ()
forall a. a -> Hsc a
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 (PsSpan -> SrcSpan) -> PsSpan -> SrcSpan
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 (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$
               DiagOpts -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts SrcSpan
span (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
               PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage) -> PsWarning -> GhcMessage
forall a b. (a -> b) -> a -> b
$ NonEmpty (PsLoc, Char, [Char]) -> PsWarning
PsWarnBidirectionalFormatChars NonEmpty (PsLoc, Char, [Char])
chars

    let parseMod | HscSource
HsigFile HscSource -> HscSource -> Bool
forall a. Eq a => a -> a -> Bool
== ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
                 = P (Located (HsModule GhcPs))
parseSignature
                 | Bool
otherwise = P (Located (HsModule GhcPs))
parseModule

    case unP parseMod (initParserState (initParserOpts dflags) buf loc) of
        PFailed PState
pst ->
            (Messages PsWarning, Messages PsWarning) -> Hsc HsParsedModule
forall a. (Messages PsWarning, Messages PsWarning) -> Hsc a
handleWarningsThrowErrors (PState -> (Messages PsWarning, Messages PsWarning)
getPsMessages PState
pst)
        POk PState
pst Located (HsModule GhcPs)
rdr_module -> do
            IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
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 (Located (HsModule GhcPs) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Located (HsModule GhcPs)
rdr_module)
            IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
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 (BlankSrcSpan
-> BlankEpAnnotations -> Located (HsModule GhcPs) -> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan
                                                   BlankEpAnnotations
NoBlankEpAnnotations
                                                   Located (HsModule GhcPs)
rdr_module)
            IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
forall a b. (a -> b) -> a -> b
$ Logger -> DumpFlag -> [Char] -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_source_stats [Char]
"Source Statistics"
                        DumpFormat
FormatText (Bool -> Located (HsModule GhcPs) -> SDoc
ppSourceStats Bool
False Located (HsModule GhcPs)
rdr_module)

            -- 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 = [[Char]] -> [[Char]]
forall a. Eq a => [a] -> [a]
nub ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char]
tmp_dir [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf`))
                            ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
== [Char]
n_hspp))
                            ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> [Char]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map [Char] -> [Char]
FilePath.normalise
                            ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> ([Char] -> Bool) -> [Char] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> [Char] -> Bool
forall a. Eq a => [a] -> [a] -> Bool
isPrefixOf [Char]
"<")
                            ([[Char]] -> [[Char]]) -> [[Char]] -> [[Char]]
forall a b. (a -> b) -> a -> b
$ (FastString -> [Char]) -> [FastString] -> [[Char]]
forall a b. (a -> b) -> [a] -> [b]
map FastString -> [Char]
unpackFS
                            ([FastString] -> [[Char]]) -> [FastString] -> [[Char]]
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  -> ([Char] -> Bool) -> [[Char]] -> [[Char]]
forall a. (a -> Bool) -> [a] -> [a]
filter ([Char] -> [Char] -> Bool
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:
            srcs2 <- IO [[Char]] -> Hsc [[Char]]
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> Hsc [[Char]]) -> IO [[Char]] -> Hsc [[Char]]
forall a b. (a -> b) -> a -> b
$ ([Char] -> IO Bool) -> [[Char]] -> IO [[Char]]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [Char] -> IO Bool
doesFileExist [[Char]]
srcs1

            let res = HsParsedModule {
                      hpm_module :: Located (HsModule GhcPs)
hpm_module    = Located (HsModule GhcPs)
rdr_module,
                      hpm_src_files :: [[Char]]
hpm_src_files = [[Char]]
srcs2
                   }

            -- apply parse transformation of plugins
            let applyPluginAction Plugin
p [[Char]]
opts
                  = Plugin
-> [[Char]] -> ModSummary -> ParsedResult -> Hsc ParsedResult
parsedResultAction Plugin
p [[Char]]
opts ModSummary
mod_summary
            hsc_env <- getHscEnv
            (ParsedResult transformed (PsMessages warns errs)) <-
              withPlugins (hsc_plugins hsc_env) applyPluginAction
                (ParsedResult res (uncurry PsMessages $ getPsMessages pst))

            logDiagnostics (GhcPsMessage <$> warns)
            unless (isEmptyMessages errs) $ throwErrors (GhcPsMessage <$> errs)

            return transformed

checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, String))
checkBidirectionFormatChars :: PsLoc -> StringBuffer -> Maybe (NonEmpty (PsLoc, Char, [Char]))
checkBidirectionFormatChars PsLoc
start_loc StringBuffer
sb
  | StringBuffer -> Bool
containsBidirectionalFormatChar StringBuffer
sb = NonEmpty (PsLoc, Char, [Char])
-> Maybe (NonEmpty (PsLoc, Char, [Char]))
forall a. a -> Maybe a
Just (NonEmpty (PsLoc, Char, [Char])
 -> Maybe (NonEmpty (PsLoc, Char, [Char])))
-> NonEmpty (PsLoc, Char, [Char])
-> Maybe (NonEmpty (PsLoc, Char, [Char]))
forall a b. (a -> b) -> a -> b
$ PsLoc -> StringBuffer -> NonEmpty (PsLoc, Char, [Char])
go PsLoc
start_loc StringBuffer
sb
  | Bool
otherwise = Maybe (NonEmpty (PsLoc, Char, [Char]))
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 = [Char] -> NonEmpty (PsLoc, Char, [Char])
forall a. HasCallStack => [Char] -> a
panic [Char]
"checkBidirectionFormatChars: no char found"
      | Bool
otherwise = case StringBuffer -> (Char, StringBuffer)
nextChar StringBuffer
sb of
          (Char
chr, StringBuffer
sb)
            | Just [Char]
desc <- Char -> [(Char, [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
chr [(Char, [Char])]
bidirectionalFormatChars ->
                (PsLoc
loc, Char
chr, [Char]
desc) (PsLoc, Char, [Char])
-> [(PsLoc, Char, [Char])] -> NonEmpty (PsLoc, Char, [Char])
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 <- Char -> [(Char, [Char])] -> Maybe [Char]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Char
chr [(Char, [Char])]
bidirectionalFormatChars ->
                (PsLoc
loc, Char
chr, [Char]
desc) (PsLoc, Char, [Char])
-> [(PsLoc, Char, [Char])] -> [(PsLoc, Char, [Char])]
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

    dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    logger <- getLogger
    liftIO $ putDumpFileMaybe logger Opt_D_dump_rn_ast "Renamer"
                FormatHaskell (showAstData NoBlankSrcSpan NoBlankEpAnnotations rn_info)

    -- Create HIE files
    when (gopt Opt_WriteHie dflags) $ do
        -- I assume this fromJust is safe because `-fwrite-hie-file`
        -- enables the option which keeps the renamed source.
        hieFile <- mkHieFile mod_summary tc_result (fromJust rn_info)
        let out_file = ModLocation -> [Char]
ml_hie_file (ModLocation -> [Char]) -> ModLocation -> [Char]
forall a b. (a -> b) -> a -> b
$ ModSummary -> ModLocation
ms_location ModSummary
mod_summary
        liftIO $ writeHieFile out_file hieFile
        liftIO $ putDumpFileMaybe logger Opt_D_dump_hie "HIE AST" FormatHaskell (ppr $ hie_asts hieFile)

        -- Validate HIE files
        when (gopt Opt_ValidateHie dflags) $ do
            hs_env <- getHscEnv
            liftIO $ do
              -- Validate Scopes
              case validateScopes (hie_module hieFile) $ getAsts $ hie_asts hieFile of
                  [] -> Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Got valid scopes"
                  [SDoc]
xs -> do
                    Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Got invalid scopes"
                    (SDoc -> IO ()) -> [SDoc] -> IO ()
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
              file' <- readHieFile (hsc_NC hs_env) out_file
              case diffFile hieFile (hie_file_result file') of
                [] ->
                  Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Got no roundtrip errors"
                [SDoc]
xs -> do
                  Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Got roundtrip errors"
                  let logger' :: Logger
logger' = Logger -> (LogFlags -> LogFlags) -> Logger
updateLogFlags Logger
logger (DumpFlag -> LogFlags -> LogFlags
log_set_dopt DumpFlag
Opt_D_ppr_debug)
                  (SDoc -> IO ()) -> [SDoc] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Logger -> SDoc -> IO ()
putMsg Logger
logger') [SDoc]
xs
    return 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 =
    ((TcGblEnv,
  Maybe
    (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
     Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
     Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName))),
 Messages GhcMessage)
-> (TcGblEnv,
    Maybe
      (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
       Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
       Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName)))
forall a b. (a, b) -> a
fst (((TcGblEnv,
   Maybe
     (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
      Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
      Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName))),
  Messages GhcMessage)
 -> (TcGblEnv,
     Maybe
       (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
        Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
        Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName))))
-> IO
     ((TcGblEnv,
       Maybe
         (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
          Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
          Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName))),
      Messages GhcMessage)
-> IO
     (TcGblEnv,
      Maybe
        (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
         Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
         Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> HscEnv
-> ModSummary
-> HsParsedModule
-> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
hscTypecheckRenameWithDiagnostics HscEnv
hsc_env ModSummary
mod_summary HsParsedModule
rdr_module

-- | Rename and typecheck a module, additionally returning the renamed syntax
-- and the diagnostics produced.
hscTypecheckRenameWithDiagnostics :: HscEnv -> ModSummary -> HsParsedModule
                                  -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
hscTypecheckRenameWithDiagnostics :: HscEnv
-> ModSummary
-> HsParsedModule
-> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
hscTypecheckRenameWithDiagnostics HscEnv
hsc_env ModSummary
mod_summary HsParsedModule
rdr_module = HscEnv
-> Hsc (TcGblEnv, RenamedStuff)
-> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
forall a. HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' HscEnv
hsc_env (Hsc (TcGblEnv, RenamedStuff)
 -> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage))
-> Hsc (TcGblEnv, RenamedStuff)
-> IO ((TcGblEnv, RenamedStuff), Messages GhcMessage)
forall a b. (a -> b) -> a -> b
$
    Bool
-> ModSummary
-> Maybe HsParsedModule
-> Hsc (TcGblEnv, RenamedStuff)
hsc_typecheck Bool
True ModSummary
mod_summary (HsParsedModule -> Maybe HsParsedModule
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 = HscEnv
-> Hsc FrontendResult -> IO (FrontendResult, Messages GhcMessage)
forall a. HscEnv -> Hsc a -> IO (a, Messages GhcMessage)
runHsc' HscEnv
hsc_env (Hsc FrontendResult -> IO (FrontendResult, Messages GhcMessage))
-> Hsc FrontendResult -> IO (FrontendResult, Messages GhcMessage)
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 (TcGblEnv -> FrontendResult)
-> ((TcGblEnv,
     Maybe
       (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
        Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
        Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName)))
    -> TcGblEnv)
-> (TcGblEnv,
    Maybe
      (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
       Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
       Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName)))
-> FrontendResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TcGblEnv,
 Maybe
   (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
    Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
    Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName)))
-> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv,
  Maybe
    (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
     Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
     Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName)))
 -> FrontendResult)
-> Hsc
     (TcGblEnv,
      Maybe
        (HsGroup GhcRn, [GenLocated SrcSpanAnnA (ImportDecl GhcRn)],
         Maybe [(GenLocated SrcSpanAnnA (IE GhcRn), Avails)],
         Maybe (LHsDoc GhcRn), Maybe (GenLocated SrcSpanAnnA ModuleName)))
-> Hsc FrontendResult
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 Maybe HsParsedModule
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
    hsc_env <- Hsc HscEnv
getHscEnv
    let hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
mod_summary
        dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
        outer_mod = ModSummary -> Module
ms_mod ModSummary
mod_summary
        mod_name = Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName Module
outer_mod
        outer_mod' = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
        inner_mod = HomeUnit -> ModuleName -> Module
homeModuleNameInstantiation HomeUnit
home_unit ModuleName
mod_name
        src_filename  = ModSummary -> [Char]
ms_hspp_file ModSummary
mod_summary
        real_loc = RealSrcLoc -> RealSrcSpan
realSrcLocSpan (RealSrcLoc -> RealSrcSpan) -> RealSrcLoc -> RealSrcSpan
forall a b. (a -> b) -> a -> b
$ FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
mkFastString [Char]
src_filename) Int
1 Int
1
        keep_rn' = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags Bool -> Bool -> Bool
|| Bool
keep_rn
    massert (isHomeModule home_unit outer_mod)
    tc_result <- if hsc_src == HsigFile && not (isHoleModule inner_mod)
        then ioMsgMaybe $ hoistTcRnMessage $ tcRnInstantiateSignature hsc_env outer_mod' real_loc
        else
         do hpm <- case mb_rdr_module of
                    Just HsParsedModule
hpm -> HsParsedModule -> Hsc HsParsedModule
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return HsParsedModule
hpm
                    Maybe HsParsedModule
Nothing -> ModSummary -> Hsc HsParsedModule
hscParse' ModSummary
mod_summary
            tc_result0 <- tcRnModule' mod_summary keep_rn' hpm
            if hsc_src == HsigFile
                then do (iface, _) <- liftIO $ hscSimpleIface hsc_env Nothing tc_result0 mod_summary
                        ioMsgMaybe $ hoistTcRnMessage $
                            tcRnMergeSignatures hsc_env hpm tc_result0 iface
                else return tc_result0
    -- TODO are we extracting anything when we merely instantiate a signature?
    -- If not, try to move this into the "else" case above.
    rn_info <- extract_renamed_stuff mod_summary tc_result
    return (tc_result, 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
    hsc_env <- Hsc HscEnv
getHscEnv
    dflags  <- getDynFlags

    let diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
    -- -Wmissing-safe-haskell-mode
    when (not (safeHaskellModeEnabled dflags)
          && wopt Opt_WarnMissingSafeHaskellMode dflags) $
        logDiagnostics $ singleMessage $
        mkPlainMsgEnvelope diag_opts (getLoc (hpm_module mod)) $
        GhcDriverMessage $ DriverMissingSafeHaskellMode (ms_mod sum)

    tcg_res <- {-# SCC "Typecheck-Rename" #-}
               ioMsgMaybe $ hoistTcRnMessage $
                   tcRnModule hsc_env sum
                     save_rn_syntax mod

    -- See Note [Safe Haskell Overlapping Instances Implementation]
    -- although this is used for more than just that failure case.
    tcSafeOK <- liftIO $ readIORef (tcg_safe_infer tcg_res)
    whyUnsafe <- liftIO $ readIORef (tcg_safe_infer_reasons tcg_res)
    let allSafeOK = DynFlags -> Bool
safeInferred DynFlags
dflags Bool -> Bool -> Bool
&& Bool
tcSafeOK

    -- end of the safe haskell line, how to respond to user?
    if not (safeHaskellOn dflags)
         || (safeInferOn dflags && not allSafeOK)
      -- if safe Haskell off or safe infer failed, mark unsafe
      then markUnsafeInfer tcg_res whyUnsafe

      -- module (could be) safe, throw warning if needed
      else do
          tcg_res' <- hscCheckSafeImports tcg_res
          safe <- liftIO $ readIORef (tcg_safe_infer tcg_res')
          when safe $
            case wopt Opt_WarnSafe dflags of
              Bool
True
                | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Safe -> () -> Hsc ()
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                | Bool
otherwise -> (Messages GhcMessage -> Hsc ()
logDiagnostics (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$
                       DiagOpts -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (DynFlags -> SrcSpan
warnSafeOnLoc DynFlags
dflags) (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
                       DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverInferredSafeModule (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_res'))
              Bool
False | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
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 (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$
                       DiagOpts -> SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (DynFlags -> SrcSpan
trustworthyOnLoc DynFlags
dflags) (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
                       DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverMarkedTrustworthyButInferredSafe (TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_res'))
              Bool
False -> () -> Hsc ()
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          return 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 =
    HscEnv -> Hsc ModGuts -> IO ModGuts
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc ModGuts -> IO ModGuts) -> Hsc ModGuts -> IO ModGuts
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
    hsc_env <- Hsc HscEnv
getHscEnv
    ioMsgMaybe $ hoistDsMessage $
      {-# SCC "deSugar" #-}
      deSugar hsc_env mod_location 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
                -> HomeModLinkable
                -> (Int,Int)
                -> IO HscRecompStatus
hscRecompStatus :: Maybe Messager
-> HscEnv
-> ModSummary
-> Maybe ModIface
-> HomeModLinkable
-> (Int, Int)
-> IO HscRecompStatus
hscRecompStatus
    Maybe Messager
mHscMessage HscEnv
hsc_env ModSummary
mod_summary Maybe ModIface
mb_old_iface HomeModLinkable
old_linkable (Int, Int)
mod_index
  = do
    let
        msg :: RecompileRequired -> IO ()
msg RecompileRequired
what = case Maybe Messager
mHscMessage of
          Just Messager
hscMessage -> Messager
hscMessage HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
what ([NodeKey] -> ModSummary -> ModuleGraphNode
ModuleNode [] ModSummary
mod_summary)
          Maybe Messager
Nothing -> () -> IO ()
forall a. a -> IO a
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.
    recomp_if_result
          <- {-# SCC "checkOldIface" #-}
             IO (MaybeValidated ModIface) -> IO (MaybeValidated ModIface)
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (MaybeValidated ModIface) -> IO (MaybeValidated ModIface))
-> IO (MaybeValidated ModIface) -> IO (MaybeValidated ModIface)
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 recomp_if_result of
      OutOfDateItem CompileReason
reason Maybe ModIface
mb_checked_iface -> do
        RecompileRequired -> IO ()
msg (RecompileRequired -> IO ()) -> RecompileRequired -> IO ()
forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
reason
        HscRecompStatus -> IO HscRecompStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscRecompStatus -> IO HscRecompStatus)
-> HscRecompStatus -> IO HscRecompStatus
forall a b. (a -> b) -> a -> b
$ Maybe Fingerprint -> HscRecompStatus
HscRecompNeeded (Maybe Fingerprint -> HscRecompStatus)
-> Maybe Fingerprint -> HscRecompStatus
forall a b. (a -> b) -> a -> b
$ (ModIface -> Fingerprint) -> Maybe ModIface -> Maybe Fingerprint
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIfaceBackend -> Fingerprint)
-> (ModIface -> ModIfaceBackend) -> ModIface -> Fingerprint
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModIface -> IfaceBackendExts 'ModIfaceFinal
ModIface -> ModIfaceBackend
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts) Maybe ModIface
mb_checked_iface
      UpToDateItem ModIface
checked_iface -> do
        let lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
ms_hspp_opts ModSummary
mod_summary
        if | Bool -> Bool
not (Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend DynFlags
lcl_dflags)) -> do
               -- No need for a linkable, we're good to go
               RecompileRequired -> IO ()
msg RecompileRequired
UpToDate
               HscRecompStatus -> IO HscRecompStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscRecompStatus -> IO HscRecompStatus)
-> HscRecompStatus -> IO HscRecompStatus
forall a b. (a -> b) -> a -> b
$ ModIface -> HomeModLinkable -> HscRecompStatus
HscUpToDate ModIface
checked_iface HomeModLinkable
emptyHomeModInfoLinkable
           | Bool -> Bool
not (Backend -> Bool
backendGeneratesCodeForHsBoot (DynFlags -> Backend
backend DynFlags
lcl_dflags))
           , IsBootInterface
IsBoot <- ModSummary -> IsBootInterface
isBootSummary ModSummary
mod_summary -> do
               RecompileRequired -> IO ()
msg RecompileRequired
UpToDate
               HscRecompStatus -> IO HscRecompStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscRecompStatus -> IO HscRecompStatus)
-> HscRecompStatus -> IO HscRecompStatus
forall a b. (a -> b) -> a -> b
$ ModIface -> HomeModLinkable -> HscRecompStatus
HscUpToDate ModIface
checked_iface HomeModLinkable
emptyHomeModInfoLinkable

           -- Always recompile with the JS backend when TH is enabled until
           -- #23013 is fixed.
           | Arch
ArchJavaScript <- Platform -> Arch
platformArch (DynFlags -> Platform
targetPlatform DynFlags
lcl_dflags)
           , Extension -> DynFlags -> Bool
xopt Extension
LangExt.TemplateHaskell DynFlags
lcl_dflags
           -> do
              RecompileRequired -> IO ()
msg (RecompileRequired -> IO ()) -> RecompileRequired -> IO ()
forall a b. (a -> b) -> a -> b
$ RecompReason -> RecompileRequired
needsRecompileBecause RecompReason
THWithJS
              HscRecompStatus -> IO HscRecompStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscRecompStatus -> IO HscRecompStatus)
-> HscRecompStatus -> IO HscRecompStatus
forall a b. (a -> b) -> a -> b
$ Maybe Fingerprint -> HscRecompStatus
HscRecompNeeded (Maybe Fingerprint -> HscRecompStatus)
-> Maybe Fingerprint -> HscRecompStatus
forall a b. (a -> b) -> a -> b
$ Fingerprint -> Maybe Fingerprint
forall a. a -> Maybe a
Just (Fingerprint -> Maybe Fingerprint)
-> Fingerprint -> Maybe Fingerprint
forall a b. (a -> b) -> a -> b
$ ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIfaceBackend -> Fingerprint) -> ModIfaceBackend -> Fingerprint
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts (ModIface -> IfaceBackendExts 'ModIfaceFinal)
-> ModIface -> IfaceBackendExts 'ModIfaceFinal
forall a b. (a -> b) -> a -> b
$ ModIface
checked_iface

           | Bool
otherwise -> do
               -- Do need linkable
               -- 1. Just check whether we have bytecode/object linkables and then
               -- we will decide if we need them or not.
               bc_linkable <- ModIface
-> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
checkByteCode ModIface
checked_iface ModSummary
mod_summary (HomeModLinkable -> Maybe Linkable
homeMod_bytecode HomeModLinkable
old_linkable)
               obj_linkable <- liftIO $ checkObjects lcl_dflags (homeMod_object old_linkable) mod_summary
               trace_if (hsc_logger hsc_env) (vcat [text "BCO linkable", nest 2 (ppr bc_linkable), text "Object Linkable", ppr obj_linkable])

               let just_bc = Linkable -> HomeModLinkable
justBytecode (Linkable -> HomeModLinkable)
-> MaybeValidated Linkable -> MaybeValidated HomeModLinkable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeValidated Linkable
bc_linkable
                   just_o  = Linkable -> HomeModLinkable
justObjects  (Linkable -> HomeModLinkable)
-> MaybeValidated Linkable -> MaybeValidated HomeModLinkable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeValidated Linkable
obj_linkable
                   _maybe_both_os = case (MaybeValidated Linkable
bc_linkable, MaybeValidated Linkable
obj_linkable) of
                               (UpToDateItem Linkable
bc, UpToDateItem Linkable
o) -> HomeModLinkable -> MaybeValidated HomeModLinkable
forall a. a -> MaybeValidated a
UpToDateItem (Linkable -> Linkable -> HomeModLinkable
bytecodeAndObjects Linkable
bc Linkable
o)
                               -- If missing object code, just say we need to recompile because of object code.
                               (MaybeValidated Linkable
_, OutOfDateItem CompileReason
reason Maybe Linkable
_) -> CompileReason
-> Maybe HomeModLinkable -> MaybeValidated HomeModLinkable
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason Maybe HomeModLinkable
forall a. Maybe a
Nothing
                               -- If just missing byte code, just use the object code
                               -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll
                               -- end up using bytecode on recompilation
                               (MaybeValidated Linkable
_, UpToDateItem {} ) -> MaybeValidated HomeModLinkable
just_o

                   definitely_both_os = case (MaybeValidated Linkable
bc_linkable, MaybeValidated Linkable
obj_linkable) of
                               (UpToDateItem Linkable
bc, UpToDateItem Linkable
o) -> HomeModLinkable -> MaybeValidated HomeModLinkable
forall a. a -> MaybeValidated a
UpToDateItem (Linkable -> Linkable -> HomeModLinkable
bytecodeAndObjects Linkable
bc Linkable
o)
                               -- If missing object code, just say we need to recompile because of object code.
                               (MaybeValidated Linkable
_, OutOfDateItem CompileReason
reason Maybe Linkable
_) -> CompileReason
-> Maybe HomeModLinkable -> MaybeValidated HomeModLinkable
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason Maybe HomeModLinkable
forall a. Maybe a
Nothing
                               -- If just missing byte code, just use the object code
                               -- so you should use -fprefer-byte-code with -fwrite-if-simplified-core or you'll
                               -- end up using bytecode on recompilation
                               (OutOfDateItem CompileReason
reason Maybe Linkable
_,  MaybeValidated Linkable
_ ) -> CompileReason
-> Maybe HomeModLinkable -> MaybeValidated HomeModLinkable
forall a. CompileReason -> Maybe a -> MaybeValidated a
OutOfDateItem CompileReason
reason Maybe HomeModLinkable
forall a. Maybe a
Nothing

--               pprTraceM "recomp" (ppr just_bc <+> ppr just_o)
               -- 2. Decide which of the products we will need
               let recomp_linkable_result = case () of
                     ()
_ | Backend -> Bool
backendCanReuseLoadedCode (DynFlags -> Backend
backend DynFlags
lcl_dflags) ->
                           case MaybeValidated Linkable
bc_linkable of
                             -- If bytecode is available for Interactive then don't load object code
                             UpToDateItem Linkable
_ -> MaybeValidated HomeModLinkable
just_bc
                             MaybeValidated Linkable
_ -> case MaybeValidated Linkable
obj_linkable of
                                     -- If o is availabe, then just use that
                                     UpToDateItem Linkable
_ -> MaybeValidated HomeModLinkable
just_o
                                     MaybeValidated Linkable
_ -> RecompReason
-> Maybe HomeModLinkable -> MaybeValidated HomeModLinkable
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingBytecode Maybe HomeModLinkable
forall a. Maybe a
Nothing
                        -- Need object files for making object files
                        | Backend -> Bool
backendWritesFiles (DynFlags -> Backend
backend DynFlags
lcl_dflags) ->
                           if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ByteCodeAndObjectCode DynFlags
lcl_dflags
                             -- We say we are going to write both, so recompile unless we have both
                             then MaybeValidated HomeModLinkable
definitely_both_os
                             -- Only load the object file unless we are saying we need to produce both.
                             -- Unless we do this then you can end up using byte-code for a module you specify -fobject-code for.
                             else MaybeValidated HomeModLinkable
just_o
                        | Bool
otherwise -> [Char] -> SDoc -> MaybeValidated HomeModLinkable
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"hscRecompStatus" ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text ([Char] -> SDoc) -> [Char] -> SDoc
forall a b. (a -> b) -> a -> b
$ Backend -> [Char]
forall a. Show a => a -> [Char]
show (Backend -> [Char]) -> Backend -> [Char]
forall a b. (a -> b) -> a -> b
$ DynFlags -> Backend
backend DynFlags
lcl_dflags)
               case recomp_linkable_result of
                 UpToDateItem HomeModLinkable
linkable -> do
                   RecompileRequired -> IO ()
msg (RecompileRequired -> IO ()) -> RecompileRequired -> IO ()
forall a b. (a -> b) -> a -> b
$ RecompileRequired
UpToDate
                   HscRecompStatus -> IO HscRecompStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscRecompStatus -> IO HscRecompStatus)
-> HscRecompStatus -> IO HscRecompStatus
forall a b. (a -> b) -> a -> b
$ ModIface -> HomeModLinkable -> HscRecompStatus
HscUpToDate ModIface
checked_iface (HomeModLinkable -> HscRecompStatus)
-> HomeModLinkable -> HscRecompStatus
forall a b. (a -> b) -> a -> b
$ HomeModLinkable
linkable
                 OutOfDateItem CompileReason
reason Maybe HomeModLinkable
_ -> do
                   RecompileRequired -> IO ()
msg (RecompileRequired -> IO ()) -> RecompileRequired -> IO ()
forall a b. (a -> b) -> a -> b
$ CompileReason -> RecompileRequired
NeedsRecompile CompileReason
reason
                   HscRecompStatus -> IO HscRecompStatus
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (HscRecompStatus -> IO HscRecompStatus)
-> HscRecompStatus -> IO HscRecompStatus
forall a b. (a -> b) -> a -> b
$ Maybe Fingerprint -> HscRecompStatus
HscRecompNeeded (Maybe Fingerprint -> HscRecompStatus)
-> Maybe Fingerprint -> HscRecompStatus
forall a b. (a -> b) -> a -> b
$ Fingerprint -> Maybe Fingerprint
forall a. a -> Maybe a
Just (Fingerprint -> Maybe Fingerprint)
-> Fingerprint -> Maybe Fingerprint
forall a b. (a -> b) -> a -> b
$ ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIfaceBackend -> Fingerprint) -> ModIfaceBackend -> Fingerprint
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts (ModIface -> IfaceBackendExts 'ModIfaceFinal)
-> ModIface -> IfaceBackendExts 'ModIfaceFinal
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 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
(>=) (UTCTime -> UTCTime -> Bool)
-> Maybe UTCTime -> Maybe (UTCTime -> Bool)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb_dyn_obj_date Maybe (UTCTime -> Bool) -> Maybe UTCTime -> Maybe Bool
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
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
_ -> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated Linkable -> IO (MaybeValidated Linkable))
-> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe Linkable -> MaybeValidated Linkable
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingDynObjectFile Maybe Linkable
forall a. Maybe a
Nothing
      -- Not in dynamic-too mode
      else IO (MaybeValidated Linkable)
k

  IO (MaybeValidated Linkable) -> IO (MaybeValidated Linkable)
checkDynamicObj (IO (MaybeValidated Linkable) -> IO (MaybeValidated Linkable))
-> IO (MaybeValidated Linkable) -> IO (MaybeValidated Linkable)
forall a b. (a -> b) -> a -> b
$
    case (,) (UTCTime -> UTCTime -> (UTCTime, UTCTime))
-> Maybe UTCTime -> Maybe (UTCTime -> (UTCTime, UTCTime))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe UTCTime
mb_obj_date Maybe (UTCTime -> (UTCTime, UTCTime))
-> Maybe UTCTime -> Maybe (UTCTime, UTCTime)
forall a b. Maybe (a -> b) -> Maybe a -> Maybe b
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 UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
>= UTCTime
if_date ->
            case Maybe Linkable
mb_old_linkable of
              Just Linkable
old_linkable
                | Linkable -> Bool
linkableIsNativeCodeOnly Linkable
old_linkable, Linkable -> UTCTime
linkableTime Linkable
old_linkable UTCTime -> UTCTime -> Bool
forall a. Eq a => a -> a -> Bool
== UTCTime
obj_date
                -> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated Linkable -> IO (MaybeValidated Linkable))
-> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a b. (a -> b) -> a -> b
$ Linkable -> MaybeValidated Linkable
forall a. a -> MaybeValidated a
UpToDateItem Linkable
old_linkable
              Maybe Linkable
_ -> Linkable -> MaybeValidated Linkable
forall a. a -> MaybeValidated a
UpToDateItem (Linkable -> MaybeValidated Linkable)
-> IO Linkable -> IO (MaybeValidated Linkable)
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)
_ -> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated Linkable -> IO (MaybeValidated Linkable))
-> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe Linkable -> MaybeValidated Linkable
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingObjectFile Maybe Linkable
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 :: ModIface -> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
checkByteCode :: ModIface
-> ModSummary -> Maybe Linkable -> IO (MaybeValidated Linkable)
checkByteCode ModIface
iface ModSummary
mod_sum Maybe Linkable
mb_old_linkable =
  case Maybe Linkable
mb_old_linkable of
    Just Linkable
old_linkable
      | Bool -> Bool
not (Linkable -> Bool
linkableIsNativeCodeOnly Linkable
old_linkable)
      -> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated Linkable -> IO (MaybeValidated Linkable))
-> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a b. (a -> b) -> a -> b
$ (Linkable -> MaybeValidated Linkable
forall a. a -> MaybeValidated a
UpToDateItem Linkable
old_linkable)
    Maybe Linkable
_ -> ModIface -> ModSummary -> IO (MaybeValidated Linkable)
loadByteCode ModIface
iface ModSummary
mod_sum

loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
loadByteCode :: ModIface -> ModSummary -> IO (MaybeValidated Linkable)
loadByteCode ModIface
iface ModSummary
mod_sum = do
    let
      this_mod :: Module
this_mod   = ModSummary -> Module
ms_mod ModSummary
mod_sum
      if_date :: UTCTime
if_date    = Maybe UTCTime -> UTCTime
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe UTCTime -> UTCTime) -> Maybe UTCTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ ModSummary -> Maybe UTCTime
ms_iface_date ModSummary
mod_sum
    case ModIface -> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
forall (phase :: ModIfacePhase).
ModIface_ phase
-> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
mi_extra_decls ModIface
iface of
      Just [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
extra_decls -> do
          let fi :: WholeCoreBindings
fi = [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> Module -> ModLocation -> IfaceForeign -> WholeCoreBindings
WholeCoreBindings [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
extra_decls Module
this_mod (ModSummary -> ModLocation
ms_location ModSummary
mod_sum)
                   (ModIface -> IfaceForeign
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceForeign
mi_foreign ModIface
iface)
          MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Linkable -> MaybeValidated Linkable
forall a. a -> MaybeValidated a
UpToDateItem (UTCTime -> Module -> NonEmpty LinkablePart -> Linkable
Linkable UTCTime
if_date Module
this_mod (LinkablePart -> NonEmpty LinkablePart
forall a. a -> NonEmpty a
NE.singleton (WholeCoreBindings -> LinkablePart
CoreBindings WholeCoreBindings
fi))))
      Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
_ -> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeValidated Linkable -> IO (MaybeValidated Linkable))
-> MaybeValidated Linkable -> IO (MaybeValidated Linkable)
forall a b. (a -> b) -> a -> b
$ RecompReason -> Maybe Linkable -> MaybeValidated Linkable
forall a. RecompReason -> Maybe a -> MaybeValidated a
outOfDateItemBecause RecompReason
MissingBytecode Maybe Linkable
forall a. Maybe a
Nothing

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

add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> HscEnv
add_iface_to_hpt :: ModIface -> ModDetails -> HscEnv -> HscEnv
add_iface_to_hpt ModIface
iface ModDetails
details =
  (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
hscUpdateHPT ((HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv)
-> (HomePackageTable -> HomePackageTable) -> HscEnv -> HscEnv
forall a b. (a -> b) -> a -> b
$ \ HomePackageTable
hpt ->
    HomePackageTable -> ModuleName -> HomeModInfo -> HomePackageTable
addToHpt HomePackageTable
hpt (Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
iface))
    (ModIface -> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details HomeModLinkable
emptyHomeModInfoLinkable)

-- Knot tying!  See Note [Knot-tying typecheckIface]
-- See Note [ModDetails and --make mode]
initModDetails :: HscEnv -> ModIface -> IO ModDetails
initModDetails :: HscEnv -> ModIface -> IO ModDetails
initModDetails HscEnv
hsc_env ModIface
iface =
  (ModDetails -> IO ModDetails) -> IO ModDetails
forall a. (a -> IO a) -> IO a
fixIO ((ModDetails -> IO ModDetails) -> IO ModDetails)
-> (ModDetails -> IO ModDetails) -> IO ModDetails
forall a b. (a -> b) -> a -> b
$ \ModDetails
details' -> do
    let !hsc_env' :: HscEnv
hsc_env' = ModIface -> ModDetails -> HscEnv -> HscEnv
add_iface_to_hpt ModIface
iface ModDetails
details' 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

-- | Modify flags such that objects are compiled for the interpreter's way.
-- This is necessary when building foreign objects for Template Haskell, since
-- those are object code built outside of the pipeline, which means they aren't
-- subject to the mechanism in 'enableCodeGenWhen' that requests dynamic build
-- outputs for dependencies when the interpreter used for TH is dynamic but the
-- main outputs aren't.
-- Furthermore, the HPT only stores one set of objects with different names for
-- bytecode linking in 'HomeModLinkable', so the usual hack for switching
-- between ways in 'get_link_deps' doesn't work.
compile_for_interpreter :: HscEnv -> (HscEnv -> IO a) -> IO a
compile_for_interpreter :: forall a. HscEnv -> (HscEnv -> IO a) -> IO a
compile_for_interpreter HscEnv
hsc_env HscEnv -> IO a
use =
  HscEnv -> IO a
use ((DynFlags -> DynFlags) -> HscEnv -> HscEnv
hscUpdateFlags DynFlags -> DynFlags
update HscEnv
hsc_env)
  where
    update :: DynFlags -> DynFlags
update DynFlags
dflags = DynFlags
dflags {
      targetWays_ = adapt_way interpreterDynamic WayDyn $
                    adapt_way interpreterProfiled WayProf $
                    targetWays_ dflags
      }

    adapt_way :: (Interp -> Bool) -> Way -> Ways -> Ways
adapt_way Interp -> Bool
want = if Interp -> Bool
want (HscEnv -> Interp
hscInterp HscEnv
hsc_env) then Way -> Ways -> Ways
addWay else Way -> Ways -> Ways
removeWay

-- | Assemble 'WholeCoreBindings' if the interface contains Core bindings.
iface_core_bindings :: ModIface -> ModLocation -> Maybe WholeCoreBindings
iface_core_bindings :: ModIface -> ModLocation -> Maybe WholeCoreBindings
iface_core_bindings ModIface
iface ModLocation
wcb_mod_location =
  Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
mi_extra_decls Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> ([IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
    -> WholeCoreBindings)
-> Maybe WholeCoreBindings
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings ->
    WholeCoreBindings {
      [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
wcb_bindings,
      wcb_module :: Module
wcb_module = Module
mi_module,
      ModLocation
wcb_mod_location :: ModLocation
wcb_mod_location :: ModLocation
wcb_mod_location,
      wcb_foreign :: IfaceForeign
wcb_foreign = IfaceForeign
mi_foreign
    }
  where
    ModIface {Module
mi_module :: forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module :: Module
mi_module, Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
mi_extra_decls :: forall (phase :: ModIfacePhase).
ModIface_ phase
-> Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
mi_extra_decls :: Maybe [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
mi_extra_decls, IfaceForeign
mi_foreign :: forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceForeign
mi_foreign :: IfaceForeign
mi_foreign} = ModIface
iface

-- | Return an 'IO' that hydrates Core bindings and compiles them to bytecode if
-- the interface contains any, using the supplied type env for typechecking.
--
-- Unlike 'initWholeCoreBindings', this does not use lazy IO.
-- Instead, the 'IO' is only evaluated (in @get_link_deps@) when it is clear
-- that it will be used immediately (because we're linking TH with
-- @-fprefer-byte-code@ in oneshot mode), and the result is cached in
-- 'LoaderState'.
--
-- 'initWholeCoreBindings' needs the laziness because it is used to populate
-- 'HomeModInfo', which is done preemptively, in anticipation of downstream
-- modules using the bytecode for TH in make mode, which might never happen.
loadIfaceByteCode ::
  HscEnv ->
  ModIface ->
  ModLocation ->
  TypeEnv ->
  Maybe (IO Linkable)
loadIfaceByteCode :: HscEnv -> ModIface -> ModLocation -> TypeEnv -> Maybe (IO Linkable)
loadIfaceByteCode HscEnv
hsc_env ModIface
iface ModLocation
location TypeEnv
type_env =
  WholeCoreBindings -> IO Linkable
compile (WholeCoreBindings -> IO Linkable)
-> Maybe WholeCoreBindings -> Maybe (IO Linkable)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModIface -> ModLocation -> Maybe WholeCoreBindings
iface_core_bindings ModIface
iface ModLocation
location
  where
    compile :: WholeCoreBindings -> IO Linkable
compile WholeCoreBindings
decls = do
      (bcos, fos) <- HscEnv
-> TypeEnv -> WholeCoreBindings -> IO (CompiledByteCode, [[Char]])
compileWholeCoreBindings HscEnv
hsc_env TypeEnv
type_env WholeCoreBindings
decls
      linkable $ BCOs bcos :| [DotO fo ForeignObject | fo <- fos]

    linkable :: NonEmpty LinkablePart -> IO Linkable
linkable NonEmpty LinkablePart
parts = do
      if_time <- [Char] -> IO (Maybe UTCTime)
modificationTimeIfExists (ModLocation -> [Char]
ml_hi_file ModLocation
location)
      time <- maybe getCurrentTime pure if_time
      return $! Linkable time (mi_module iface) parts

-- | If the 'Linkable' contains Core bindings loaded from an interface, replace
-- them with a lazy IO thunk that compiles them to bytecode and foreign objects,
-- using the supplied environment for type checking.
--
-- The laziness is necessary because this value is stored purely in a
-- 'HomeModLinkable' in the home package table, rather than some dedicated
-- mutable state that would generate bytecode on demand, so we have to call this
-- function even when we don't know that we'll need the bytecode.
--
-- In addition, the laziness has to be hidden inside 'LazyBCOs' because
-- 'Linkable' is used too generally, so that looking at the constructor to
-- decide whether to discard it when linking native code would force the thunk
-- otherwise, incurring a significant performance penalty.
--
-- This is sound because generateByteCode just depends on things already loaded
-- in the interface file.
initWholeCoreBindings ::
  HscEnv ->
  ModIface ->
  ModDetails ->
  Linkable ->
  IO Linkable
initWholeCoreBindings :: HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
initWholeCoreBindings HscEnv
hsc_env ModIface
iface ModDetails
details (Linkable UTCTime
utc_time Module
this_mod NonEmpty LinkablePart
uls) =
  UTCTime -> Module -> NonEmpty LinkablePart -> Linkable
Linkable UTCTime
utc_time Module
this_mod (NonEmpty LinkablePart -> Linkable)
-> IO (NonEmpty LinkablePart) -> IO Linkable
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (LinkablePart -> IO LinkablePart)
-> NonEmpty LinkablePart -> IO (NonEmpty LinkablePart)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM LinkablePart -> IO LinkablePart
go NonEmpty LinkablePart
uls
  where
    go :: LinkablePart -> IO LinkablePart
go = \case
      CoreBindings WholeCoreBindings
wcb -> do
        ~(bco, fos) <- IO (CompiledByteCode, [[Char]]) -> IO (CompiledByteCode, [[Char]])
forall a. IO a -> IO a
unsafeInterleaveIO (IO (CompiledByteCode, [[Char]])
 -> IO (CompiledByteCode, [[Char]]))
-> IO (CompiledByteCode, [[Char]])
-> IO (CompiledByteCode, [[Char]])
forall a b. (a -> b) -> a -> b
$
                       HscEnv
-> TypeEnv -> WholeCoreBindings -> IO (CompiledByteCode, [[Char]])
compileWholeCoreBindings HscEnv
hsc_env' TypeEnv
type_env WholeCoreBindings
wcb
        pure (LazyBCOs bco fos)
      LinkablePart
l -> LinkablePart -> IO LinkablePart
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure LinkablePart
l

    hsc_env' :: HscEnv
hsc_env' = ModIface -> ModDetails -> HscEnv -> HscEnv
add_iface_to_hpt ModIface
iface ModDetails
details HscEnv
hsc_env
    type_env :: TypeEnv
type_env = ModDetails -> TypeEnv
md_types ModDetails
details

-- | Hydrate interface Core bindings and compile them to bytecode.
--
-- This consists of:
--
-- 1. Running a typechecking step to insert the global names that were removed
--    when the interface was written or were unavailable due to boot import
--    cycles, converting the bindings to 'CoreBind'.
--
-- 2. Restoring the foreign build inputs from their serialized format, resulting
--    in a set of foreign import stubs and source files added via
--    'qAddForeignFilePath'.
--
-- 3. Generating bytecode and foreign objects from the results of the previous
--    steps using the usual pipeline actions.
compileWholeCoreBindings ::
  HscEnv ->
  TypeEnv ->
  WholeCoreBindings ->
  IO (CompiledByteCode, [FilePath])
compileWholeCoreBindings :: HscEnv
-> TypeEnv -> WholeCoreBindings -> IO (CompiledByteCode, [[Char]])
compileWholeCoreBindings HscEnv
hsc_env TypeEnv
type_env WholeCoreBindings
wcb = do
  core_binds <- IO CoreProgram
typecheck
  (stubs, foreign_files) <- decode_foreign
  gen_bytecode core_binds stubs foreign_files
  where
    typecheck :: IO CoreProgram
typecheck = do
      types_var <- TypeEnv -> IO (IORef TypeEnv)
forall a. a -> IO (IORef a)
newIORef TypeEnv
type_env
      let
        tc_env = HscEnv
hsc_env {
          hsc_type_env_vars =
            knotVarsFromModuleEnv (mkModuleEnv [(wcb_module, types_var)])
        }
      initIfaceCheck (text "l") tc_env $
        typecheckWholeCoreBindings types_var wcb

    decode_foreign :: IO (ForeignStubs, [(ForeignSrcLang, [Char])])
decode_foreign =
      Logger
-> TmpFs
-> TempDir
-> IfaceForeign
-> IO (ForeignStubs, [(ForeignSrcLang, [Char])])
decodeIfaceForeign Logger
logger (HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env)
      (DynFlags -> TempDir
tmpDir (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)) IfaceForeign
wcb_foreign

    gen_bytecode :: CoreProgram
-> ForeignStubs
-> [(ForeignSrcLang, [Char])]
-> IO (CompiledByteCode, [[Char]])
gen_bytecode CoreProgram
core_binds ForeignStubs
stubs [(ForeignSrcLang, [Char])]
foreign_files = do
      let cgi_guts :: CgInteractiveGuts
cgi_guts = Module
-> CoreProgram
-> [TyCon]
-> ForeignStubs
-> [(ForeignSrcLang, [Char])]
-> Maybe ModBreaks
-> [SptEntry]
-> CgInteractiveGuts
CgInteractiveGuts Module
wcb_module CoreProgram
core_binds
                      (TypeEnv -> [TyCon]
typeEnvTyCons TypeEnv
type_env) ForeignStubs
stubs [(ForeignSrcLang, [Char])]
foreign_files
                      Maybe ModBreaks
forall a. Maybe a
Nothing []
      Logger -> SDoc -> IO ()
trace_if Logger
logger ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Generating ByteCode for" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
wcb_module)
      HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO (CompiledByteCode, [[Char]])
generateByteCode HscEnv
hsc_env CgInteractiveGuts
cgi_guts ModLocation
wcb_mod_location

    WholeCoreBindings {Module
wcb_module :: WholeCoreBindings -> Module
wcb_module :: Module
wcb_module, ModLocation
wcb_mod_location :: WholeCoreBindings -> ModLocation
wcb_mod_location :: ModLocation
wcb_mod_location, IfaceForeign
wcb_foreign :: WholeCoreBindings -> IfaceForeign
wcb_foreign :: IfaceForeign
wcb_foreign} = WholeCoreBindings
wcb

    logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env

{-
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
  hsc_env <- Hsc HscEnv
getHscEnv
  dflags <- getDynFlags
  logger <- getLogger
  let bcknd  = DynFlags -> Backend
backend DynFlags
dflags
      hsc_src = ModSummary -> HscSource
ms_hsc_src ModSummary
summary
      diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
      print_config = DynFlags -> DiagnosticOpts GhcMessage
initPrintConfig 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.
  mb_desugar <-
      if ms_mod summary /= gHC_PRIM && hsc_src == HsSrcFile
      then Just <$> hscDesugar' (ms_location summary) tc_result
      else pure Nothing

  -- Report the warnings from both typechecking and desugar together
  w <- getDiagnostics
  liftIO $ printOrThrowDiagnostics logger print_config diag_opts (unionMessages tc_warnings w)
  clearDiagnostics

  -- Simplify, if appropriate, and (whether we simplified or not) generate an
  -- interface file.
  case mb_desugar of
      -- Just cause we desugared doesn't mean we are generating code, see above.
      Just ModGuts
desugared_guts | Backend -> Bool
backendGeneratesCode Backend
bcknd -> do
          plugins <- IO [[Char]] -> Hsc [[Char]]
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> Hsc [[Char]]) -> IO [[Char]] -> Hsc [[Char]]
forall a b. (a -> b) -> a -> b
$ IORef [[Char]] -> IO [[Char]]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [[Char]]
tcg_th_coreplugins TcGblEnv
tc_result)
          simplified_guts <- hscSimplify' plugins desugared_guts

          (cg_guts, details) <-
              liftIO $ hscTidy hsc_env simplified_guts

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

          return HscRecomp { hscs_guts = cg_guts,
                             hscs_mod_location = ms_location summary,
                             hscs_partial_iface = partial_iface,
                             hscs_old_iface_hash = mb_old_hash
                           }

      Just ModGuts
desugared_guts | GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteIfSimplifiedCore DynFlags
dflags -> do
          -- If -fno-code is enabled (hence we fall through to this case)
          -- Running the simplifier once is necessary before doing byte code generation
          -- in order to inline data con wrappers but we honour whatever level of simplificication the
          -- user requested. See #22008 for some discussion.
          plugins <- IO [[Char]] -> Hsc [[Char]]
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [[Char]] -> Hsc [[Char]]) -> IO [[Char]] -> Hsc [[Char]]
forall a b. (a -> b) -> a -> b
$ IORef [[Char]] -> IO [[Char]]
forall a. IORef a -> IO a
readIORef (TcGblEnv -> IORef [[Char]]
tcg_th_coreplugins TcGblEnv
tc_result)
          simplified_guts <- hscSimplify' plugins desugared_guts
          (cg_guts, _) <-
              liftIO $ hscTidy hsc_env simplified_guts

          (iface, _details) <- liftIO $
            hscSimpleIface hsc_env (Just $ cg_binds cg_guts) tc_result summary

          liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)

          return $ HscUpdate iface


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

        liftIO $ hscMaybeWriteIface logger dflags True iface mb_old_hash (ms_location summary)

        return $ HscUpdate 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 = Backend -> Bool
backendWritesFiles (DynFlags -> Backend
backend DynFlags
dflags)

        write_iface :: DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags' ModIface
iface =
          let !iface_name :: [Char]
iface_name = if DynFlags -> Bool
dynamicNow DynFlags
dflags' then ModLocation -> [Char]
ml_dyn_hi_file ModLocation
mod_location else ModLocation -> [Char]
ml_hi_file ModLocation
mod_location
              profile :: Profile
profile     = DynFlags -> Profile
targetProfile DynFlags
dflags'
          in
          {-# SCC "writeIface" #-}
          Logger -> SDoc -> (() -> ()) -> IO () -> IO ()
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
              ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"WriteIface"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
iface_name))
              (() -> () -> ()
forall a b. a -> b -> a
const ())
              (Logger
-> Profile -> CompressionIFace -> [Char] -> ModIface -> IO ()
writeIface Logger
logger Profile
profile (DynFlags -> CompressionIFace
flagsToIfCompression DynFlags
dflags) [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 Maybe Fingerprint -> Maybe Fingerprint -> Bool
forall a. Eq a => a -> a -> Bool
/= Fingerprint -> Maybe Fingerprint
forall a. a -> Maybe a
Just (ModIfaceBackend -> Fingerprint
mi_iface_hash (ModIface -> IfaceBackendExts 'ModIfaceFinal
forall (phase :: ModIfacePhase).
ModIface_ phase -> IfaceBackendExts phase
mi_final_exts ModIface
iface))

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

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_if_trace) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Logger -> SDoc -> IO ()
putMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
        SDoc -> Int -> SDoc -> SDoc
hang ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Writing interface(s):") Int
2 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat
         [ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Kind:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> if Bool
is_simple then [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"simple" else [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"full"
         , [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Hash change:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Bool -> SDoc
forall a. Outputable a => a -> SDoc
ppr Bool
change
         , [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"DynamicToo state:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (DynamicTooState -> [Char]
forall a. Show a => a -> [Char]
show DynamicTooState
dt)
         ]

      if Bool
is_simple
         then Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
change (IO () -> IO ()) -> IO () -> IO ()
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   -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
               DynamicTooState
DT_Dyn    -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
panic [Char]
"Unexpected DT_Dyn state when writing simple interface"
               DynamicTooState
DT_OK     -> DynFlags -> ModIface -> IO ()
write_iface (DynFlags -> DynFlags
setDynamicNow DynFlags
dflags) ModIface
iface
         else case DynamicTooState
dt of
               DynamicTooState
DT_Dont | Bool
change                    -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
               DynamicTooState
DT_OK   | Bool
change                    -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
               -- FIXME: see change' comment above
               DynamicTooState
DT_Dyn                              -> DynFlags -> ModIface -> IO ()
write_iface DynFlags
dflags ModIface
iface
               DynamicTooState
_                                   -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_WriteHie DynFlags
dflags) (IO () -> IO ()) -> IO () -> IO ()
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
          IO Bool -> IO () -> IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ([Char] -> IO Bool
doesFileExist [Char]
hie_file) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> IO ()
GHC.Utils.Touch.touch [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.
    new_details <- {-# SCC "tcRnIface" #-}
                  HscEnv -> Module -> IfG ModDetails -> IO ModDetails
forall a. HscEnv -> Module -> IfG a -> IO a
initIfaceLoadModule HscEnv
hsc_env (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
old_iface) (ModIface -> IfG ModDetails
typecheckIface ModIface
old_iface)
    case lookupKnotVars (hsc_type_env_vars hsc_env) (mi_module old_iface) of
      Maybe (IORef TypeEnv)
Nothing -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Just IORef TypeEnv
te_var -> IORef TypeEnv -> TypeEnv -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef TypeEnv
te_var (ModDetails -> TypeEnv
md_types ModDetails
new_details)
    dumpIfaceStats hsc_env
    return 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 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"compilation IS NOT required"
        NeedsRecompile CompileReason
_ -> () -> IO ()
forall a. a -> IO a
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
forall doc. IsOutput doc => doc
empty)
batchMultiMsg :: Messager
batchMultiMsg :: Messager
batchMultiMsg = (HscEnv
 -> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc)
-> Messager
batchMsgWith (\HscEnv
_ (Int, Int)
_ RecompileRequired
_ ModuleGraphNode
node -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (UnitId -> SDoc
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
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Skipping") SDoc
forall doc. IsOutput doc => doc
empty
          | Bool
otherwise -> () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        NeedsRecompile CompileReason
reason0 -> SDoc -> SDoc -> IO ()
showMsg ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
herald) (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$ case CompileReason
reason0 of
          CompileReason
MustCompile            -> SDoc
forall doc. IsOutput doc => doc
empty
          (RecompBecause RecompReason
reason) -> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
" [" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> UnitState -> SDoc -> SDoc
pprWithUnitState UnitState
state (RecompReason -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecompReason
reason) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"]"
    where
        herald :: [Char]
herald = case ModuleGraphNode
node of
                    LinkNode {} -> [Char]
"Linking"
                    InstantiationNode {} -> [Char]
"Instantiating"
                    ModuleNode {} -> [Char]
"Compiling"
        hsc_env :: HscEnv
hsc_env = HasDebugCallStack => UnitId -> HscEnv -> HscEnv
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
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
        showMsg :: SDoc -> SDoc -> IO ()
showMsg SDoc
msg SDoc
reason =
            Logger -> SDoc -> IO ()
compilationProgressMsg Logger
logger (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
            ((Int, Int) -> SDoc
showModuleIndex (Int, Int)
mod_index SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>
            SDoc
msg SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> DynFlags -> Bool -> ModuleGraphNode -> SDoc
showModMsg DynFlags
dflags (RecompileRequired -> Bool
recompileRequired RecompileRequired
recomp) ModuleGraphNode
node)
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> HscEnv
-> (Int, Int) -> RecompileRequired -> ModuleGraphNode -> SDoc
extra HscEnv
hsc_env (Int, Int)
mod_index RecompileRequired
recomp ModuleGraphNode
node
                SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> 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
    dflags   <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    tcg_env' <- checkSafeImports tcg_env
    checkRULES dflags 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 (Messages GhcMessage -> Hsc ()) -> Messages GhcMessage -> Hsc ()
forall a b. (a -> b) -> a -> b
$ (DriverMessage -> GhcMessage)
-> Messages DriverMessage -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DriverMessage -> GhcMessage
GhcDriverMessage (Messages DriverMessage -> Messages GhcMessage)
-> Messages DriverMessage -> Messages GhcMessage
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')
              TcGblEnv -> Hsc TcGblEnv
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env' { tcg_rules = [] }
          Bool
False
                -- SafeInferred: user defined RULES, so not safe
              | DynFlags -> Bool
safeInferOn DynFlags
dflags Bool -> Bool -> Bool
&& Bool -> Bool
not ([LRuleDecl GhcTc] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([LRuleDecl GhcTc] -> Bool) -> [LRuleDecl GhcTc] -> Bool
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [LRuleDecl GhcTc]
tcg_rules TcGblEnv
tcg_env')
              -> TcGblEnv -> Messages DriverMessage -> Hsc TcGblEnv
forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env' (Messages DriverMessage -> Hsc TcGblEnv)
-> Messages DriverMessage -> Hsc TcGblEnv
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
              -> TcGblEnv -> Hsc TcGblEnv
forall a. a -> Hsc a
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 = Bag (MsgEnvelope DriverMessage) -> Messages DriverMessage
forall e. Bag (MsgEnvelope e) -> Messages e
mkMessages (Bag (MsgEnvelope DriverMessage) -> Messages DriverMessage)
-> Bag (MsgEnvelope DriverMessage) -> Messages DriverMessage
forall a b. (a -> b) -> a -> b
$ [MsgEnvelope DriverMessage] -> Bag (MsgEnvelope DriverMessage)
forall a. [a] -> Bag a
listToBag ([MsgEnvelope DriverMessage] -> Bag (MsgEnvelope DriverMessage))
-> [MsgEnvelope DriverMessage] -> Bag (MsgEnvelope DriverMessage)
forall a b. (a -> b) -> a -> b
$ (GenLocated SrcSpanAnnA (RuleDecl GhcTc)
 -> MsgEnvelope DriverMessage)
-> [GenLocated SrcSpanAnnA (RuleDecl GhcTc)]
-> [MsgEnvelope DriverMessage]
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) =
        DiagOpts -> SrcSpan -> DriverMessage -> MsgEnvelope DriverMessage
forall e. Diagnostic e => DiagOpts -> SrcSpan -> e -> MsgEnvelope e
mkPlainMsgEnvelope DiagOpts
diag_opts (SrcSpanAnnA -> SrcSpan
forall a. HasLoc a => a -> SrcSpan
locA SrcSpanAnnA
loc) (DriverMessage -> MsgEnvelope DriverMessage)
-> DriverMessage -> MsgEnvelope DriverMessage
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
        dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
        imps <- mapM condense imports'
        let (safeImps, regImps) = partition (\(Module
_,SrcSpan
_,Bool
s) -> Bool
s) imps

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

        -- Check safe imports are correct
        safePkgs <- S.fromList <$> mapMaybeM checkSafe safeImps
        safeErrs <- getDiagnostics
        clearDiagnostics

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

        -- restore old errors
        logDiagnostics oldErrs

        diag_opts <- initDiagOpts <$> getDynFlags
        print_config <- initPrintConfig <$> getDynFlags
        logger <- getLogger

        -- Will throw if failed safe check
        liftIO $ printOrThrowDiagnostics logger print_config diag_opts safeErrs

        -- No fatal warnings or errors: passed safe check
        let infPassed = Messages GhcMessage -> Bool
forall e. Messages e -> Bool
isEmptyMessages Messages GhcMessage
infErrs
        tcg_env' <- case (not infPassed) of
          Bool
True  -> TcGblEnv -> Messages GhcMessage -> Hsc TcGblEnv
forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env Messages GhcMessage
infErrs
          Bool
False -> TcGblEnv -> Hsc TcGblEnv
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return TcGblEnv
tcg_env
        when (packageTrustOn dflags) $ checkPkgTrust pkgReqs
        let newTrust = DynFlags -> Set UnitId -> Set UnitId -> Bool -> ImportAvails
pkgTrustReqs DynFlags
dflags Set UnitId
safePkgs Set UnitId
infPkgs Bool
infPassed
        return tcg_env' { tcg_imports = impInfo `plusImportAvails` 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 = ImportedMods -> [(Module, [ImportedBy])]
forall k a. Map k a -> [(k, a)]
M.toList ImportedMods
imports -- (Module, [ImportedBy])
    imports' :: [(Module, [ImportedModsVal])]
imports' = ((Module, [ImportedBy]) -> (Module, [ImportedModsVal]))
-> [(Module, [ImportedBy])] -> [(Module, [ImportedModsVal])]
forall a b. (a -> b) -> [a] -> [b]
map (([ImportedBy] -> [ImportedModsVal])
-> (Module, [ImportedBy]) -> (Module, [ImportedModsVal])
forall a b. (a -> b) -> (Module, a) -> (Module, b)
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
_, [])   = [Char] -> Hsc (Module, SrcSpan, Bool)
forall a. HasCallStack => [Char] -> a
panic [Char]
"GHC.Driver.Main.condense: Pattern match failure!"
    condense (Module
m, ImportedModsVal
x:[ImportedModsVal]
xs) = do imv <- (ImportedModsVal -> ImportedModsVal -> Hsc ImportedModsVal)
-> ImportedModsVal -> [ImportedModsVal] -> Hsc ImportedModsVal
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
                            return (m, imv_span imv, imv_is_safe 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 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
/= ImportedModsVal -> Bool
imv_is_safe ImportedModsVal
v2
        = MsgEnvelope GhcMessage -> Hsc ImportedModsVal
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> Hsc ImportedModsVal)
-> MsgEnvelope GhcMessage -> Hsc ImportedModsVal
forall a b. (a -> b) -> a -> b
$
            SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope (ImportedModsVal -> SrcSpan
imv_span ImportedModsVal
v1) (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
            DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ ModuleName -> DriverMessage
DriverMixedSafetyImport (ImportedModsVal -> ModuleName
imv_name ImportedModsVal
v1)
        | Bool
otherwise
        = ImportedModsVal -> Hsc ImportedModsVal
forall a. a -> Hsc a
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
_) = (Maybe UnitId, Set UnitId) -> Maybe UnitId
forall a b. (a, b) -> a
fst ((Maybe UnitId, Set UnitId) -> Maybe UnitId)
-> Hsc (Maybe UnitId, Set UnitId) -> Hsc (Maybe UnitId)
forall a b. (a -> b) -> Hsc a -> Hsc b
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 = req `S.union` inf
                                   }
    pkgTrustReqs DynFlags
dflags Set UnitId
_   Set UnitId
_ Bool
_ | DynFlags -> SafeHaskellMode
safeHaskell DynFlags
dflags SafeHaskellMode -> SafeHaskellMode -> Bool
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 = 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 = HscEnv -> Hsc Bool -> IO Bool
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc Bool -> IO Bool) -> Hsc Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$ do
    dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    pkgs <- snd `fmap` hscCheckSafe' m l
    when (packageTrustOn dflags) $ checkPkgTrust pkgs
    errs <- getDiagnostics
    return $ isEmptyMessages 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 = HscEnv -> Hsc (Bool, Set UnitId) -> IO (Bool, Set UnitId)
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (Bool, Set UnitId) -> IO (Bool, Set UnitId))
-> Hsc (Bool, Set UnitId) -> IO (Bool, Set UnitId)
forall a b. (a -> b) -> a -> b
$ do
    (self, pkgs) <- Module -> SrcSpan -> Hsc (Maybe UnitId, Set UnitId)
hscCheckSafe' Module
m SrcSpan
l
    good         <- isEmptyMessages `fmap` getDiagnostics
    clearDiagnostics -- don't want them printed...
    let pkgs' | Just UnitId
p <- Maybe UnitId
self = UnitId -> Set UnitId -> Set UnitId
forall a. Ord a => a -> Set a -> Set a
S.insert UnitId
p Set UnitId
pkgs
              | Bool
otherwise      = Set UnitId
pkgs
    return (good, 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
    hsc_env <- Hsc HscEnv
getHscEnv
    let home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
    (tw, pkgs) <- isModSafe home_unit m l
    case tw of
        Bool
False                           -> (Maybe UnitId, Set UnitId) -> Hsc (Maybe UnitId, Set UnitId)
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UnitId
forall a. Maybe a
Nothing, Set UnitId
pkgs)
        Bool
True | HomeUnit -> Module -> Bool
isHomeModule HomeUnit
home_unit Module
m -> (Maybe UnitId, Set UnitId) -> Hsc (Maybe UnitId, Set UnitId)
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UnitId
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   -> (Maybe UnitId, Set UnitId) -> Hsc (Maybe UnitId, Set UnitId)
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (UnitId -> Maybe UnitId
forall a. a -> Maybe a
Just (UnitId -> Maybe UnitId) -> UnitId -> Maybe UnitId
forall a b. (a -> b) -> a -> b
$ GenUnit UnitId -> UnitId
toUnitId (Module -> GenUnit UnitId
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
        hsc_env <- Hsc HscEnv
getHscEnv
        dflags <- getDynFlags
        iface <- lookup' m
        let diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
        case iface of
            -- can't load iface to check trust!
            Maybe ModIface
Nothing -> MsgEnvelope GhcMessage -> Hsc (Bool, Set UnitId)
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> Hsc (Bool, Set UnitId))
-> MsgEnvelope GhcMessage -> Hsc (Bool, Set UnitId)
forall a b. (a -> b) -> a -> b
$
                         SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
l (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
                         DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
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 (IfaceTrustInfo -> SafeHaskellMode)
-> IfaceTrustInfo -> SafeHaskellMode
forall a b. (a -> b) -> a -> b
$ ModIface -> IfaceTrustInfo
forall (phase :: ModIfacePhase). ModIface_ phase -> IfaceTrustInfo
mi_trust ModIface
iface'
                    trust_own_pkg :: Bool
trust_own_pkg = ModIface -> Bool
forall (phase :: ModIfacePhase). ModIface_ phase -> Bool
mi_trust_pkg ModIface
iface'
                    -- check module is trusted
                    safeM :: Bool
safeM = SafeHaskellMode
trust SafeHaskellMode -> [SafeHaskellMode] -> Bool
forall a. Eq a => a -> [a] -> Bool
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
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 (Dependencies -> Set UnitId) -> Dependencies -> Set UnitId
forall a b. (a -> b) -> a -> b
$ ModIface -> Dependencies
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 SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_SafeInferred
                                then DiagOpts -> Messages GhcMessage
inferredImportWarn DiagOpts
diag_opts
                                else Messages GhcMessage
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 ) -> Messages GhcMessage
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
                    (Bool, Set UnitId) -> Hsc (Bool, Set UnitId)
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (SafeHaskellMode
trust SafeHaskellMode -> SafeHaskellMode -> Bool
forall a. Eq a => a -> a -> Bool
== SafeHaskellMode
Sf_Trustworthy, Set UnitId
pkgRs)

                where
                    state :: UnitState
state = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
                    inferredImportWarn :: DiagOpts -> Messages GhcMessage
inferredImportWarn DiagOpts
diag_opts = MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage
                        (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ DiagOpts
-> SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
DiagOpts -> SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkMsgEnvelope DiagOpts
diag_opts SrcSpan
l (UnitState -> NamePprCtx
pkgQual UnitState
state)
                        (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ Module -> DriverMessage
DriverInferredSafeImport Module
m
                    pkgTrustErr :: Messages GhcMessage
pkgTrustErr = MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage
                      (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
l (UnitState -> NamePprCtx
pkgQual UnitState
state)
                      (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ UnitState -> Module -> DriverMessage
DriverCannotImportFromUntrustedPackage UnitState
state Module
m
                    modTrustErr :: Messages GhcMessage
modTrustErr = MsgEnvelope GhcMessage -> Messages GhcMessage
forall e. MsgEnvelope e -> Messages e
singleMessage
                      (MsgEnvelope GhcMessage -> Messages GhcMessage)
-> MsgEnvelope GhcMessage -> Messages GhcMessage
forall a b. (a -> b) -> a -> b
$ SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
l (UnitState -> NamePprCtx
pkgQual UnitState
state)
                      (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
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
_ -> GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted (GenericUnitInfo PackageId PackageName UnitId ModuleName Module
 -> Bool)
-> GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack =>
UnitState
-> GenUnit UnitId
-> GenericUnitInfo PackageId PackageName UnitId ModuleName Module
UnitState
-> GenUnit UnitId
-> GenericUnitInfo PackageId PackageName UnitId ModuleName Module
unsafeLookupUnit UnitState
unit_state (Module -> GenUnit UnitId
forall unit. GenModule unit -> unit
moduleUnit Module
m)

    lookup' :: Module -> Hsc (Maybe ModIface)
    lookup' :: Module -> Hsc (Maybe ModIface)
lookup' Module
m = do
        hsc_env <- Hsc HscEnv
getHscEnv
        hsc_eps <- liftIO $ hscEPS hsc_env
        let pkgIfaceT = ExternalPackageState -> PackageIfaceTable
eps_PIT ExternalPackageState
hsc_eps
            hug       = HscEnv -> HomeUnitGraph
hsc_HUG HscEnv
hsc_env
            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 iface of
            Just ModIface
_  -> Maybe ModIface -> Hsc (Maybe ModIface)
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModIface
iface
            Maybe ModIface
Nothing -> (Messages TcRnMessage, Maybe ModIface) -> Maybe ModIface
forall a b. (a, b) -> b
snd ((Messages TcRnMessage, Maybe ModIface) -> Maybe ModIface)
-> Hsc (Messages TcRnMessage, Maybe ModIface)
-> Hsc (Maybe ModIface)
forall a b. (a -> b) -> Hsc a -> Hsc b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` (IO (Messages TcRnMessage, Maybe ModIface)
-> Hsc (Messages TcRnMessage, Maybe ModIface)
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Messages TcRnMessage, Maybe ModIface)
 -> Hsc (Messages TcRnMessage, Maybe ModIface))
-> IO (Messages TcRnMessage, Maybe ModIface)
-> Hsc (Messages TcRnMessage, Maybe ModIface)
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
    hsc_env <- Hsc HscEnv
getHscEnv
    let errors = (UnitId
 -> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage))
-> Bag (MsgEnvelope GhcMessage)
-> Set UnitId
-> Bag (MsgEnvelope GhcMessage)
forall a b. (a -> b -> b) -> b -> Set a -> b
S.foldr UnitId
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
go Bag (MsgEnvelope GhcMessage)
forall a. Bag a
emptyBag Set UnitId
pkgs
        state  = HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env
        go UnitId
pkg Bag (MsgEnvelope GhcMessage)
acc
            | GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> Bool
forall srcpkgid srcpkgname uid modulename mod.
GenericUnitInfo srcpkgid srcpkgname uid modulename mod -> Bool
unitIsTrusted (GenericUnitInfo PackageId PackageName UnitId ModuleName Module
 -> Bool)
-> GenericUnitInfo PackageId PackageName UnitId ModuleName Module
-> Bool
forall a b. (a -> b) -> a -> b
$ HasDebugCallStack =>
UnitState
-> UnitId
-> GenericUnitInfo PackageId PackageName UnitId ModuleName Module
UnitState
-> UnitId
-> GenericUnitInfo PackageId PackageName UnitId ModuleName Module
unsafeLookupUnitId UnitState
state UnitId
pkg
            = Bag (MsgEnvelope GhcMessage)
acc
            | Bool
otherwise
            = (MsgEnvelope GhcMessage
-> Bag (MsgEnvelope GhcMessage) -> Bag (MsgEnvelope GhcMessage)
forall a. a -> Bag a -> Bag a
`consBag` Bag (MsgEnvelope GhcMessage)
acc)
                     (MsgEnvelope GhcMessage -> Bag (MsgEnvelope GhcMessage))
-> MsgEnvelope GhcMessage -> Bag (MsgEnvelope GhcMessage)
forall a b. (a -> b) -> a -> b
$ SrcSpan -> NamePprCtx -> GhcMessage -> MsgEnvelope GhcMessage
forall e.
Diagnostic e =>
SrcSpan -> NamePprCtx -> e -> MsgEnvelope e
mkErrorMsgEnvelope SrcSpan
noSrcSpan (UnitState -> NamePprCtx
pkgQual UnitState
state)
                     (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$ DriverMessage -> GhcMessage
GhcDriverMessage
                     (DriverMessage -> GhcMessage) -> DriverMessage -> GhcMessage
forall a b. (a -> b) -> a -> b
$ UnitState -> UnitId -> DriverMessage
DriverPackageNotTrusted UnitState
state UnitId
pkg
    if isEmptyBag errors
      then return ()
      else liftIO $ throwErrors $ mkMessages 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 :: forall e . Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer :: forall e. Diagnostic e => TcGblEnv -> Messages e -> Hsc TcGblEnv
markUnsafeInfer TcGblEnv
tcg_env Messages e
whyUnsafe = do
    dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags

    let reason = WarningFlag -> DiagnosticReason
WarningWithFlag WarningFlag
Opt_WarnUnsafe
    let diag_opts = DynFlags -> DiagOpts
initDiagOpts DynFlags
dflags
    when (diag_wopt Opt_WarnUnsafe diag_opts)
         (logDiagnostics $ singleMessage $
             mkPlainMsgEnvelope diag_opts (warnUnsafeOnLoc dflags) $
             GhcDriverMessage $ DriverUnknownMessage $
             mkSimpleUnknownDiagnostic $
             mkPlainDiagnostic reason noHints $
             whyUnsafe' dflags)

    liftIO $ writeIORef (tcg_safe_infer tcg_env) False
    liftIO $ writeIORef (tcg_safe_infer_reasons tcg_env) 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 not (safeHaskellModeEnabled dflags) of
      Bool
True  -> TcGblEnv -> Hsc TcGblEnv
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return (TcGblEnv -> Hsc TcGblEnv) -> TcGblEnv -> Hsc TcGblEnv
forall a b. (a -> b) -> a -> b
$ TcGblEnv
tcg_env { tcg_imports = wiped_trust }
      Bool
False -> TcGblEnv -> Hsc TcGblEnv
forall a. a -> Hsc a
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 = S.empty }
    pprMod :: SDoc
pprMod        = ModuleName -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleName -> SDoc) -> ModuleName -> SDoc
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
forall unit. GenModule unit -> ModuleName
moduleName (Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> Module
tcg_mod TcGblEnv
tcg_env
    whyUnsafe' :: DynFlags -> SDoc
whyUnsafe' DynFlags
df = [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [ SDoc -> SDoc
quotes SDoc
pprMod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"has been inferred as unsafe!"
                         , [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"Reason:"
                         , Int -> SDoc -> SDoc
nest Int
4 (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ DynFlags -> [SDoc]
badFlags DynFlags
df) SDoc -> SDoc -> SDoc
$+$
                                    -- MP: Using defaultDiagnosticOpts here is not right but it's also not right to handle these
                                    -- unsafety error messages in an unstructured manner.
                                    ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
forall e.
Diagnostic e =>
DiagnosticOpts e -> Bag (MsgEnvelope e) -> [SDoc]
pprMsgEnvelopeBagWithLoc (forall opts.
HasDefaultDiagnosticOpts (DiagnosticOpts opts) =>
DiagnosticOpts opts
defaultDiagnosticOpts @e) (Messages e -> Bag (MsgEnvelope e)
forall e. Messages e -> Bag (MsgEnvelope e)
getMessages Messages e
whyUnsafe)) SDoc -> SDoc -> SDoc
$+$
                                    ([SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ClsInst] -> [SDoc]
forall {t :: * -> *}. Foldable t => t ClsInst -> [SDoc]
badInsts ([ClsInst] -> [SDoc]) -> [ClsInst] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ TcGblEnv -> [ClsInst]
tcg_insts TcGblEnv
tcg_env)
                         ]
    badFlags :: DynFlags -> [SDoc]
badFlags DynFlags
df   = ((Extension, DynFlags -> SrcSpan, DynFlags -> Bool,
  DynFlags -> DynFlags)
 -> [SDoc])
-> [(Extension, DynFlags -> SrcSpan, DynFlags -> Bool,
     DynFlags -> DynFlags)]
-> [SDoc]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (DynFlags
-> (Extension, DynFlags -> SrcSpan, DynFlags -> Bool,
    DynFlags -> DynFlags)
-> [SDoc]
forall {a} {t} {d}.
Outputable a =>
t -> (a, t -> SrcSpan, t -> Bool, d) -> [SDoc]
badFlag DynFlags
df) [(Extension, DynFlags -> SrcSpan, DynFlags -> Bool,
  DynFlags -> DynFlags)]
unsafeFlagsForInfer
    badFlag :: t -> (a, t -> SrcSpan, t -> Bool, d) -> [SDoc]
badFlag t
df (a
ext,t -> SrcSpan
loc,t -> Bool
on,d
_)
        | t -> Bool
on t
df     = [MessageClass -> SrcSpan -> SDoc -> SDoc
mkLocMessage MessageClass
MCOutput (t -> SrcSpan
loc t
df) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                            [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"-X" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
ext SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"is not allowed in Safe Haskell"]
        | Bool
otherwise = []
    badInsts :: t ClsInst -> [SDoc]
badInsts t ClsInst
insts = (ClsInst -> [SDoc]) -> t ClsInst -> [SDoc]
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 (Name -> SrcSpan) -> Name -> SrcSpan
forall a b. (a -> b) -> a -> b
$ Id -> Name
forall a. NamedThing a => a -> Name
getName (Id -> Name) -> Id -> Name
forall a b. (a -> b) -> a -> b
$ ClsInst -> Id
is_dfun ClsInst
ins) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
                      OverlapMode -> SDoc
forall a. Outputable a => a -> SDoc
ppr (OverlapFlag -> OverlapMode
overlapMode (OverlapFlag -> OverlapMode) -> OverlapFlag -> OverlapMode
forall a b. (a -> b) -> a -> b
$ ClsInst -> OverlapFlag
is_flag ClsInst
ins) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                      [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
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
    dflags  <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    liftIO $ finalSafeMode dflags 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 =
    HscEnv -> Hsc ModGuts -> IO ModGuts
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc ModGuts -> IO ModGuts) -> Hsc ModGuts -> IO ModGuts
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
    hsc_env <- Hsc HscEnv
getHscEnv
    hsc_env_with_plugins <- if null plugins -- fast path
        then return hsc_env
        else liftIO $ initializePlugins
                    $ hscUpdateFlags (\DynFlags
dflags -> ([Char] -> DynFlags -> DynFlags)
-> DynFlags -> [[Char]] -> DynFlags
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr [Char] -> DynFlags -> DynFlags
addPluginModuleName DynFlags
dflags [[Char]]
plugins)
                      hsc_env
    {-# SCC "Core2Core" #-}
      liftIO $ core2core hsc_env_with_plugins ds_result

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

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

hscSimpleIface' :: Maybe CoreProgram
                -> TcGblEnv
                -> ModSummary
                -> Hsc (ModIface, ModDetails)
hscSimpleIface' :: Maybe CoreProgram
-> TcGblEnv -> ModSummary -> Hsc (ModIface, ModDetails)
hscSimpleIface' Maybe CoreProgram
mb_core_program TcGblEnv
tc_result ModSummary
summary = do
    hsc_env   <- Hsc HscEnv
getHscEnv
    logger    <- getLogger
    details   <- liftIO $ mkBootModDetailsTc logger tc_result
    safe_mode <- hscGetSafeMode tc_result
    new_iface
        <- {-# SCC "MkFinalIface" #-}
           liftIO $
               mkIfaceTc hsc_env safe_mode details summary mb_core_program tc_result
    -- And the answer is ...
    liftIO $ dumpIfaceStats hsc_env
    return (new_iface, 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{ 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
                    } = CgGuts
cgguts
            dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
            logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env


        -------------------
        -- Insert late cost centres based on the provided flags.
        --
        -- If -fprof-late-inline is enabled, we will skip adding CCs on any
        -- top-level bindings here (via shortcut in `addLateCostCenters`),
        -- since it will have already added a superset of the CCs we would add
        -- here.
        let
          late_cc_config :: LateCCConfig
          late_cc_config :: LateCCConfig
late_cc_config =
            LateCCConfig
              { lateCCConfig_whichBinds :: LateCCBindSpec
lateCCConfig_whichBinds =
                  if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateInlineCcs DynFlags
dflags then
                    LateCCBindSpec
LateCCNone
                  else if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateCcs DynFlags
dflags then
                    LateCCBindSpec
LateCCBinds
                  else if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateOverloadedCcs DynFlags
dflags then
                    LateCCBindSpec
LateCCOverloadedBinds
                  else
                    LateCCBindSpec
LateCCNone
              , lateCCConfig_overloadedCalls :: Bool
lateCCConfig_overloadedCalls =
                  GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfLateoverloadedCallsCCs DynFlags
dflags
              , lateCCConfig_env :: LateCCEnv
lateCCConfig_env =
                  LateCCEnv
                    { lateCCEnv_module :: Module
lateCCEnv_module = Module
this_mod
                    , lateCCEnv_file :: Maybe FastString
lateCCEnv_file = [Char] -> FastString
fsLit ([Char] -> FastString) -> Maybe [Char] -> Maybe FastString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ModLocation -> Maybe [Char]
ml_hs_file ModLocation
location
                    , lateCCEnv_countEntries :: Bool
lateCCEnv_countEntries= GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfCountEntries DynFlags
dflags
                    , lateCCEnv_collectCCs :: Bool
lateCCEnv_collectCCs = Bool
True
                    }
              }

        (late_cc_binds, late_cc_state) <-
          Logger
-> LateCCConfig
-> CoreProgram
-> IO (CoreProgram, LateCCState (Maybe SrcSpan))
addLateCostCenters Logger
logger LateCCConfig
late_cc_config CoreProgram
core_binds

        when (dopt Opt_D_dump_late_cc dflags || dopt Opt_D_verbose_core2core dflags) $
          putDumpFileMaybe logger Opt_D_dump_late_cc "LateCC" FormatCore (vcat (map ppr late_cc_binds))

        -------------------
        -- Run late plugins
        -- This is the last use of the ModGuts in a compilation.
        -- From now on, we just use the bits we need.
        ( CgGuts
            { cg_tycons        = tycons,
              cg_foreign       = foreign_stubs0,
              cg_foreign_files = foreign_files,
              cg_dep_pkgs      = dependencies,
              cg_spt_entries   = spt_entries,
              cg_binds         = late_binds,
              cg_ccs           = late_local_ccs
            }
          , _
          ) <-
          {-# SCC latePlugins #-}
          withTiming
            logger
            (text "LatePlugins"<+>brackets (ppr this_mod))
            (const ()) $
            withPlugins (hsc_plugins hsc_env)
              (($ hsc_env) . latePlugin)
                ( cgguts
                    { cg_binds = late_cc_binds
                    , cg_ccs = S.toList (lateCCState_ccs late_cc_state) ++ local_ccs
                    }
                , lateCCState_ccState late_cc_state
                )

        let
          hooks  = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
          tmpfs  = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
          llvm_config = HscEnv -> LlvmConfigCache
hsc_llvm_config HscEnv
hsc_env
          profile = DynFlags -> Profile
targetProfile DynFlags
dflags
          data_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
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
        (prepd_binds) <- {-# SCC "CorePrep" #-} do
          cp_cfg <- initCorePrepConfig hsc_env
          corePrepPgm
            (hsc_logger hsc_env)
            cp_cfg
            (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
            this_mod location late_binds data_tycons

        -----------------  Convert to STG ------------------
        (stg_binds_with_deps, denv, (caf_ccs, caf_cc_stacks), stg_cg_infos)
            <- {-# SCC "CoreToStg" #-}
               withTiming logger
                   (text "CoreToStg"<+>brackets (ppr this_mod))
                   (\([(CgStgTopBinding, IdSet)]
a, InfoTableProvMap
b, ([CostCentre]
c,[CostCentreStack]
d), StgCgInfos
tag_env) ->
                        [(CgStgTopBinding, IdSet)]
a [(CgStgTopBinding, IdSet)] -> InfoTableProvMap -> InfoTableProvMap
forall a b. [a] -> b -> b
`seqList`
                        InfoTableProvMap
b InfoTableProvMap -> () -> ()
forall a b. a -> b -> b
`seq`
                        [CostCentre]
c [CostCentre] -> [CostCentreStack] -> [CostCentreStack]
forall a b. [a] -> b -> b
`seqList`
                        [CostCentreStack]
d [CostCentreStack] -> () -> ()
forall a b. [a] -> b -> b
`seqList`
                        ((TagSig -> ()) -> StgCgInfos -> ()
forall {k} elt (key :: k). (elt -> ()) -> UniqFM key elt -> ()
seqEltsUFM (TagSig -> ()
seqTagSig) StgCgInfos
tag_env))
                   (myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) False this_mod location prepd_binds)

        let (stg_binds,_stg_deps) = unzip stg_binds_with_deps

        let cost_centre_info =
              ([CostCentre]
late_local_ccs [CostCentre] -> [CostCentre] -> [CostCentre]
forall a. [a] -> [a] -> [a]
++ [CostCentre]
caf_ccs, [CostCentreStack]
caf_cc_stacks)
            platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
            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 = CStub
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 withTiming isn't very useful here.
        -- Hence we have one withTiming for the whole backend, the
        -- next withTiming after this will be "Assembler" (hard code only).
        withTiming logger (text "CodeGen"<+>brackets (ppr this_mod)) (const ())
         $ case backendCodeOutput (backend dflags) of
            DefunctionalizedCodeOutput
JSCodeOutput ->
              do
              let js_config :: StgToJSConfig
js_config = DynFlags -> StgToJSConfig
initStgToJSConfig DynFlags
dflags

                  -- The JavaScript backend does not create CmmCgInfos like the Cmm backend,
                  -- but it is needed for writing the interface file. Here we compute a very
                  -- conservative but correct value.
                  lf_infos :: GenStgTopBinding pass -> [(Name, LambdaFormInfo)]
lf_infos (StgTopLifted (StgNonRec BinderP pass
b GenStgRhs pass
_)) = [(Id -> Name
idName Id
BinderP pass
b, Bool -> LambdaFormInfo
LFUnknown Bool
True)]
                  lf_infos (StgTopLifted (StgRec [(BinderP pass, GenStgRhs pass)]
bs))     = ((Id, GenStgRhs pass) -> (Name, LambdaFormInfo))
-> [(Id, GenStgRhs pass)] -> [(Name, LambdaFormInfo)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Id
b,GenStgRhs pass
_) -> (Id -> Name
idName Id
b, Bool -> LambdaFormInfo
LFUnknown Bool
True)) [(Id, GenStgRhs pass)]
[(BinderP pass, GenStgRhs pass)]
bs
                  lf_infos (StgTopStringLit Id
b ByteString
_)          = [(Id -> Name
idName Id
b, LambdaFormInfo
LFUnlifted)]

                  cmm_cg_infos :: CmmCgInfos
cmm_cg_infos  = CmmCgInfos
                    { cgNonCafs :: NonCaffySet
cgNonCafs = NonCaffySet
forall a. Monoid a => a
mempty
                    , cgLFInfos :: ModuleLFInfos
cgLFInfos = [(Name, LambdaFormInfo)] -> ModuleLFInfos
forall a. [(Name, a)] -> NameEnv a
mkNameEnv ((CgStgTopBinding -> [(Name, LambdaFormInfo)])
-> [CgStgTopBinding] -> [(Name, LambdaFormInfo)]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CgStgTopBinding -> [(Name, LambdaFormInfo)]
forall {pass :: StgPass}.
(BinderP pass ~ Id) =>
GenStgTopBinding pass -> [(Name, LambdaFormInfo)]
lf_infos [CgStgTopBinding]
stg_binds)
                    , cgIPEStub :: CStub
cgIPEStub = CStub
forall a. Monoid a => a
mempty
                    }
                  stub_c_exists :: Maybe a
stub_c_exists = Maybe a
forall a. Maybe a
Nothing
                  foreign_fps :: [a]
foreign_fps   = []

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

              -- do the unfortunately effectual business
              Logger
-> StgToJSConfig
-> [CgStgTopBinding]
-> Module
-> [SptEntry]
-> ForeignStubs
-> ([CostCentre], [CostCentreStack])
-> [Char]
-> IO ()
stgToJS Logger
logger StgToJSConfig
js_config [CgStgTopBinding]
stg_binds Module
this_mod [SptEntry]
spt_entries ForeignStubs
foreign_stubs0 ([CostCentre], [CostCentreStack])
cost_centre_info [Char]
output_filename
              ([Char], Maybe [Char], [(ForeignSrcLang, [Char])],
 Maybe StgCgInfos, Maybe CmmCgInfos)
-> IO
     ([Char], Maybe [Char], [(ForeignSrcLang, [Char])],
      Maybe StgCgInfos, Maybe CmmCgInfos)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Char]
output_filename, Maybe [Char]
forall a. Maybe a
stub_c_exists, [(ForeignSrcLang, [Char])]
forall a. [a]
foreign_fps, StgCgInfos -> Maybe StgCgInfos
forall a. a -> Maybe a
Just StgCgInfos
stg_cg_infos, CmmCgInfos -> Maybe CmmCgInfos
forall a. a -> Maybe a
Just CmmCgInfos
cmm_cg_infos)

            DefunctionalizedCodeOutput
_          ->
              do
              cmms <- {-# SCC "StgToCmm" #-}
                HscEnv
-> Module
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> IO
     (CgStream
        [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

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

              let dump [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a = do
                    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a) (IO () -> IO ()) -> IO () -> IO ()
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 (Platform
-> [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a)
                    [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a
                  rawcmms1 = ([GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
 -> UniqDSMT
      IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph])
-> CgStream
     [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
     CmmCgInfos
-> CgStream
     [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
     CmmCgInfos
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM (IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> UniqDSMT
     IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
 -> UniqDSMT
      IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph])
-> ([GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
    -> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph])
-> [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> UniqDSMT
     IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
dump) CgStream
  [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
  CmmCgInfos
rawcmms0

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

              (output_filename, (_stub_h_exists, stub_c_exists), foreign_fps, cmm_cg_infos)
                  <- {-# SCC "codeOutput" #-}
                    codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) this_mod output_filename location
                    foreign_stubs foreign_files dependencies (initDUniqSupply 'n' 0) rawcmms1
              return  ( output_filename, stub_c_exists, foreign_fps
                      , Just stg_cg_infos, Just cmm_cg_infos)


-- The part of CgGuts that we need for HscInteractive
data CgInteractiveGuts = CgInteractiveGuts { CgInteractiveGuts -> Module
cgi_module :: Module
                                           , CgInteractiveGuts -> CoreProgram
cgi_binds  :: CoreProgram
                                           , CgInteractiveGuts -> [TyCon]
cgi_tycons :: [TyCon]
                                           , CgInteractiveGuts -> ForeignStubs
cgi_foreign :: ForeignStubs
                                           , CgInteractiveGuts -> [(ForeignSrcLang, [Char])]
cgi_foreign_files :: [(ForeignSrcLang, FilePath)]
                                           , CgInteractiveGuts -> Maybe ModBreaks
cgi_modBreaks ::  Maybe ModBreaks
                                           , CgInteractiveGuts -> [SptEntry]
cgi_spt_entries :: [SptEntry]
                                           }

mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts
mkCgInteractiveGuts :: CgGuts -> CgInteractiveGuts
mkCgInteractiveGuts CgGuts{Module
cg_module :: CgGuts -> Module
cg_module :: Module
cg_module, CoreProgram
cg_binds :: CgGuts -> CoreProgram
cg_binds :: CoreProgram
cg_binds, [TyCon]
cg_tycons :: CgGuts -> [TyCon]
cg_tycons :: [TyCon]
cg_tycons, ForeignStubs
cg_foreign :: CgGuts -> ForeignStubs
cg_foreign :: ForeignStubs
cg_foreign, [(ForeignSrcLang, [Char])]
cg_foreign_files :: CgGuts -> [(ForeignSrcLang, [Char])]
cg_foreign_files :: [(ForeignSrcLang, [Char])]
cg_foreign_files, Maybe ModBreaks
cg_modBreaks :: Maybe ModBreaks
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_modBreaks, [SptEntry]
cg_spt_entries :: CgGuts -> [SptEntry]
cg_spt_entries :: [SptEntry]
cg_spt_entries}
  = Module
-> CoreProgram
-> [TyCon]
-> ForeignStubs
-> [(ForeignSrcLang, [Char])]
-> Maybe ModBreaks
-> [SptEntry]
-> CgInteractiveGuts
CgInteractiveGuts Module
cg_module CoreProgram
cg_binds [TyCon]
cg_tycons ForeignStubs
cg_foreign [(ForeignSrcLang, [Char])]
cg_foreign_files Maybe ModBreaks
cg_modBreaks [SptEntry]
cg_spt_entries

hscInteractive :: HscEnv
               -> CgInteractiveGuts
               -> ModLocation
               -> IO (Maybe FilePath, CompiledByteCode) -- ^ .c stub path (if any) and ByteCode
hscInteractive :: HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO (Maybe [Char], CompiledByteCode)
hscInteractive HscEnv
hsc_env CgInteractiveGuts
cgguts ModLocation
location = do
    let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
    let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    let tmpfs :: TmpFs
tmpfs  = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
    let CgInteractiveGuts{ -- This is the last use of the ModGuts in a compilation.
                -- From now on, we just use the bits we need.
               cgi_module :: CgInteractiveGuts -> Module
cgi_module   = Module
this_mod,
               cgi_binds :: CgInteractiveGuts -> CoreProgram
cgi_binds    = CoreProgram
core_binds,
               cgi_tycons :: CgInteractiveGuts -> [TyCon]
cgi_tycons   = [TyCon]
tycons,
               cgi_foreign :: CgInteractiveGuts -> ForeignStubs
cgi_foreign  = ForeignStubs
foreign_stubs,
               cgi_modBreaks :: CgInteractiveGuts -> Maybe ModBreaks
cgi_modBreaks = Maybe ModBreaks
mod_breaks,
               cgi_spt_entries :: CgInteractiveGuts -> [SptEntry]
cgi_spt_entries = [SptEntry]
spt_entries } = CgInteractiveGuts
cgguts

        data_tycons :: [TyCon]
data_tycons = (TyCon -> Bool) -> [TyCon] -> [TyCon]
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
    prepd_binds <- {-# SCC "CorePrep" #-} do
      cp_cfg <- HscEnv -> IO CorePrepConfig
initCorePrepConfig HscEnv
hsc_env
      corePrepPgm
        (hsc_logger hsc_env)
        cp_cfg
        (initCorePrepPgmConfig (hsc_dflags hsc_env) (interactiveInScope $ hsc_IC hsc_env))
        this_mod location core_binds data_tycons

    -- The stg cg info only provides a runtime benfit, but is not requires so we just
    -- omit it here
    (stg_binds_with_deps, _infotable_prov, _caf_ccs__caf_cc_stacks, _ignore_stg_cg_infos)
      <- {-# SCC "CoreToStg" #-}
          myCoreToStg logger dflags (interactiveInScope (hsc_IC hsc_env)) True this_mod location prepd_binds

    let (stg_binds,_stg_deps) = unzip stg_binds_with_deps

    -----------------  Generate byte code ------------------
    comp_bc <- byteCodeGen hsc_env this_mod stg_binds data_tycons mod_breaks spt_entries

    ------------------ Create f-x-dynamic C-side stuff -----
    (_istub_h_exists, istub_c_exists)
        <- outputForeignStubs logger tmpfs dflags (hsc_units hsc_env) this_mod location foreign_stubs
    return (istub_c_exists, comp_bc)

-- | Compile Core bindings and foreign inputs that were loaded from an
-- interface, to produce bytecode and potential foreign objects for the purpose
-- of linking splices.
generateByteCode :: HscEnv
  -> CgInteractiveGuts
  -> ModLocation
  -> IO (CompiledByteCode, [FilePath])
generateByteCode :: HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO (CompiledByteCode, [[Char]])
generateByteCode HscEnv
hsc_env CgInteractiveGuts
cgguts ModLocation
mod_location = do
  (hasStub, comp_bc) <- HscEnv
-> CgInteractiveGuts
-> ModLocation
-> IO (Maybe [Char], CompiledByteCode)
hscInteractive HscEnv
hsc_env CgInteractiveGuts
cgguts ModLocation
mod_location
  compile_for_interpreter hsc_env $ \ HscEnv
i_env -> do
    stub_o <- ([Char] -> IO [Char]) -> Maybe [Char] -> IO (Maybe [Char])
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (HscEnv -> ForeignSrcLang -> [Char] -> IO [Char]
compileForeign HscEnv
i_env ForeignSrcLang
LangC) Maybe [Char]
hasStub
    foreign_files_o <- traverse (uncurry (compileForeign i_env)) (cgi_foreign_files cgguts)
    pure (comp_bc, maybeToList stub_o ++ foreign_files_o)

generateFreshByteCode :: HscEnv
  -> ModuleName
  -> CgInteractiveGuts
  -> ModLocation
  -> IO Linkable
generateFreshByteCode :: HscEnv
-> ModuleName -> CgInteractiveGuts -> ModLocation -> IO Linkable
generateFreshByteCode HscEnv
hsc_env ModuleName
mod_name CgInteractiveGuts
cgguts ModLocation
mod_location = do
  bco_time <- IO UTCTime
getCurrentTime
  (bcos, fos) <- generateByteCode hsc_env cgguts mod_location
  return $!
    Linkable bco_time
    (mkHomeModule (hsc_home_unit hsc_env) mod_name)
    (BCOs bcos :| [DotO fo ForeignObject | fo <- fos])
------------------------------

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 = HscEnv -> Hsc (Maybe [Char]) -> IO (Maybe [Char])
forall a. HscEnv -> Hsc a -> IO a
runHsc HscEnv
hsc_env (Hsc (Maybe [Char]) -> IO (Maybe [Char]))
-> Hsc (Maybe [Char]) -> IO (Maybe [Char])
forall a b. (a -> b) -> a -> b
$ do
    let dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
        logger :: Logger
logger   = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
        hooks :: Hooks
hooks    = HscEnv -> Hooks
hsc_hooks HscEnv
hsc_env
        tmpfs :: TmpFs
tmpfs    = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
        profile :: Profile
profile  = DynFlags -> Profile
targetProfile DynFlags
dflags
        home_unit :: HomeUnit
home_unit = HscEnv -> HomeUnit
hsc_home_unit HscEnv
hsc_env
        platform :: Platform
platform  = DynFlags -> Platform
targetPlatform DynFlags
dflags
        llvm_config :: LlvmConfigCache
llvm_config = HscEnv -> LlvmConfigCache
hsc_llvm_config HscEnv
hsc_env
        cmm_config :: CmmConfig
cmm_config = DynFlags -> CmmConfig
initCmmConfig DynFlags
dflags
        do_info_table :: Bool
do_info_table = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags
        -- 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 ([Char] -> ModuleName) -> [Char] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [Char]
"Cmm$" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
original_filename
        cmm_mod :: Module
cmm_mod = HomeUnit -> ModuleName -> Module
mkHomeModule HomeUnit
home_unit ModuleName
mod_name
        cmmpConfig :: CmmParserConfig
cmmpConfig = DynFlags -> CmmParserConfig
initCmmParserConfig DynFlags
dflags
    (dcmm, ipe_ents) <- IO (Messages GhcMessage, Maybe (DCmmGroup, [InfoProvEnt]))
-> Hsc (DCmmGroup, [InfoProvEnt])
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe
               (IO (Messages GhcMessage, Maybe (DCmmGroup, [InfoProvEnt]))
 -> Hsc (DCmmGroup, [InfoProvEnt]))
-> IO (Messages GhcMessage, Maybe (DCmmGroup, [InfoProvEnt]))
-> Hsc (DCmmGroup, [InfoProvEnt])
forall a b. (a -> b) -> a -> b
$ do
                  (warns,errs,cmm) <- Logger
-> SDoc
-> ((Messages PsWarning, Messages PsWarning,
     Maybe (DCmmGroup, [InfoProvEnt]))
    -> ())
-> IO
     (Messages PsWarning, Messages PsWarning,
      Maybe (DCmmGroup, [InfoProvEnt]))
-> IO
     (Messages PsWarning, Messages PsWarning,
      Maybe (DCmmGroup, [InfoProvEnt]))
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"ParseCmm"SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
filename)) (\(Messages PsWarning, Messages PsWarning,
 Maybe (DCmmGroup, [InfoProvEnt]))
_ -> ())
                                       (IO
   (Messages PsWarning, Messages PsWarning,
    Maybe (DCmmGroup, [InfoProvEnt]))
 -> IO
      (Messages PsWarning, Messages PsWarning,
       Maybe (DCmmGroup, [InfoProvEnt])))
-> IO
     (Messages PsWarning, Messages PsWarning,
      Maybe (DCmmGroup, [InfoProvEnt]))
-> IO
     (Messages PsWarning, Messages PsWarning,
      Maybe (DCmmGroup, [InfoProvEnt]))
forall a b. (a -> b) -> a -> b
$ CmmParserConfig
-> Module
-> HomeUnit
-> [Char]
-> IO
     (Messages PsWarning, Messages PsWarning,
      Maybe (DCmmGroup, [InfoProvEnt]))
parseCmmFile CmmParserConfig
cmmpConfig Module
cmm_mod HomeUnit
home_unit [Char]
filename
                  let msgs = Messages PsWarning
warns Messages PsWarning -> Messages PsWarning -> Messages PsWarning
forall e. Messages e -> Messages e -> Messages e
`unionMessages` Messages PsWarning
errs
                  return (GhcPsMessage <$> msgs, cmm)
    -- Probably need to rename cmm here
    let cmm = DCmmGroup -> CmmGroup
removeDeterm DCmmGroup
dcmm
    liftIO $ do
        putDumpFileMaybe logger Opt_D_dump_cmm_verbose_by_proc "Parsed Cmm" FormatCMM (pdoc platform 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]
        ((_,dus1), cmmgroup) <- second concat <$>
          mapAccumLM (\(ModuleSRTInfo
msrt0, DUniqSupply
dus0) GenCmmDecl CmmStatics CmmTopInfo CmmGraph
cmm -> do
            ((msrt1, cmm'), dus1) <- Logger
-> CmmConfig
-> ModuleSRTInfo
-> CmmGroup
-> DUniqSupply
-> IO
     ((ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]),
      DUniqSupply)
cmmPipeline Logger
logger CmmConfig
cmm_config ModuleSRTInfo
msrt0 [GenCmmDecl CmmStatics CmmTopInfo CmmGraph
cmm] DUniqSupply
dus0
            return ((msrt1, dus1), cmm')) (emptySRT cmm_mod, initDUniqSupply 'u' 0) cmm

        unless (null cmmgroup) $
          putDumpFileMaybe logger Opt_D_dump_cmm "Output Cmm"
            FormatCMM (pdoc platform cmmgroup)

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

        let dump [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a = do
              Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a) (IO () -> IO ()) -> IO () -> IO ()
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 (Platform
-> [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a)
              [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
a
            rawCmms = ([GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
 -> UniqDSMT
      IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph])
-> CgStream
     [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ()
-> CgStream
     [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ()
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM (IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> UniqDSMT
     IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
 -> UniqDSMT
      IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph])
-> ([GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
    -> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph])
-> [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> UniqDSMT
     IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
-> IO [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph]
dump) CgStream
  [GenCmmDecl RawCmmStatics (LabelMap RawCmmStatics) CmmGraph] ()
rawCmms0

        let foreign_stubs ()
_
              | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [InfoProvEnt] -> Bool
forall a. [a] -> Bool
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
        (_output_filename, (_stub_h_exists, stub_c_exists), _foreign_fps, _caf_infos)
          <- codeOutput logger tmpfs llvm_config dflags (hsc_units hsc_env) cmm_mod output_filename no_loc foreign_stubs [] S.empty
             dus1 rawCmms
        return stub_c_exists
  where
    no_loc :: ModLocation
no_loc = OsPathModLocation
        { ml_hs_file_ospath :: Maybe OsPath
ml_hs_file_ospath  = OsPath -> Maybe OsPath
forall a. a -> Maybe a
Just (OsPath -> Maybe OsPath) -> OsPath -> Maybe OsPath
forall a b. (a -> b) -> a -> b
$ HasCallStack => [Char] -> OsPath
[Char] -> OsPath
unsafeEncodeUtf [Char]
original_filename,
          ml_hi_file_ospath :: OsPath
ml_hi_file_ospath  = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no hi file",
          ml_obj_file_ospath :: OsPath
ml_obj_file_ospath = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no obj file",
          ml_dyn_obj_file_ospath :: OsPath
ml_dyn_obj_file_ospath = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no dyn obj file",
          ml_dyn_hi_file_ospath :: OsPath
ml_dyn_hi_file_ospath  = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCmmFile: no dyn obj file",
          ml_hie_file_ospath :: OsPath
ml_hie_file_ospath = [Char] -> OsPath
forall a. HasCallStack => [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
          -> IO (CgStream 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]
-> IO
     (CgStream
        [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 = 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
        (StgPprOpts -> [CgStgTopBinding] -> SDoc
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]
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
stg_to_cmm DynFlags
dflags Module
mod InfoTableProvMap
a [TyCon]
b ([CostCentre], [CostCentreStack])
c [CgStgTopBinding]
d = case Hooks
-> Maybe
     (StgToCmmConfig
      -> InfoTableProvMap
      -> [TyCon]
      -> ([CostCentre], [CostCentreStack])
      -> [CgStgTopBinding]
      -> CgStream CmmGroup ModuleLFInfos)
stgToCmmHook Hooks
hooks of
          Maybe
  (StgToCmmConfig
   -> InfoTableProvMap
   -> [TyCon]
   -> ([CostCentre], [CostCentreStack])
   -> [CgStgTopBinding]
   -> CgStream CmmGroup ModuleLFInfos)
Nothing -> Logger
-> TmpFs
-> StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
StgToCmm.codeGen Logger
logger TmpFs
tmpfs (DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig DynFlags
dflags Module
mod) InfoTableProvMap
a [TyCon]
b ([CostCentre], [CostCentreStack])
c [CgStgTopBinding]
d
          Just StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> CgStream CmmGroup ModuleLFInfos
h  -> (,DetUniqFM
emptyDetUFM) (ModuleLFInfos -> (ModuleLFInfos, DetUniqFM))
-> CgStream CmmGroup ModuleLFInfos
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StgToCmmConfig
-> InfoTableProvMap
-> [TyCon]
-> ([CostCentre], [CostCentreStack])
-> [CgStgTopBinding]
-> CgStream CmmGroup ModuleLFInfos
h          (DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig DynFlags
dflags Module
mod) InfoTableProvMap
a [TyCon]
b ([CostCentre], [CostCentreStack])
c [CgStgTopBinding]
d

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

        -- 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 :: CmmGroup -> IO CmmGroup
dump1 CmmGroup
a = do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (CmmGroup -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null CmmGroup
a) (IO () -> IO ()) -> IO () -> IO ()
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 (Platform -> CmmGroup -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmGroup
a)
          CmmGroup -> IO CmmGroup
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmGroup
a

        ppr_stream1 :: CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
ppr_stream1 = (CmmGroup -> UniqDSMT IO CmmGroup)
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM (IO CmmGroup -> UniqDSMT IO CmmGroup
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO CmmGroup -> UniqDSMT IO CmmGroup)
-> (CmmGroup -> IO CmmGroup) -> CmmGroup -> UniqDSMT IO CmmGroup
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmGroup -> IO CmmGroup
dump1) CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
cmm_stream

        cmm_config :: CmmConfig
cmm_config = DynFlags -> CmmConfig
initCmmConfig DynFlags
dflags

        pipeline_stream :: CgStream CmmGroupSRTs CmmCgInfos
        pipeline_stream :: CgStream [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
pipeline_stream = do
          ((mod_srt_info, ipes, ipe_stats), (lf_infos, detRnEnv)) <-
            {-# SCC "cmmPipeline" #-}
            ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation),
  IPEStats)
 -> CmmGroup
 -> UniqDSMT
      IO
      ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation),
        IPEStats),
       [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]))
-> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation),
    IPEStats)
-> CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
-> Stream
     (UniqDSMT IO)
     [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
     ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation),
       IPEStats),
      (ModuleLFInfos, DetUniqFM))
forall (m :: * -> *) a b c r.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)
Stream.mapAccumL_ (Logger
-> CmmConfig
-> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation),
    IPEStats)
-> CmmGroup
-> UniqDSMT
     IO
     ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation),
       IPEStats),
      [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
pipeline_action Logger
logger CmmConfig
cmm_config) (Module -> ModuleSRTInfo
emptySRT Module
this_mod, Map CmmInfoTable (Maybe IpeSourceLocation)
forall k a. Map k a
M.empty, IPEStats
forall a. Monoid a => a
mempty) CgStream CmmGroup (ModuleLFInfos, DetUniqFM)
ppr_stream1

          let nonCaffySet = SRTMap -> NonCaffySet
srtMapNonCAFs (ModuleSRTInfo -> SRTMap
moduleSRTMap ModuleSRTInfo
mod_srt_info)

              -- denv::InfoTableProvMap refers to symbols that no longer exist
              -- if -fobject-determinism is on, since it was created before the
              -- Cmm was renamed. Update all the symbols by renaming them with
              -- the renaming map in that case.
              (_drn, rn_denv)
                | gopt Opt_ObjectDeterminism dflags = detRenameIPEMap detRnEnv denv
                | otherwise = (detRnEnv, denv)

          cmmCgInfos <- generateCgIPEStub hsc_env this_mod rn_denv (nonCaffySet, lf_infos, ipes, ipe_stats)
          return cmmCgInfos

        pipeline_action
          :: Logger
          -> CmmConfig
          -> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats)
          -> CmmGroup
          -> UniqDSMT IO ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation), IPEStats), CmmGroupSRTs)
        pipeline_action :: Logger
-> CmmConfig
-> (ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation),
    IPEStats)
-> CmmGroup
-> UniqDSMT
     IO
     ((ModuleSRTInfo, Map CmmInfoTable (Maybe IpeSourceLocation),
       IPEStats),
      [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
pipeline_action Logger
logger CmmConfig
cmm_config (ModuleSRTInfo
mod_srt_info, Map CmmInfoTable (Maybe IpeSourceLocation)
ipes, IPEStats
stats) CmmGroup
cmm_group = do
          (mod_srt_info', cmm_srts) <- (DUniqSupply
 -> IO
      ((ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]),
       DUniqSupply))
-> UniqDSMT
     IO (ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
forall a. (DUniqSupply -> IO (a, DUniqSupply)) -> UniqDSMT IO a
withDUS ((DUniqSupply
  -> IO
       ((ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]),
        DUniqSupply))
 -> UniqDSMT
      IO (ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]))
-> (DUniqSupply
    -> IO
         ((ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]),
          DUniqSupply))
-> UniqDSMT
     IO (ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
forall a b. (a -> b) -> a -> b
$ Logger
-> CmmConfig
-> ModuleSRTInfo
-> CmmGroup
-> DUniqSupply
-> IO
     ((ModuleSRTInfo, [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]),
      DUniqSupply)
cmmPipeline Logger
logger CmmConfig
cmm_config ModuleSRTInfo
mod_srt_info CmmGroup
cmm_group

          -- If -finfo-table-map is enabled, we precompute a map from info
          -- tables to source locations. See Note [Mapping Info Tables to Source
          -- Positions] in GHC.Stg.Debug.
          (ipes', stats') <-
            if (gopt Opt_InfoTableMap dflags) then
              liftIO $ lookupEstimatedTicks hsc_env ipes stats cmm_srts
            else
              return (ipes, stats)

          return ((mod_srt_info', ipes', stats'), cmm_srts)

        dump2 :: [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
dump2 [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a = do
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a) (IO () -> IO ()) -> IO () -> IO ()
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 (Platform -> [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a)
          [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
a

    CgStream [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
-> IO
     (CgStream
        [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CgStream [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
 -> IO
      (CgStream
         [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos))
-> CgStream
     [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
-> IO
     (CgStream
        [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos)
forall a b. (a -> b) -> a -> b
$ ([GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
 -> UniqDSMT IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
-> CgStream
     [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
-> CgStream
     [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
forall (m :: * -> *) a b x.
Monad m =>
(a -> m b) -> Stream m a x -> Stream m b x
Stream.mapM (IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> UniqDSMT IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
forall a. IO a -> UniqDSMT IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
 -> UniqDSMT IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
-> ([GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
    -> IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph])
-> [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> UniqDSMT IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
-> IO [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph]
dump2) CgStream [GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph] CmmCgInfos
pipeline_stream

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

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

    putDumpFileMaybe logger Opt_D_dump_stg_cg "CodeGenInput STG:" FormatSTG
        (pprGenStgTopBindings (initStgPprOpts dflags) (fmap fst stg_binds_with_fvs))

    return (stg_binds_with_fvs, denv, cost_centre_info, 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 =
  HscEnv
-> Hsc (Maybe ([Id], ForeignHValue, FixityEnv))
-> IO (Maybe ([Id], ForeignHValue, FixityEnv))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Maybe ([Id], ForeignHValue, FixityEnv))
 -> IO (Maybe ([Id], ForeignHValue, FixityEnv)))
-> Hsc (Maybe ([Id], ForeignHValue, FixityEnv))
-> IO (Maybe ([Id], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do
    maybe_stmt <- [Char] -> Int -> [Char] -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmtWithLocation [Char]
source Int
linenumber [Char]
stmt
    case maybe_stmt of
      Maybe
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
Nothing -> Maybe ([Id], ForeignHValue, FixityEnv)
-> Hsc (Maybe ([Id], ForeignHValue, FixityEnv))
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ([Id], ForeignHValue, FixityEnv)
forall a. Maybe a
Nothing

      Just GenLocated
  SrcSpanAnnA
  (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
parsed_stmt -> do
        hsc_env <- Hsc HscEnv
getHscEnv
        liftIO $ hscParsedStmt hsc_env 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 = HscEnv
-> Hsc (Maybe ([Id], ForeignHValue, FixityEnv))
-> IO (Maybe ([Id], ForeignHValue, FixityEnv))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Maybe ([Id], ForeignHValue, FixityEnv))
 -> IO (Maybe ([Id], ForeignHValue, FixityEnv)))
-> Hsc (Maybe ([Id], ForeignHValue, FixityEnv))
-> IO (Maybe ([Id], ForeignHValue, FixityEnv))
forall a b. (a -> b) -> a -> b
$ do
  -- Rename and typecheck it
  (ids, tc_expr, fix_env) <- IO (Messages GhcMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
-> Hsc ([Id], LHsExpr GhcTc, FixityEnv)
forall a. IO (Messages GhcMessage, Maybe a) -> Hsc a
ioMsgMaybe (IO (Messages GhcMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
 -> Hsc ([Id], LHsExpr GhcTc, FixityEnv))
-> IO (Messages GhcMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
-> Hsc ([Id], LHsExpr GhcTc, FixityEnv)
forall a b. (a -> b) -> a -> b
$ IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
-> IO (Messages GhcMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
forall (m :: * -> *) a.
Monad m =>
m (Messages TcRnMessage, a) -> m (Messages GhcMessage, a)
hoistTcRnMessage (IO (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
 -> IO
      (Messages GhcMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv)))
-> IO
     (Messages TcRnMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
-> IO (Messages GhcMessage, Maybe ([Id], LHsExpr GhcTc, FixityEnv))
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
  ds_expr <- ioMsgMaybe $ hoistDsMessage $ deSugarExpr hsc_env tc_expr
  liftIO (lintInteractiveExpr (text "desugar expression") hsc_env ds_expr)
  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 = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
  (hval,_,_) <- liftIO $ hscCompileCoreExpr hsc_env src_span ds_expr

  return $ Just (ids, hval, 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 GhcPs)
hscParseModuleWithLocation :: HscEnv -> [Char] -> Int -> [Char] -> IO (HsModule GhcPs)
hscParseModuleWithLocation HscEnv
hsc_env [Char]
source Int
line_num [Char]
str = do
    L _ mod <-
      HscEnv
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs)))
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$
        [Char]
-> Int
-> P (Located (HsModule GhcPs))
-> [Char]
-> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
[Char] -> Int -> P thing -> [Char] -> Hsc thing
hscParseThingWithLocation [Char]
source Int
line_num P (Located (HsModule GhcPs))
parseModule [Char]
str
    return 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 = decls } <- HscEnv -> [Char] -> Int -> [Char] -> IO (HsModule GhcPs)
hscParseModuleWithLocation HscEnv
hsc_env [Char]
source Int
line_num [Char]
str
  return 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 _ (HsModule{ hsmodDecls = decls }) <-
      HscEnv
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs)))
-> Hsc (Located (HsModule GhcPs)) -> IO (Located (HsModule GhcPs))
forall a b. (a -> b) -> a -> b
$
        [Char]
-> Int
-> P (Located (HsModule GhcPs))
-> [Char]
-> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
[Char] -> Int -> P thing -> [Char] -> Hsc thing
hscParseThingWithLocation [Char]
source Int
linenumber P (Located (HsModule GhcPs))
parseModule [Char]
str
    hscParsedDecls hsc_env decls

hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls :: HscEnv -> [LHsDecl GhcPs] -> IO ([TyThing], InteractiveContext)
hscParsedDecls HscEnv
hsc_env [LHsDecl GhcPs]
decls = HscEnv
-> Hsc ([TyThing], InteractiveContext)
-> IO ([TyThing], InteractiveContext)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc ([TyThing], InteractiveContext)
 -> IO ([TyThing], InteractiveContext))
-> Hsc ([TyThing], InteractiveContext)
-> IO ([TyThing], InteractiveContext)
forall a b. (a -> b) -> a -> b
$ do
    hsc_env <- Hsc HscEnv
getHscEnv
    let interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env

    {- Rename and typecheck it -}
    tc_gblenv <- ioMsgMaybe $ hoistTcRnMessage $ tcRnDeclsi hsc_env 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 = TcGblEnv -> DefaultEnv
tcg_default TcGblEnv
tc_gblenv

    {- Desugar it -}
    -- We use a basically null location for iNTERACTIVE
    let iNTERACTIVELoc = OsPathModLocation
            { ml_hs_file_ospath :: Maybe OsPath
ml_hs_file_ospath   = Maybe OsPath
forall a. Maybe a
Nothing,
              ml_hi_file_ospath :: OsPath
ml_hi_file_ospath   = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_hi_file_ospath",
              ml_obj_file_ospath :: OsPath
ml_obj_file_ospath  = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_obj_file_ospath",
              ml_dyn_obj_file_ospath :: OsPath
ml_dyn_obj_file_ospath = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_dyn_obj_file_ospath",
              ml_dyn_hi_file_ospath :: OsPath
ml_dyn_hi_file_ospath = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_dyn_hi_file_ospath",
              ml_hie_file_ospath :: OsPath
ml_hie_file_ospath  = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hsDeclsWithLocation:ml_hie_file_ospath" }
    ds_result <- hscDesugar' iNTERACTIVELoc tc_gblenv

    {- Simplify -}
    simpl_mg <- liftIO $ do
      plugins <- readIORef (tcg_th_coreplugins tc_gblenv)
      hscSimplify hsc_env plugins ds_result

    {- Tidy -}
    (tidy_cg, mod_details) <- liftIO $ hscTidy hsc_env simpl_mg

    let !CgGuts{ cg_module    = this_mod,
                 cg_binds     = core_binds
                 } = tidy_cg

        !ModDetails { md_insts     = cls_insts
                    , md_fam_insts = fam_insts } = mod_details
            -- Get the *tidied* cls_insts and fam_insts

    {- Generate byte code & foreign stubs -}
    linkable <- liftIO $ generateFreshByteCode hsc_env
      (moduleName this_mod)
      (mkCgInteractiveGuts tidy_cg)
      iNTERACTIVELoc

    let src_span = SrcLoc -> SrcSpan
srcLocSpan SrcLoc
interactiveSrcLoc
    _ <- liftIO $ loadDecls interp hsc_env src_span linkable

    {- Load static pointer table entries -}
    liftIO $ hscAddSptEntries hsc_env (cg_spt_entries tidy_cg)

    let tcs = (TyCon -> Bool) -> [TyCon] -> [TyCon]
forall a. (a -> Bool) -> [a] -> [a]
filterOut TyCon -> Bool
isImplicitTyCon (ModGuts -> [TyCon]
mg_tcs ModGuts
simpl_mg)
        patsyns = ModGuts -> [PatSyn]
mg_patsyns ModGuts
simpl_mg

        ext_ids = [ Id
id | Id
id <- CoreProgram -> [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 = (Id -> TyThing) -> [Id] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map Id -> TyThing
AnId [Id]
ext_ids [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (TyCon -> TyThing) -> [TyCon] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map TyCon -> TyThing
ATyCon [TyCon]
tcs [TyThing] -> [TyThing] -> [TyThing]
forall a. [a] -> [a] -> [a]
++ (PatSyn -> TyThing) -> [PatSyn] -> [TyThing]
forall a b. (a -> b) -> [a] -> [b]
map (ConLike -> TyThing
AConLike (ConLike -> TyThing) -> (PatSyn -> ConLike) -> PatSyn -> TyThing
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PatSyn -> ConLike
PatSynCon) [PatSyn]
patsyns
        ictxt        = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
        -- See Note [Fixity declarations in GHCi]
        fix_env      = TcGblEnv -> FixityEnv
tcg_fix_env TcGblEnv
tc_gblenv
        new_ictxt    = InteractiveContext
-> [TyThing]
-> InstEnv
-> [FamInst]
-> DefaultEnv
-> FixityEnv
-> InteractiveContext
extendInteractiveContext InteractiveContext
ictxt [TyThing]
new_tythings InstEnv
cls_insts
                                                [FamInst]
fam_insts DefaultEnv
defaults FixityEnv
fix_env
    return (new_tythings, 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
            (val, _, _) <- Interp
-> HscEnv -> Name -> IO (ForeignHValue, [Linkable], PkgsLoaded)
loadName Interp
interp HscEnv
hsc_env (Id -> Name
idName Id
i)
            addSptEntry interp fpr val
    (SptEntry -> IO ()) -> [SptEntry] -> IO ()
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 = HscEnv -> Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs))
-> Hsc (ImportDecl GhcPs) -> IO (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ do
    -- Use >>= \case instead of MonadFail desugaring to take into
    -- consideration `instance XXModule p = DataConCantHappen`.
    -- Tracked in #15681
    P (Located (HsModule GhcPs))
-> [Char] -> Hsc (Located (HsModule GhcPs))
forall thing.
(Outputable thing, Data thing) =>
P thing -> [Char] -> Hsc thing
hscParseThing P (Located (HsModule GhcPs))
parseModule [Char]
str Hsc (Located (HsModule GhcPs))
-> (Located (HsModule GhcPs) -> Hsc (ImportDecl GhcPs))
-> Hsc (ImportDecl GhcPs)
forall a b. Hsc a -> (a -> Hsc b) -> Hsc b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      (L SrcSpan
_ (HsModule{hsmodImports :: forall p. HsModule p -> [LImportDecl p]
hsmodImports=[LImportDecl GhcPs]
is})) ->
        case [LImportDecl GhcPs]
is of
            [L SrcSpanAnnA
_ ImportDecl GhcPs
i] -> ImportDecl GhcPs -> Hsc (ImportDecl GhcPs)
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return ImportDecl GhcPs
i
            [LImportDecl GhcPs]
_ -> IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs)
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs))
-> IO (ImportDecl GhcPs) -> Hsc (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$ MsgEnvelope GhcMessage -> IO (ImportDecl GhcPs)
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage -> IO (ImportDecl GhcPs))
-> MsgEnvelope GhcMessage -> IO (ImportDecl GhcPs)
forall a b. (a -> b) -> a -> b
$
                     SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
                     PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage) -> PsWarning -> GhcMessage
forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic (DiagnosticOpts PsWarning) -> PsWarning
PsUnknownMessage (UnknownDiagnostic (DiagnosticOpts PsWarning) -> PsWarning)
-> UnknownDiagnostic (DiagnosticOpts PsWarning) -> PsWarning
forall a b. (a -> b) -> a -> b
$
                     DiagnosticMessage -> UnknownDiagnostic (DiagnosticOpts PsWarning)
forall a b.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic (DiagnosticMessage -> UnknownDiagnostic (DiagnosticOpts PsWarning))
-> DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts PsWarning)
forall a b. (a -> b) -> a -> b
$
                      [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
                         [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
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 Type
hscTcExpr HscEnv
hsc_env0 TcRnExprMode
mode [Char]
expr = HscEnv -> Hsc Type -> IO Type
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc Type -> IO Type) -> Hsc Type -> IO Type
forall a b. (a -> b) -> a -> b
$ do
  hsc_env <- Hsc HscEnv
getHscEnv
  parsed_expr <- hscParseExpr expr
  ioMsgMaybe $ hoistTcRnMessage $ tcRnExpr hsc_env mode 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 (Type, Type)
hscKcType HscEnv
hsc_env0 Bool
normalise [Char]
str = HscEnv -> Hsc (Type, Type) -> IO (Type, Type)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env0 (Hsc (Type, Type) -> IO (Type, Type))
-> Hsc (Type, Type) -> IO (Type, Type)
forall a b. (a -> b) -> a -> b
$ do
    hsc_env <- Hsc HscEnv
getHscEnv
    ty <- hscParseType str
    ioMsgMaybe $ hoistTcRnMessage $ tcRnType hsc_env DefaultFlexi normalise ty

hscParseExpr :: String -> Hsc (LHsExpr GhcPs)
hscParseExpr :: [Char] -> Hsc (LHsExpr GhcPs)
hscParseExpr [Char]
expr = do
  maybe_stmt <- [Char] -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt [Char]
expr
  case maybe_stmt of
    Just (L SrcSpanAnnA
_ (BodyStmt XBodyStmt GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))
_ GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr SyntaxExpr GhcPs
_ SyntaxExpr GhcPs
_)) -> GenLocated SrcSpanAnnA (HsExpr GhcPs)
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a. a -> Hsc a
forall (m :: * -> *) a. Monad m => a -> m a
return GenLocated SrcSpanAnnA (HsExpr GhcPs)
expr
    Maybe
  (GenLocated
     SrcSpanAnnA
     (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs))))
_ -> MsgEnvelope GhcMessage
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall (io :: * -> *) a.
MonadIO io =>
MsgEnvelope GhcMessage -> io a
throwOneError (MsgEnvelope GhcMessage
 -> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs)))
-> MsgEnvelope GhcMessage
-> Hsc (GenLocated SrcSpanAnnA (HsExpr GhcPs))
forall a b. (a -> b) -> a -> b
$
           SrcSpan -> GhcMessage -> MsgEnvelope GhcMessage
forall e. Diagnostic e => SrcSpan -> e -> MsgEnvelope e
mkPlainErrorMsgEnvelope SrcSpan
noSrcSpan (GhcMessage -> MsgEnvelope GhcMessage)
-> GhcMessage -> MsgEnvelope GhcMessage
forall a b. (a -> b) -> a -> b
$
           PsWarning -> GhcMessage
GhcPsMessage (PsWarning -> GhcMessage) -> PsWarning -> GhcMessage
forall a b. (a -> b) -> a -> b
$ UnknownDiagnostic (DiagnosticOpts PsWarning) -> PsWarning
PsUnknownMessage
             (UnknownDiagnostic (DiagnosticOpts PsWarning) -> PsWarning)
-> UnknownDiagnostic (DiagnosticOpts PsWarning) -> PsWarning
forall a b. (a -> b) -> a -> b
$ DiagnosticMessage -> UnknownDiagnostic (DiagnosticOpts PsWarning)
forall a b.
(Diagnostic a, Typeable a, DiagnosticOpts a ~ NoDiagnosticOpts) =>
a -> UnknownDiagnostic b
mkSimpleUnknownDiagnostic
             (DiagnosticMessage -> UnknownDiagnostic (DiagnosticOpts PsWarning))
-> DiagnosticMessage
-> UnknownDiagnostic (DiagnosticOpts PsWarning)
forall a b. (a -> b) -> a -> b
$ [GhcHint] -> SDoc -> DiagnosticMessage
mkPlainError [GhcHint]
noHints (SDoc -> DiagnosticMessage) -> SDoc -> DiagnosticMessage
forall a b. (a -> b) -> a -> b
$
             [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"not an expression:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
quotes ([Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
expr)

hscParseStmt :: String -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt :: [Char] -> Hsc (Maybe (GhciLStmt GhcPs))
hscParseStmt = P (Maybe
     (GenLocated
        SrcSpanAnnA
        (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Char]
-> Hsc
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
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 =
    [Char]
-> Int
-> P (Maybe
        (GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
-> [Char]
-> Hsc
     (Maybe
        (GenLocated
           SrcSpanAnnA
           (StmtLR GhcPs GhcPs (GenLocated SrcSpanAnnA (HsExpr GhcPs)))))
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 = P (GenLocated SrcSpanAnnA (HsType GhcPs))
-> [Char] -> Hsc (GenLocated SrcSpanAnnA (HsType GhcPs))
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 =
    HscEnv -> Hsc (LocatedN RdrName) -> IO (LocatedN RdrName)
forall a. HscEnv -> Hsc a -> IO a
runInteractiveHsc HscEnv
hsc_env (Hsc (LocatedN RdrName) -> IO (LocatedN RdrName))
-> Hsc (LocatedN RdrName) -> IO (LocatedN RdrName)
forall a b. (a -> b) -> a -> b
$ P (LocatedN RdrName) -> [Char] -> Hsc (LocatedN RdrName)
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 = [Char] -> Int -> P thing -> [Char] -> Hsc thing
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
    dflags <- Hsc DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
    logger <- getLogger
    withTiming logger
               (text "Parser [source]")
               (const ()) $ {-# SCC "Parser" #-} do

        let buf = [Char] -> StringBuffer
stringToStringBuffer [Char]
str
            loc = FastString -> Int -> Int -> RealSrcLoc
mkRealSrcLoc ([Char] -> FastString
fsLit [Char]
source) Int
linenumber Int
1

        case unP parser (initParserState (initParserOpts dflags) buf loc) of
            PFailed PState
pst ->
                (Messages PsWarning, Messages PsWarning) -> Hsc thing
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)
                IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
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 (thing -> SDoc
forall a. Outputable a => a -> SDoc
ppr thing
thing)
                IO () -> Hsc ()
forall a. IO a -> Hsc a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Hsc ()) -> IO () -> Hsc ()
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 (BlankSrcSpan -> BlankEpAnnotations -> thing -> SDoc
forall a. Data a => BlankSrcSpan -> BlankEpAnnotations -> a -> SDoc
showAstData BlankSrcSpan
NoBlankSrcSpan BlankEpAnnotations
NoBlankEpAnnotations thing
thing)
                thing -> Hsc thing
forall a. a -> Hsc a
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

  opts <- HscEnv -> IO TidyOpts
initTidyOpts HscEnv
hsc_env
  (cgguts, details) <- withTiming logger
    (text "CoreTidy"<+>brackets (ppr this_mod))
    (const ())
    $! {-# SCC "CoreTidy" #-} tidyProgram opts guts

  -- post tidy pretty-printing and linting...
  let tidy_rules     = ModDetails -> [CoreRule]
md_rules ModDetails
details
  let all_tidy_binds = CgGuts -> CoreProgram
cg_binds CgGuts
cgguts
  let name_ppr_ctx   = PromotionTickContext -> UnitEnv -> GlobalRdrEnv -> NamePprCtx
forall info.
Outputable info =>
PromotionTickContext -> UnitEnv -> GlobalRdrEnvX info -> NamePprCtx
mkNamePprCtx PromotionTickContext
ptc (HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env) (ModGuts -> GlobalRdrEnv
mg_rdr_env ModGuts
guts)
      ptc            = DynFlags -> PromotionTickContext
initPromotionTickContext (HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env)

  endPassHscEnvIO hsc_env name_ppr_ctx CoreTidy all_tidy_binds tidy_rules

  -- If the endPass didn't print the rules, but ddump-rules is
  -- on, print now
  unless (logHasDumpFlag logger Opt_D_dump_simpl) $
    putDumpFileMaybe logger Opt_D_dump_rules
      "Tidy Core rules"
      FormatText
      (pprRulesForUser tidy_rules)

  -- Print one-line size info
  let cs = CoreProgram -> CoreStats
coreBindsStats CoreProgram
all_tidy_binds
  putDumpFileMaybe logger Opt_D_dump_core_stats "Core Stats"
    FormatText
    (text "Tidy size (terms,types,coercions)"
     <+> ppr (moduleName this_mod) <> colon
     <+> int (cs_tm cs)
     <+> int (cs_ty cs)
     <+> int (cs_co cs))

  pure (cgguts, details)


{- **********************************************************************
%*                                                                      *
        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.
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
  let ic :: InteractiveContext
ic = HscEnv -> InteractiveContext
hsc_IC HscEnv
hsc_env
  let unit_env :: UnitEnv
unit_env = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
  let simplify_expr_opts :: SimplifyExprOpts
simplify_expr_opts = DynFlags -> InteractiveContext -> SimplifyExprOpts
initSimplifyExprOpts DynFlags
dflags InteractiveContext
ic

  simpl_expr <- Logger
-> ExternalUnitCache -> SimplifyExprOpts -> CoreExpr -> IO CoreExpr
simplifyExpr Logger
logger (UnitEnv -> ExternalUnitCache
ue_eps UnitEnv
unit_env) SimplifyExprOpts
simplify_expr_opts CoreExpr
ds_expr

  -- Create a unique temporary binding
  --
  -- The id has to be exported for the JS backend. This isn't required for the
  -- byte-code interpreter but it does no harm to always do it.
  u <- uniqFromTag 'I'
  let binding_name = Unique -> FastString -> Name
mkSystemVarName Unique
u ([Char] -> FastString
fsLit ([Char]
"BCO_toplevel"))
  let binding_id   = Name -> Type -> Id
mkExportedVanillaId Name
binding_name (HasDebugCallStack => CoreExpr -> Type
CoreExpr -> Type
exprType CoreExpr
simpl_expr)

  {- Tidy it (temporary, until coreSat does cloning) -}
  let tidy_occ_env = [OccName] -> TidyOccEnv
initTidyOccEnv [Id -> OccName
forall name. HasOccName name => name -> OccName
occName Id
binding_id]
  let tidy_env     = TidyOccEnv -> TidyEnv
mkEmptyTidyEnv TidyOccEnv
tidy_occ_env
  let tidy_expr    = TidyEnv -> CoreExpr -> CoreExpr
tidyExpr TidyEnv
tidy_env CoreExpr
simpl_expr

  {- Prepare for codegen -}
  cp_cfg <- initCorePrepConfig hsc_env
  prepd_expr <- corePrepExpr
   logger cp_cfg
   tidy_expr

  {- Lint if necessary -}
  lintInteractiveExpr (text "hscCompileCoreExpr") hsc_env prepd_expr
  let this_loc = OsPathModLocation
          { ml_hs_file_ospath :: Maybe OsPath
ml_hs_file_ospath   = Maybe OsPath
forall a. Maybe a
Nothing,
            ml_hi_file_ospath :: OsPath
ml_hi_file_ospath   = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_hi_file_ospath",
            ml_obj_file_ospath :: OsPath
ml_obj_file_ospath  = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_obj_file_ospath",
            ml_dyn_obj_file_ospath :: OsPath
ml_dyn_obj_file_ospath = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr': ml_obj_file_ospath",
            ml_dyn_hi_file_ospath :: OsPath
ml_dyn_hi_file_ospath  = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr': ml_dyn_hi_file_ospath",
            ml_hie_file_ospath :: OsPath
ml_hie_file_ospath  = [Char] -> OsPath
forall a. HasCallStack => [Char] -> a
panic [Char]
"hscCompileCoreExpr':ml_hie_file_ospath" }

  -- Ensure module uniqueness by giving it a name like "GhciNNNN".
  -- This uniqueness is needed by the JS linker. Without it we break the 1-1
  -- relationship between modules and object files, i.e. we get different object
  -- files for the same module and the JS linker doesn't support this.
  --
  -- Note that we can't use icInteractiveModule because the ic_mod_index value
  -- isn't bumped between invocations of hscCompileCoreExpr, so uniqueness isn't
  -- guaranteed.
  --
  -- We reuse the unique we obtained for the binding, but any unique would do.
  let this_mod = [Char] -> Module
mkInteractiveModule (Unique -> [Char]
forall a. Show a => a -> [Char]
show Unique
u)
  let for_bytecode = Bool
True

  (stg_binds_with_deps, _prov_map, _collected_ccs, _stg_cg_infos) <-
       myCoreToStg logger
                   dflags
                   (interactiveInScope (hsc_IC hsc_env))
                   for_bytecode
                   this_mod
                   this_loc
                   [NonRec binding_id prepd_expr]

  let (stg_binds, _stg_deps) = unzip stg_binds_with_deps

  let interp = HscEnv -> Interp
hscInterp HscEnv
hsc_env

  case interp of
    -- always generate JS code for the JS interpreter (no bytecode!)
    Interp (ExternalInterp (ExtJS JSInterp
i)) Loader
_ MVar (UniqFM FastString (Ptr ()))
_ ->
      HscEnv
-> SrcSpan
-> JSInterp
-> Module
-> [(CgStgTopBinding, IdSet)]
-> Id
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
jsCodeGen HscEnv
hsc_env SrcSpan
srcspan JSInterp
i Module
this_mod [(CgStgTopBinding, IdSet)]
stg_binds_with_deps Id
binding_id

    Interp
_ -> do
      {- Convert to BCOs -}
      bcos <- HscEnv
-> Module
-> [CgStgTopBinding]
-> [TyCon]
-> Maybe ModBreaks
-> [SptEntry]
-> IO CompiledByteCode
byteCodeGen HscEnv
hsc_env
                Module
this_mod
                [CgStgTopBinding]
stg_binds
                []
                Maybe ModBreaks
forall a. Maybe a
Nothing -- modbreaks
                [] -- spt entries

      {- load it -}
      bco_time <- getCurrentTime
      (fv_hvs, mods_needed, units_needed) <- loadDecls interp hsc_env srcspan $
        Linkable bco_time this_mod $ NE.singleton $ BCOs bcos
      {- Get the HValue for the root -}
      return (expectJust "hscCompileCoreExpr'"
         $ lookup (idName binding_id) fv_hvs, mods_needed, units_needed)



-- | Generate JS code for the given bindings and return the HValue for the given id
jsCodeGen
  :: HscEnv
  -> SrcSpan
  -> JSInterp
  -> Module
  -> [(CgStgTopBinding,IdSet)]
  -> Id
  -> IO (ForeignHValue, [Linkable], PkgsLoaded)
jsCodeGen :: HscEnv
-> SrcSpan
-> JSInterp
-> Module
-> [(CgStgTopBinding, IdSet)]
-> Id
-> IO (ForeignHValue, [Linkable], PkgsLoaded)
jsCodeGen HscEnv
hsc_env SrcSpan
srcspan JSInterp
i Module
this_mod [(CgStgTopBinding, IdSet)]
stg_binds_with_deps Id
binding_id = do
  let logger :: Logger
logger           = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
      tmpfs :: TmpFs
tmpfs            = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
      dflags :: DynFlags
dflags           = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      interp :: Interp
interp           = HscEnv -> Interp
hscInterp HscEnv
hsc_env
      tmp_dir :: TempDir
tmp_dir          = DynFlags -> TempDir
tmpDir DynFlags
dflags
      unit_env :: UnitEnv
unit_env         = HscEnv -> UnitEnv
hsc_unit_env HscEnv
hsc_env
      js_config :: StgToJSConfig
js_config        = DynFlags -> StgToJSConfig
initStgToJSConfig DynFlags
dflags

  -- We need to load all the dependencies first.
  --
  -- We get all the imported names from the Stg bindings and load their modules.
  --
  -- (logic adapted from GHC.Linker.Loader.loadDecls for the JS linker)
  let
    ([CgStgTopBinding]
stg_binds, [IdSet]
stg_deps) = [(CgStgTopBinding, IdSet)] -> ([CgStgTopBinding], [IdSet])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CgStgTopBinding, IdSet)]
stg_binds_with_deps
    imported_ids :: [Id]
imported_ids   = IdSet -> [Id]
forall elt. UniqSet elt -> [elt]
nonDetEltsUniqSet ([IdSet] -> IdSet
unionVarSets [IdSet]
stg_deps)
    imported_names :: [Name]
imported_names = (Id -> Name) -> [Id] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map Id -> Name
idName [Id]
imported_ids

    needed_mods :: [Module]
    needed_mods :: [Module]
needed_mods = [ HasDebugCallStack => Name -> Module
Name -> Module
nameModule Name
n | Name
n <- [Name]
imported_names,
                    Name -> Bool
isExternalName Name
n,       -- Names from other modules
                    Bool -> Bool
not (Name -> Bool
isWiredInName Name
n)   -- Exclude wired-in names
                  ]                         -- (see note below)
    -- Exclude wired-in names because we may not have read
    -- their interface files, so getLinkDeps will fail
    -- All wired-in names are in the base package, which we link
    -- by default, so we can safely ignore them here.

  -- Initialise the linker (if it's not been done already)
  Interp -> HscEnv -> IO ()
initLoaderState Interp
interp HscEnv
hsc_env

  -- Take lock for the actual work.
  (dep_linkables, dep_units) <- Interp
-> (LoaderState -> IO (LoaderState, ([Linkable], PkgsLoaded)))
-> IO ([Linkable], PkgsLoaded)
forall a. Interp -> (LoaderState -> IO (LoaderState, a)) -> IO a
modifyLoaderState Interp
interp ((LoaderState -> IO (LoaderState, ([Linkable], PkgsLoaded)))
 -> IO ([Linkable], PkgsLoaded))
-> (LoaderState -> IO (LoaderState, ([Linkable], PkgsLoaded)))
-> IO ([Linkable], PkgsLoaded)
forall a b. (a -> b) -> a -> b
$ \LoaderState
pls -> do
    let link_opts :: LinkDepsOpts
link_opts = HscEnv -> LinkDepsOpts
initLinkDepsOpts HscEnv
hsc_env

    -- Find what packages and linkables are required
    deps <- LinkDepsOpts
-> Interp -> LoaderState -> SrcSpan -> [Module] -> IO LinkDeps
getLinkDeps LinkDepsOpts
link_opts Interp
interp LoaderState
pls SrcSpan
srcspan [Module]
needed_mods
    -- We update the LinkerState even if the JS interpreter maintains its linker
    -- state independently to load new objects here.

    let objs = (Linkable -> Maybe Linkable) -> [Linkable] -> [Linkable]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Linkable -> Maybe Linkable
linkableFilterNative (LinkDeps -> [Linkable]
ldNeededLinkables LinkDeps
deps)
        (objs_loaded', _new_objs) = rmDupLinkables (objs_loaded pls) objs

    -- FIXME: we should make the JS linker load new_objs here, instead of
    -- on-demand.

    -- FIXME: we don't report needed units because we would have to find a way
    -- to build a meaningful LoadedPkgInfo (see the mess in
    -- GHC.Linker.Loader.{loadPackage,loadPackages'}). Detecting what to load
    -- and actually loading (using the native interpreter) are intermingled, so
    -- we can't directly reuse this code.
    let pls' = LoaderState
pls { objs_loaded = objs_loaded' }
    pure (pls', (ldAllLinkables deps, emptyUDFM {- ldNeededUnits deps -}) )


  let foreign_stubs    = ForeignStubs
NoStubs
      spt_entries      = [SptEntry]
forall a. Monoid a => a
mempty
      cost_centre_info = ([CostCentre], [CostCentreStack])
forall a. Monoid a => a
mempty

  -- codegen into object file whose path is in out_obj
  out_obj <- newTempName logger tmpfs tmp_dir TFL_CurrentModule "o"
  stgToJS logger js_config stg_binds this_mod spt_entries foreign_stubs cost_centre_info out_obj

  let TxtI id_sym = makeIdentForId binding_id Nothing IdPlain this_mod
  -- link code containing binding "id_sym = expr", using id_sym as root
  withJSInterp i $ \ExtInterpInstance JSInterpExtra
inst -> do
    let roots :: [ExportedFun]
roots = Module -> [FastString] -> [ExportedFun]
mkExportedModFuns Module
this_mod [FastString
id_sym]
    Logger
-> TmpFs
-> TempDir
-> StgToJSConfig
-> UnitEnv
-> ExtInterpInstance JSInterpExtra
-> [Char]
-> [ExportedFun]
-> IO ()
jsLinkObject Logger
logger TmpFs
tmpfs TempDir
tmp_dir StgToJSConfig
js_config UnitEnv
unit_env ExtInterpInstance JSInterpExtra
inst [Char]
out_obj [ExportedFun]
roots

  -- look up "id_sym" closure and create a StablePtr (HValue) from it
  href <- lookupClosure interp (unpackFS id_sym) >>= \case
    Maybe HValueRef
Nothing -> [Char] -> SDoc -> IO HValueRef
forall a. HasCallStack => [Char] -> SDoc -> a
pprPanic [Char]
"Couldn't find just linked TH closure" (FastString -> SDoc
forall a. Outputable a => a -> SDoc
ppr FastString
id_sym)
    Just HValueRef
r  -> HValueRef -> IO HValueRef
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HValueRef
r

  binding_fref <- withJSInterp i $ \ExtInterpInstance JSInterpExtra
inst ->
                    HValueRef -> IO () -> IO ForeignHValue
forall a. RemoteRef a -> IO () -> IO (ForeignRef a)
mkForeignRef HValueRef
href (ExtInterpInstance JSInterpExtra -> HValueRef -> IO ()
forall d a. ExtInterpInstance d -> RemoteRef a -> IO ()
freeReallyRemoteRef ExtInterpInstance JSInterpExtra
inst HValueRef
href)

  return (castForeignRef binding_fref, dep_linkables, dep_units)


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

dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats :: HscEnv -> IO ()
dumpIfaceStats HscEnv
hsc_env = do
  eps <- HscEnv -> IO ExternalPackageState
hscEPS HscEnv
hsc_env
  let
    logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
    dump_rn_stats = Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_rn_stats
    dump_if_trace = Logger -> DumpFlag -> Bool
logHasDumpFlag Logger
logger DumpFlag
Opt_D_dump_if_trace
  when (dump_if_trace || dump_rn_stats) $
    logDumpMsg logger "Interface statistics" (ifaceStats eps)


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

showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex :: (Int, Int) -> SDoc
showModuleIndex (Int
i,Int
n) = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"[" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
pad SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
" of " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text [Char]
"] "
  where
    -- compute the length of x > 0 in base 10
    len :: a -> b
len a
x = Float -> b
forall b. Integral b => Float -> b
forall a b. (RealFrac a, Integral b) => a -> b
ceiling (Float -> Float -> Float
forall a. Floating a => a -> a -> a
logBase Float
10 (a -> Float
forall a b. (Integral a, Num b) => a -> b
fromIntegral a
xFloat -> Float -> Float
forall a. Num a => a -> a -> a
+Float
1) :: Float)
    pad :: SDoc
pad = [Char] -> SDoc
forall doc. IsLine doc => [Char] -> doc
text (Int -> Char -> [Char]
forall a. Int -> a -> [a]
replicate (Int -> Int
forall {b} {a}. (Integral b, Integral a) => a -> b
len Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int -> Int
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
&&
 Bool -> Bool
not (Backend -> Bool
backendGeneratesCode (DynFlags -> Backend
backend DynFlags
dflags))