{-# LANGUAGE CPP #-}
{-# LANGUAGE RecordWildCards #-}
module Data.Array.Accelerate.LLVM.Native.Plugin (
plugin,
) where
import GhcPlugins
import Linker
import SysTools
import Control.Monad
import Data.IORef
import Data.List
import qualified Data.Map as Map
import Data.Array.Accelerate.LLVM.Native.Plugin.Annotation
import Data.Array.Accelerate.LLVM.Native.Plugin.BuildInfo
plugin :: Plugin
plugin = defaultPlugin
{ installCoreToDos = install
}
install :: [CommandLineOption] -> [CoreToDo] -> CoreM [CoreToDo]
install _ rest = do
#if __GLASGOW_HASKELL__ < 802
reinitializeGlobals
#endif
let this (CoreDoPluginPass "accelerate-llvm-native" _) = True
this _ = False
return $ CoreDoPluginPass "accelerate-llvm-native" pass : filter (not . this) rest
pass :: ModGuts -> CoreM ModGuts
pass guts = do
hscEnv <- getHscEnv
dynFlags <- getDynFlags
this <- getModule
paths <- nub . concat <$> mapM (objectPaths guts) (mg_binds guts)
when (not (null paths))
$ debugTraceMsg
$ hang (text "Data.Array.Accelerate.LLVM.Native.Plugin: linking module" <+> quotes (pprModule this) <+> text "with:") 2 (vcat (map text paths))
case hscTarget dynFlags of
HscNothing -> return ()
HscInterpreted ->
when (not (null paths)) . liftIO $ do
let opts = ldInputs dynFlags
objs = map optionOfPath paths
linkCmdLineLibs
#if __GLASGOW_HASKELL__ < 800
$ dynFlags { ldInputs = opts ++ objs }
#else
$ hscEnv { hsc_dflags = dynFlags { ldInputs = opts ++ objs }}
#endif
_ -> liftIO $ do
let buildInfo = mkBuildInfoFileName (objectMapPath dynFlags)
abi <- readBuildInfo buildInfo
let abi' = if null paths
then Map.delete this abi
else Map.insert this paths abi
allPaths = nub (concat (Map.elems abi'))
allObjs = map optionOfPath allPaths
writeBuildInfo buildInfo abi'
when (not (isNoLink (ghcLink dynFlags))) $ do
linker_info <- getLinkerInfo dynFlags
writeIORef (rtldInfo dynFlags)
$ Just
$ case linker_info of
GnuLD opts -> GnuLD (nub (opts ++ allObjs))
GnuGold opts -> GnuGold (nub (opts ++ allObjs))
DarwinLD opts -> DarwinLD (nub (opts ++ allObjs))
SolarisLD opts -> SolarisLD (nub (opts ++ allObjs))
#if __GLASGOW_HASKELL__ >= 800
AixLD opts -> AixLD (nub (opts ++ allObjs))
#endif
UnknownLD -> UnknownLD
return ()
return guts
objectPaths :: ModGuts -> CoreBind -> CoreM [FilePath]
objectPaths guts (NonRec b _) = objectAnns guts b
objectPaths guts (Rec bs) = concat <$> mapM (objectAnns guts) (map fst bs)
objectAnns :: ModGuts -> CoreBndr -> CoreM [FilePath]
objectAnns guts bndr = do
anns <- getAnnotations deserializeWithData guts
return [ path | Object path <- lookupWithDefaultUFM anns [] (varUnique bndr) ]
objectMapPath :: DynFlags -> FilePath
objectMapPath DynFlags{..}
| Just p <- objectDir = p
| Just p <- dumpDir = p
| otherwise = "."
optionOfPath :: FilePath -> Option
optionOfPath = FileOption []