module GHC.Driver.ByteCode where


import GHC.Prelude

import GHC.Driver.Session
import GHC.Driver.CodeOutput
import GHC.Driver.Env
import GHC.Runtime.Interpreter
import GHC.Tc.Utils.Monad

import GHC.Unit
import GHC.Types.ForeignStubs
import GHC.Data.Maybe

import {-# SOURCE #-} GHC.Driver.Pipeline

import GHC.Platform.Ways


-- | Write foreign sources and foreign stubs to temporary files and compile them.
outputAndCompileForeign :: HscEnv -> Module -> ModLocation -> [(ForeignSrcLang, FilePath)] ->  ForeignStubs -> IO [FilePath]
outputAndCompileForeign :: HscEnv
-> Module
-> ModLocation
-> [(ForeignSrcLang, FilePath)]
-> ForeignStubs
-> IO [FilePath]
outputAndCompileForeign HscEnv
hsc_env Module
mod_name ModLocation
location [(ForeignSrcLang, FilePath)]
foreign_files ForeignStubs
foreign_stubs = do
  let dflags :: DynFlags
dflags   = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
      logger :: Logger
logger   = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
      tmpfs :: TmpFs
tmpfs    = HscEnv -> TmpFs
hsc_tmpfs HscEnv
hsc_env
  (_, has_stub) <- Logger
-> TmpFs
-> DynFlags
-> UnitState
-> Module
-> ModLocation
-> ForeignStubs
-> IO (Bool, Maybe FilePath)
outputForeignStubs Logger
logger TmpFs
tmpfs DynFlags
dflags (HasDebugCallStack => HscEnv -> UnitState
HscEnv -> UnitState
hsc_units HscEnv
hsc_env) Module
mod_name ModLocation
location ForeignStubs
foreign_stubs
  compile_for_interpreter hsc_env $ \ HscEnv
i_env -> do
    stub_o <- (FilePath -> IO FilePath) -> Maybe FilePath -> IO (Maybe FilePath)
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 -> FilePath -> IO FilePath
compileForeign HscEnv
i_env ForeignSrcLang
LangC) Maybe FilePath
has_stub
    foreign_files_o <- traverse (uncurry (compileForeign i_env)) foreign_files
    pure (maybeToList stub_o ++ foreign_files_o)

-- | 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