-- Utilities for creating bytecode libraries
module GHC.Linker.ByteCode where

import GHC.Prelude
import GHC.ByteCode.Serialize
import GHC.Driver.Session
import GHC.Utils.Error
import GHC.Driver.Env
import GHC.Utils.Outputable
import GHC.Linker.Loader
import Data.List (partition)
import GHC.Driver.Phases (isBytecodeFilename)
import GHC.Runtime.Interpreter (interpreterDynamic)
import Data.Maybe


linkBytecodeLib :: HscEnv -> [ModuleByteCode] -> IO ()
linkBytecodeLib :: HscEnv -> [ModuleByteCode] -> IO ()
linkBytecodeLib HscEnv
hsc_env [ModuleByteCode]
gbcs = do
  let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
  -- The .gbc files from the command line
  let fileArguments :: [String]
fileArguments = [String
f | FileOption String
_ String
f <- DynFlags -> [Option]
ldInputs DynFlags
dflags]

  let ([String]
bytecodeObjects, [String]
objectFiles) = (String -> Bool) -> [String] -> ([String], [String])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition String -> Bool
isBytecodeFilename [String]
fileArguments

  let logger :: Logger
logger = HscEnv -> Logger
hsc_logger HscEnv
hsc_env
  let allFiles :: [SDoc]
allFiles = ((String -> SDoc) -> [String] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map String -> SDoc
forall doc. IsLine doc => String -> doc
text [String]
bytecodeObjects) [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [ SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
angleBrackets (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"in-memory" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>  Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModuleByteCode -> Module
gbc_module ModuleByteCode
bco)) | ModuleByteCode
bco <- [ModuleByteCode]
gbcs ]
  Logger -> Int -> SDoc -> IO ()
debugTraceMsg Logger
logger Int
2 (SDoc -> IO ()) -> SDoc -> IO ()
forall a b. (a -> b) -> a -> b
$
    String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"linkBytecodeLib: linking the following bytecode objects:" SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$
    [SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat [SDoc]
allFiles


  on_disk_bcos <- (String -> IO ModuleByteCode) -> [String] -> IO [ModuleByteCode]
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) -> [a] -> m [b]
mapM (HscEnv -> String -> IO ModuleByteCode
readBinByteCode HscEnv
hsc_env) [String]
bytecodeObjects

  let (all_cbcs, foreign_stubs) = unzip [ (bs, fs) | ModuleByteCode _m bs fs <- on_disk_bcos ++ gbcs]

  interpreter_foreign_lib <- mkInterpreterLib hsc_env (concat foreign_stubs ++ objectFiles)

  let bytecodeLib' = BytecodeLib {
    bytecodeLibUnitId :: UnitId
bytecodeLibUnitId = DynFlags -> UnitId
homeUnitId_ DynFlags
dflags,
    bytecodeLibFiles :: [CompiledByteCode]
bytecodeLibFiles = [CompiledByteCode]
all_cbcs,
    bytecodeLibForeign :: Maybe InterpreterLibrary
bytecodeLibForeign = Maybe InterpreterLibrary
interpreter_foreign_lib
  }
  let output_fn = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe String
"a.out" (DynFlags -> Maybe String
outputFile DynFlags
dflags)
  writeBytecodeLib bytecodeLib' output_fn
  return ()


-- | Build a library suitable for loading into the interpreter.
--
-- This uses similar logic to how foreign stubs are compiler specifically for
-- a specific interpeter way. If the interpreter is dynamic, we create a shared library
-- and if it's static, create a static archive.
--
-- The objects which we use will already be compiled for this scheme.
-- It doesn't appear exactly right to use interpreterDynamic here, but it's what
-- is currently done for foreign stubs in GHC.Driver.ByteCode.
-- Perhaps instead we should look at the build way to determine which kind of library to create.
mkInterpreterLib :: HscEnv -> [FilePath] -> IO (Maybe InterpreterLibrary)
mkInterpreterLib :: HscEnv -> [String] -> IO (Maybe InterpreterLibrary)
mkInterpreterLib HscEnv
hsc_env [String]
files =
  case Interp -> Bool
interpreterDynamic (HscEnv -> Interp
hscInterp HscEnv
hsc_env) of
    Bool
True -> do
      -- I'm not sure that mkDynLoadLib is exactly the right way to create a shared library for the foreign stubs,
      -- It is something we can improve later based on feedback from users.
      foreign_stub_lib <- HscEnv
-> (Ways -> Ways)
-> [(String, String)]
-> [UnitId]
-> [String]
-> IO (Maybe (String, String, String))
mkDynLoadLib HscEnv
hsc_env Ways -> Ways
forall a. a -> a
id [] [] [String]
files
      case foreign_stub_lib of
        Just (String
foreign_stub_lib_path, String
foreign_stub_lib_dir, String
foreign_stub_lib_name) -> do
          Maybe InterpreterLibrary -> IO (Maybe InterpreterLibrary)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe InterpreterLibrary -> IO (Maybe InterpreterLibrary))
-> Maybe InterpreterLibrary -> IO (Maybe InterpreterLibrary)
forall a b. (a -> b) -> a -> b
$ InterpreterLibrary -> Maybe InterpreterLibrary
forall a. a -> Maybe a
Just (String -> String -> String -> InterpreterLibrary
InterpreterSharedObject String
foreign_stub_lib_path String
foreign_stub_lib_dir String
foreign_stub_lib_name)
        Maybe (String, String, String)
Nothing -> Maybe InterpreterLibrary -> IO (Maybe InterpreterLibrary)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe InterpreterLibrary
forall a. Maybe a
Nothing
    Bool
False -> do
      Maybe InterpreterLibrary -> IO (Maybe InterpreterLibrary)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe InterpreterLibrary -> IO (Maybe InterpreterLibrary))
-> Maybe InterpreterLibrary -> IO (Maybe InterpreterLibrary)
forall a b. (a -> b) -> a -> b
$ InterpreterLibrary -> Maybe InterpreterLibrary
forall a. a -> Maybe a
Just ([String] -> InterpreterLibrary
InterpreterStaticObjects [String]
files)