{-# LANGUAGE CPP #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
module Clash.GHC.LoadModules
( loadModules
, ghcLibDir
, setWantedLanguageExtensions
)
where
#ifndef USE_GHC_PATHS
#ifndef TOOL_VERSION_ghc
#error TOOL_VERSION_ghc undefined
#endif
#endif
import Clash.Annotations.Primitive (HDL, PrimitiveGuard(..))
import Clash.Annotations.TopEntity (TopEntity (..))
import Clash.Primitives.Types (UnresolvedPrimitive)
import Clash.Util (ClashException(..), pkgIdFromTypeable)
import qualified Clash.Util.Interpolate as I
import Control.Arrow (first)
import Control.Exception (SomeException, throw)
import Control.Monad (forM, join, when)
import Data.List.Extra (nubSort)
import Control.Exception (throwIO)
import Control.Monad (foldM)
#if MIN_VERSION_ghc(9,0,0)
import Control.Monad.Catch as MC (try)
#endif
import Control.Monad.IO.Class (liftIO)
import Data.Char (isDigit)
import Data.Generics.Uniplate.DataOnly (transform)
import Data.Data (Data)
import Data.Functor ((<&>))
import Data.Foldable (toList)
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as HashMap
import Data.Typeable (Typeable)
import Data.List (foldl', nub, find)
import qualified Data.Map as Map
import Data.Maybe
(catMaybes, fromMaybe, listToMaybe, mapMaybe)
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Time.Clock as Clock
import qualified Data.Set as Set
import qualified Data.Sequence as Seq
import Debug.Trace
import Language.Haskell.TH.Syntax (lift)
import GHC.Natural (naturalFromInteger)
import GHC.Stack (HasCallStack)
#if MIN_VERSION_ghc(9,4,0)
import System.FilePath.Posix (dropExtension, takeDirectory)
#endif
import Text.Read (readMaybe)
#ifdef USE_GHC_PATHS
import GHC.Paths (libdir)
#else
import System.Exit (ExitCode (..))
import System.IO (hGetLine)
import System.IO.Error (tryIOError)
import System.Process (runInteractiveCommand,
waitForProcess)
#endif
#if MIN_VERSION_ghc(9,0,0)
#if MIN_VERSION_ghc(9,4,0)
import GHC.Driver.Phases (StopPhase(NoStop))
import GHC.Driver.Pipeline (mkPipeEnv, runPipeline, hscBackendPipeline)
#if MIN_VERSION_ghc(9,6,0)
import GHC.SysTools.Cpp (offsetIncludePaths)
import GHC.Unit.Home.ModInfo (homeMod_bytecode)
#else
import GHC.Driver.Pipeline.Execute (offsetIncludePaths)
import GHC.Driver.Pipeline.Monad (PipelineOutput(NoOutputFile, Persistent))
#endif
import GHC.Driver.Pipeline.Monad ( MonadUse(use) )
import GHC.Driver.Pipeline.Phases (TPhase(T_HscPostTc))
import GHC.Data.Bool (OverridingBool)
import GHC.Driver.Config.Tidy (initTidyOpts)
import GHC.Driver.Errors.Types (GhcMessage(GhcTcRnMessage))
import GHC.Driver.Monad (modifySession)
import GHC.Unit.Env (addHomeModInfoToHug)
import GHC.Unit.Home.ModInfo (HomeModInfo(HomeModInfo))
import GHC.Unit.Module.ModSummary (findTarget)
#else
import GHC.Utils.Misc (OverridingBool)
#endif
#if MIN_VERSION_ghc(9,2,0)
import qualified GHC.Driver.Env as HscTypes
import qualified GHC.Unit.Module.ModGuts as HscTypes
import qualified GHC.Types.SourceError as HscTypes
import qualified GHC.Unit.Module.Deps as HscTypes
import qualified GHC.Driver.Backend as Backend
import qualified GHC.Unit.Module.Graph as Graph
import qualified GHC.Platform.Ways as Ways
#if !MIN_VERSION_ghc(9,4,0)
import qualified GHC.Types.Error as Error
#endif
#else
import qualified GHC.Driver.Types as HscTypes
import qualified GHC.Driver.Ways as Ways
#endif
import qualified GHC.Types.Annotations as Annotations
import qualified GHC.Core.FVs as CoreFVs
import qualified GHC.Core as CoreSyn
import qualified GHC.Core.DataCon as DataCon
import qualified GHC.Data.Graph.Directed as Digraph
import qualified GHC.Runtime.Loader as DynamicLoading
import GHC.Driver.Session (GeneralFlag (..))
import qualified GHC.Driver.Session as DynFlags
import qualified GHC.Data.FastString as FastString
import qualified GHC
import qualified GHC.Driver.Main as HscMain
import qualified GHC.Utils.Monad as MonadUtils
import qualified GHC.Utils.Panic as Panic
import qualified GHC.Serialized as Serialized (deserializeWithData)
import qualified GHC.Unit.Types as UnitTypes (unitIdString)
import qualified GHC.Tc.Utils.Monad as TcRnMonad
import qualified GHC.Tc.Types as TcRnTypes
import qualified GHC.Iface.Tidy as TidyPgm
import qualified GHC.Core.TyCon as TyCon
import qualified GHC.Core.Type as Type
import qualified GHC.Types.Unique as Unique
import qualified GHC.Tc.Instance.Family as FamInst
import qualified GHC.Core.FamInstEnv as FamInstEnv
import qualified GHC.LanguageExtensions as LangExt
import qualified GHC.Types.Name as Name
import qualified GHC.Types.Name.Occurrence as OccName
import GHC.Utils.Outputable (ppr)
import qualified GHC.Utils.Outputable as Outputable
import qualified GHC.Types.Unique.Set as UniqSet
import qualified GHC.Types.Var as Var
import qualified GHC.Unit.Module.Env as ModuleEnv
import qualified GHC.Types.Name.Env as NameEnv
#else
import qualified Annotations
import qualified CoreFVs
import qualified CoreSyn
import qualified DataCon
import qualified Digraph
import qualified DynamicLoading
import DynFlags (GeneralFlag (..))
import qualified DynFlags
import qualified Exception
import qualified FastString
import qualified GHC
import qualified HscMain
import qualified HscTypes
import qualified MonadUtils
import qualified Panic
import qualified GhcPlugins (deserializeWithData, installedUnitIdString)
import qualified TcRnMonad
import qualified TcRnTypes
import qualified TidyPgm
import qualified TyCon
import qualified Type
import qualified Unique
import qualified UniqFM
import qualified FamInst
import qualified FamInstEnv
import qualified GHC.LanguageExtensions as LangExt
import qualified Name
import qualified OccName
import Outputable (ppr)
import qualified Outputable
import qualified UniqSet
import Util (OverridingBool)
import qualified Var
#endif
import Clash.GHC.GHC2Core (modNameM, qualifiedNameString')
import Clash.GHC.LoadInterfaceFiles
(loadExternalExprs, getUnresolvedPrimitives, loadExternalBinders,
LoadedBinders(..))
import Clash.GHCi.Common (checkMonoLocalBindsMod)
import Clash.Util (curLoc, noSrcSpan, reportTimeDiff
,wantedLanguageExtensions, unwantedLanguageExtensions)
import Clash.Annotations.BitRepresentation.Internal
(DataRepr', dataReprAnnToDataRepr')
import Clash.Signal.Internal
ghcLibDir :: IO FilePath
#ifdef USE_GHC_PATHS
ghcLibDir = return libdir
#else
ghcLibDir :: IO FilePath
ghcLibDir = do
(Maybe FilePath
libDirM,ExitCode
exitCode) <- FilePath -> IO (Maybe FilePath, ExitCode)
getProcessOutput (FilePath -> IO (Maybe FilePath, ExitCode))
-> FilePath -> IO (Maybe FilePath, ExitCode)
forall a b. (a -> b) -> a -> b
$ FilePath
"ghc-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TOOL_VERSION_ghc ++ " --print-libdir"
case ExitCode
exitCode of
ExitCode
ExitSuccess -> case Maybe FilePath
libDirM of
Just FilePath
libDir -> FilePath -> IO FilePath
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return FilePath
libDir
Maybe FilePath
Nothing -> FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
Panic.pgmError FilePath
noGHC
ExitFailure Int
i -> case Int
i of
Int
127 -> FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
Panic.pgmError FilePath
noGHC
Int
i' -> FilePath -> IO FilePath
forall a. HasCallStack => FilePath -> a
Panic.pgmError (FilePath -> IO FilePath) -> FilePath -> IO FilePath
forall a b. (a -> b) -> a -> b
$ FilePath
"Calling GHC failed with error code: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ Int -> FilePath
forall a. Show a => a -> FilePath
show Int
i'
where
noGHC :: FilePath
noGHC = FilePath
"Clash needs the GHC compiler it was built with, ghc-" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ TOOL_VERSION_ghc ++
FilePath
", but it was not found. Make sure its location is in your PATH variable."
getProcessOutput :: String -> IO (Maybe String, ExitCode)
getProcessOutput :: FilePath -> IO (Maybe FilePath, ExitCode)
getProcessOutput FilePath
command =
do (Handle
_, Handle
pOut, Handle
_, ProcessHandle
handle) <- FilePath -> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveCommand FilePath
command
ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
handle
Maybe FilePath
output <- (IOError -> Maybe FilePath)
-> (FilePath -> Maybe FilePath)
-> Either IOError FilePath
-> Maybe FilePath
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Maybe FilePath -> IOError -> Maybe FilePath
forall a b. a -> b -> a
const Maybe FilePath
forall a. Maybe a
Nothing) FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just (Either IOError FilePath -> Maybe FilePath)
-> IO (Either IOError FilePath) -> IO (Maybe FilePath)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath -> IO (Either IOError FilePath)
forall a. IO a -> IO (Either IOError a)
tryIOError (Handle -> IO FilePath
hGetLine Handle
pOut)
(Maybe FilePath, ExitCode) -> IO (Maybe FilePath, ExitCode)
forall a. a -> IO a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe FilePath
output, ExitCode
exitCode)
#endif
loadExternalModule
:: (HasCallStack, GHC.GhcMonad m)
=> HDL
-> String
-> m (Either
SomeException
( [CoreSyn.CoreBndr]
, FamInstEnv.FamInstEnv
, GHC.ModuleName
, LoadedBinders
, [CoreSyn.CoreBind]
) )
#if MIN_VERSION_ghc(9,0,0)
loadExternalModule :: forall (m :: Type -> Type).
(HasCallStack, GhcMonad m) =>
HDL
-> FilePath
-> m (Either
SomeException
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind]))
loadExternalModule HDL
hdl FilePath
modName0 = m ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
-> m (Either
SomeException
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind]))
forall (m :: Type -> Type) e a.
(HasCallStack, MonadCatch m, Exception e) =>
m a -> m (Either e a)
MC.try (m ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
-> m (Either
SomeException
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])))
-> m ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders,
[CoreBind])
-> m (Either
SomeException
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind]))
forall a b. (a -> b) -> a -> b
$ do
#else
loadExternalModule hdl modName0 = Exception.gtry $ do
#endif
let modName1 :: ModuleName
modName1 = FilePath -> ModuleName
GHC.mkModuleName FilePath
modName0
Module
foundMod <- ModuleName -> Maybe FastString -> m Module
forall (m :: Type -> Type).
GhcMonad m =>
ModuleName -> Maybe FastString -> m Module
GHC.findModule ModuleName
modName1 Maybe FastString
forall a. Maybe a
Nothing
let errMsg :: FilePath
errMsg = FilePath
"Internal error: found module, but could not load it"
ModuleInfo
modInfo <- ModuleInfo -> Maybe ModuleInfo -> ModuleInfo
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ModuleInfo
forall a. HasCallStack => FilePath -> a
error FilePath
errMsg) (Maybe ModuleInfo -> ModuleInfo)
-> m (Maybe ModuleInfo) -> m ModuleInfo
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Module -> m (Maybe ModuleInfo)
forall (m :: Type -> Type).
GhcMonad m =>
Module -> m (Maybe ModuleInfo)
GHC.getModuleInfo Module
foundMod)
[TyThing]
tyThings <- [Maybe TyThing] -> [TyThing]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe TyThing] -> [TyThing]) -> m [Maybe TyThing] -> m [TyThing]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Name -> m (Maybe TyThing)) -> [Name] -> m [Maybe TyThing]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM Name -> m (Maybe TyThing)
forall (m :: Type -> Type). GhcMonad m => Name -> m (Maybe TyThing)
GHC.lookupGlobalName (ModuleInfo -> [Name]
GHC.modInfoExports ModuleInfo
modInfo)
let rootIds :: [CoreBndr]
rootIds = [CoreBndr
id_ | GHC.AnId CoreBndr
id_ <- [TyThing]
tyThings]
LoadedBinders
loaded <- HDL -> [CoreBndr] -> m LoadedBinders
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> [CoreBndr] -> m LoadedBinders
loadExternalBinders HDL
hdl [CoreBndr]
rootIds
let allBinders :: [CoreBind]
allBinders = [(CoreBndr, CoreExpr)] -> [CoreBind]
makeRecursiveGroups (Map CoreBndr CoreExpr -> [(CoreBndr, CoreExpr)]
forall k a. Map k a -> [(k, a)]
Map.assocs (LoadedBinders -> Map CoreBndr CoreExpr
lbBinders LoadedBinders
loaded))
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
-> m ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders,
[CoreBind])
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([CoreBndr]
rootIds, FamInstEnv
FamInstEnv.emptyFamInstEnv, ModuleName
modName1, LoadedBinders
loaded, [CoreBind]
allBinders)
setupGhc
:: GHC.GhcMonad m
=> OverridingBool
-> Maybe GHC.DynFlags
-> [FilePath]
-> m ()
setupGhc :: forall (m :: Type -> Type).
GhcMonad m =>
OverridingBool -> Maybe DynFlags -> [FilePath] -> m ()
setupGhc OverridingBool
useColor Maybe DynFlags
dflagsM [FilePath]
idirs = do
DynFlags
dflags <-
case Maybe DynFlags
dflagsM of
Just DynFlags
df -> DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return DynFlags
df
Maybe DynFlags
Nothing -> do
DynFlags
df <- do
DynFlags
df <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
#if MIN_VERSION_ghc(9,0,0)
#if MIN_VERSION_ghc(9,2,0)
Logger
logger <- m Logger
forall (m :: Type -> Type). HasLogger m => m Logger
GHC.getLogger
DynFlags
df1 <- IO DynFlags -> m DynFlags
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Logger -> DynFlags -> IO DynFlags
GHC.interpretPackageEnv Logger
logger DynFlags
df)
#else
df1 <- liftIO (GHC.interpretPackageEnv df)
#endif
()
_ <- DynFlags -> m ()
forall (m :: Type -> Type).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
df1
#else
_ <- GHC.setSessionDynFlags df {DynFlags.pkgDatabase = Nothing}
#endif
m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
let df1 :: DynFlags
df1 = DynFlags -> DynFlags
setWantedLanguageExtensions DynFlags
df
ghcTyLitNormPlugin :: ModuleName
ghcTyLitNormPlugin = FilePath -> ModuleName
GHC.mkModuleName FilePath
"GHC.TypeLits.Normalise"
ghcTyLitExtrPlugin :: ModuleName
ghcTyLitExtrPlugin = FilePath -> ModuleName
GHC.mkModuleName FilePath
"GHC.TypeLits.Extra.Solver"
ghcTyLitKNPlugin :: ModuleName
ghcTyLitKNPlugin = FilePath -> ModuleName
GHC.mkModuleName FilePath
"GHC.TypeLits.KnownNat.Solver"
dfPlug :: DynFlags
dfPlug = DynFlags
df1 { DynFlags.pluginModNames = nub $
ghcTyLitNormPlugin : ghcTyLitExtrPlugin :
ghcTyLitKNPlugin : DynFlags.pluginModNames df1
, DynFlags.useColor = useColor
, DynFlags.importPaths = idirs
}
DynFlags -> m DynFlags
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return DynFlags
dfPlug
let dflags1 :: DynFlags
dflags1 = DynFlags
dflags
{ DynFlags.ghcMode = GHC.CompManager
, DynFlags.ghcLink = GHC.LinkInMemory
#if !MIN_VERSION_ghc(9,4,0)
, DynFlags.optLevel = 2
#endif
#if MIN_VERSION_ghc(9,2,0)
, DynFlags.backend =
if Ways.hostIsProfiled
#if MIN_VERSION_ghc(9,6,0)
then Backend.noBackend
#else
then Backend.NoBackend
#endif
else Backend.platformDefaultBackend (DynFlags.targetPlatform dflags)
#else
, DynFlags.hscTarget
#if MIN_VERSION_ghc(9,0,0)
= if Ways.hostIsProfiled
#else
= if DynFlags.rtsIsProfiled
#endif
then DynFlags.HscNothing
else DynFlags.defaultObjectTarget $
#if !MIN_VERSION_ghc(8,10,0)
DynFlags.targetPlatform
#endif
dflags
#endif
, DynFlags.reductionDepth = 1000
}
let dflags2 :: DynFlags
dflags2 = DynFlags -> DynFlags
unwantedOptimizationFlags DynFlags
dflags1
ghcDynamic :: Bool
ghcDynamic = case FilePath -> [(FilePath, FilePath)] -> Maybe FilePath
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup FilePath
"GHC Dynamic" (DynFlags -> [(FilePath, FilePath)]
DynFlags.compilerInfo DynFlags
dflags) of
Just FilePath
"YES" -> Bool
True
Maybe FilePath
_ -> Bool
False
dflags3 :: DynFlags
dflags3 = if Bool
ghcDynamic then DynFlags -> GeneralFlag -> DynFlags
DynFlags.gopt_set DynFlags
dflags2 GeneralFlag
DynFlags.Opt_BuildDynamicToo
else DynFlags
dflags2
Bool -> m () -> m ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
DynFlags.gopt GeneralFlag
DynFlags.Opt_WorkerWrapper DynFlags
dflags3) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
FilePath -> m () -> m ()
forall a. FilePath -> a -> a
trace
([FilePath] -> FilePath
unlines [FilePath
"WARNING:"
,FilePath
"`-fworker-wrapper` option is globally enabled, this can result in incorrect code."
,FilePath
"Are you compiling with `-O` or `-O2`? Consider adding `-fno-worker-wrapper`."
,FilePath
"`-fworker-wrapper` can be use in a diligent manner on a file-by-file basis"
,FilePath
"by using a `{-# OPTIONS_GHC -fworker-wrapper` #-} pragma."
])
(() -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ())
#if MIN_VERSION_ghc(9,2,0)
()
_ <- DynFlags -> m ()
forall (m :: Type -> Type).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
dflags3
HscEnv
hscenv <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
HscEnv
hscenv1 <- IO HscEnv -> m HscEnv
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (HscEnv -> IO HscEnv
DynamicLoading.initializePlugins HscEnv
hscenv)
HscEnv -> m ()
forall (m :: Type -> Type). GhcMonad m => HscEnv -> m ()
GHC.setSession HscEnv
hscenv1
#elif MIN_VERSION_ghc(9,0,0)
_ <- GHC.setSessionDynFlags dflags3
hscenv <- GHC.getSession
dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3)
_ <- GHC.setSessionDynFlags dflags4
#else
hscenv <- GHC.getSession
dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3)
_ <- GHC.setSessionDynFlags dflags4
#endif
() -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
loadLocalModule
:: GHC.GhcMonad m
=> HDL
-> String
-> m ( [CoreSyn.CoreBndr]
, FamInstEnv.FamInstEnv
, GHC.ModuleName
, LoadedBinders
, [CoreSyn.CoreBind]
)
loadLocalModule :: forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> FilePath
-> m ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders,
[CoreBind])
loadLocalModule HDL
hdl FilePath
modName = do
#if MIN_VERSION_ghc(9,4,0)
Target
target <- FilePath -> Maybe UnitId -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> Maybe UnitId -> Maybe Phase -> m Target
GHC.guessTarget FilePath
modName Maybe UnitId
forall a. Maybe a
Nothing Maybe Phase
forall a. Maybe a
Nothing
#else
target <- GHC.guessTarget modName Nothing
#endif
[Target] -> m ()
forall (m :: Type -> Type). GhcMonad m => [Target] -> m ()
GHC.setTargets [Target
target]
ModuleGraph
modGraph <- [ModuleName] -> Bool -> m ModuleGraph
forall (m :: Type -> Type).
GhcMonad m =>
[ModuleName] -> Bool -> m ModuleGraph
GHC.depanal [] Bool
False
let modGraph' :: ModuleGraph
modGraph' = (ModSummary -> ModSummary) -> ModuleGraph -> ModuleGraph
GHC.mapMG ModSummary -> ModSummary
disableOptimizationsFlags ModuleGraph
modGraph
modGraph2 :: [ModSummary]
modGraph2 = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
Digraph.flattenSCCs ([SCC ModSummary] -> [ModSummary])
-> [SCC ModSummary] -> [ModSummary]
forall a b. (a -> b) -> a -> b
$
#if MIN_VERSION_ghc(9,2,0)
[SCC ModuleGraphNode] -> [SCC ModSummary]
Graph.filterToposortToModules ([SCC ModuleGraphNode] -> [SCC ModSummary])
-> [SCC ModuleGraphNode] -> [SCC ModSummary]
forall a b. (a -> b) -> a -> b
$
#endif
Bool
-> ModuleGraph -> Maybe HomeUnitModule -> [SCC ModuleGraphNode]
GHC.topSortModuleGraph Bool
True ModuleGraph
modGraph' Maybe HomeUnitModule
forall a. Maybe a
Nothing
IO () -> m ()
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ (ModSummary -> IO ()) -> [ModSummary] -> IO ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ModSummary -> IO ()
checkMonoLocalBindsMod [ModSummary]
modGraph2
[([CoreBind], FamInstEnv)]
tidiedMods <- [ModSummary]
-> (ModSummary -> m ([CoreBind], FamInstEnv))
-> m [([CoreBind], FamInstEnv)]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ModSummary]
modGraph2 ((ModSummary -> m ([CoreBind], FamInstEnv))
-> m [([CoreBind], FamInstEnv)])
-> (ModSummary -> m ([CoreBind], FamInstEnv))
-> m [([CoreBind], FamInstEnv)]
forall a b. (a -> b) -> a -> b
$ \ModSummary
m -> do
DynFlags
oldDFlags <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
ParsedModule
pMod <- ModSummary -> m ParsedModule
forall (m :: Type -> Type).
GhcMonad m =>
ModSummary -> m ParsedModule
parseModule ModSummary
m
()
_ <- DynFlags -> m ()
forall (m :: Type -> Type).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags (ModSummary -> DynFlags
GHC.ms_hspp_opts (ParsedModule -> ModSummary
GHC.pm_mod_summary ParsedModule
pMod))
TypecheckedModule
tcMod <- ParsedModule -> m TypecheckedModule
forall (m :: Type -> Type).
GhcMonad m =>
ParsedModule -> m TypecheckedModule
GHC.typecheckModule (ParsedModule -> ParsedModule
removeStrictnessAnnotations ParsedModule
pMod)
#if MIN_VERSION_ghc(9,4,0)
let (TcGblEnv
tc_result,ModDetails
_) = TypecheckedModule -> (TcGblEnv, ModDetails)
GHC.tm_internals_ TypecheckedModule
tcMod
let tcMod' :: TypecheckedModule
tcMod' = TypecheckedModule
tcMod
#else
tcMod' <- GHC.loadModule tcMod
#endif
ModGuts
dsMod <- (DesugaredModule -> ModGuts) -> m DesugaredModule -> m ModGuts
forall a b. (a -> b) -> m a -> m b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap DesugaredModule -> ModGuts
forall m. DesugaredMod m => m -> ModGuts
GHC.coreModule (m DesugaredModule -> m ModGuts) -> m DesugaredModule -> m ModGuts
forall a b. (a -> b) -> a -> b
$ TypecheckedModule -> m DesugaredModule
forall (m :: Type -> Type).
GhcMonad m =>
TypecheckedModule -> m DesugaredModule
GHC.desugarModule TypecheckedModule
tcMod'
HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
ModGuts
simpl_guts <- IO ModGuts -> m ModGuts
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO ModGuts -> m ModGuts) -> IO ModGuts -> m ModGuts
forall a b. (a -> b) -> a -> b
$ HscEnv -> [FilePath] -> ModGuts -> IO ModGuts
HscMain.hscSimplify HscEnv
hsc_env [] ModGuts
dsMod
ModGuts -> m ()
forall (m :: Type -> Type). Monad m => ModGuts -> m ()
checkForInvalidPrelude ModGuts
simpl_guts
#if MIN_VERSION_ghc(9,4,0)
TidyOpts
opts <- IO TidyOpts -> m TidyOpts
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> IO TidyOpts
initTidyOpts HscEnv
hsc_env)
(CgGuts
tidy_guts,ModDetails
_) <- IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails))
-> IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails)
forall a b. (a -> b) -> a -> b
$ TidyOpts -> ModGuts -> IO (CgGuts, ModDetails)
TidyPgm.tidyProgram TidyOpts
opts ModGuts
simpl_guts
#else
(tidy_guts,_) <- MonadUtils.liftIO $ TidyPgm.tidyProgram hsc_env simpl_guts
#endif
#if MIN_VERSION_ghc(9,4,0)
let
loadAsByteCode :: Bool
loadAsByteCode
| Just GHC.Target { targetAllowObjCode :: Target -> Bool
targetAllowObjCode = Bool
obj }
<- ModSummary -> [Target] -> Maybe Target
findTarget ModSummary
m (HscEnv -> [Target]
HscTypes.hsc_targets HscEnv
hsc_env)
, Bool -> Bool
not Bool
obj
= Bool
True
| Bool
otherwise = Bool
False
lcl_dflags :: DynFlags
lcl_dflags = ModSummary -> DynFlags
GHC.ms_hspp_opts ModSummary
m
old_paths :: IncludeSpecs
old_paths = DynFlags -> IncludeSpecs
GHC.includePaths DynFlags
lcl_dflags
location :: ModLocation
location = ModSummary -> ModLocation
GHC.ms_location ModSummary
m
input_fn :: FilePath
input_fn = FilePath -> Maybe FilePath -> FilePath
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> FilePath
forall a. HasCallStack => FilePath -> a
error FilePath
"loadLocalModule") (ModLocation -> Maybe FilePath
GHC.ml_hs_file ModLocation
location)
basename :: FilePath
basename = FilePath -> FilePath
dropExtension FilePath
input_fn
current_dir :: FilePath
current_dir = FilePath -> FilePath
takeDirectory FilePath
basename
#if MIN_VERSION_ghc(9,6,0)
interpreterBackend :: Backend
interpreterBackend = Backend
Backend.interpreterBackend
#else
interpreterBackend = Backend.Interpreter
#endif
(Backend
bcknd, DynFlags
dflags3)
| Bool
loadAsByteCode
= ( Backend
interpreterBackend
, DynFlags -> GeneralFlag -> DynFlags
DynFlags.gopt_set
(DynFlags
lcl_dflags { GHC.backend = interpreterBackend })
GeneralFlag
Opt_ForceRecomp
)
| Bool
otherwise
= (DynFlags -> Backend
GHC.backend DynFlags
dflags, DynFlags
lcl_dflags)
dflags :: DynFlags
dflags = DynFlags
dflags3
{ GHC.includePaths = offsetIncludePaths dflags3 $
DynFlags.addImplicitQuoteInclude
old_paths
[current_dir] }
#if MIN_VERSION_ghc(9,6,0)
pipelineOutput :: PipelineOutput
pipelineOutput = Backend -> PipelineOutput
Backend.backendPipelineOutput Backend
bcknd
#else
pipelineOutput = case bcknd of
GHC.Interpreter -> NoOutputFile
GHC.NoBackend -> NoOutputFile
_ -> Persistent
#endif
upd_summary :: ModSummary
upd_summary = ModSummary
m { GHC.ms_hspp_opts = dflags }
hsc_env1 :: HscEnv
hsc_env1 = (() :: Constraint) => DynFlags -> HscEnv -> HscEnv
DynFlags -> HscEnv -> HscEnv
HscTypes.hscSetFlags DynFlags
dflags HscEnv
hsc_env
pipe_env :: PipeEnv
pipe_env = StopPhase -> FilePath -> Maybe Phase -> PipelineOutput -> PipeEnv
mkPipeEnv StopPhase
NoStop FilePath
input_fn Maybe Phase
forall a. Maybe a
Nothing PipelineOutput
pipelineOutput
pipeline :: HookedUse (ModIface, HomeModLinkable)
pipeline = do
HscBackendAction
ac <- TPhase HscBackendAction -> HookedUse HscBackendAction
forall a. TPhase a -> HookedUse a
forall (f :: Type -> Type) (m :: Type -> Type) a.
MonadUse f m =>
f a -> m a
use (HscEnv
-> ModSummary
-> FrontendResult
-> Messages GhcMessage
-> Maybe Fingerprint
-> TPhase HscBackendAction
T_HscPostTc HscEnv
hsc_env1 ModSummary
upd_summary
(TcGblEnv -> FrontendResult
TcRnTypes.FrontendTypecheck TcGblEnv
tc_result) Messages GhcMessage
forall a. Monoid a => a
mempty Maybe Fingerprint
forall a. Maybe a
Nothing )
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> HookedUse (ModIface, HomeModLinkable)
forall (m :: Type -> Type).
P m =>
PipeEnv
-> HscEnv
-> ModSummary
-> HscBackendAction
-> m (ModIface, HomeModLinkable)
hscBackendPipeline PipeEnv
pipe_env HscEnv
hsc_env1 ModSummary
upd_summary HscBackendAction
ac
(ModIface
iface, HomeModLinkable
linkable) <- IO (ModIface, HomeModLinkable) -> m (ModIface, HomeModLinkable)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (Hooks
-> HookedUse (ModIface, HomeModLinkable)
-> IO (ModIface, HomeModLinkable)
forall a. Hooks -> HookedUse a -> IO a
runPipeline (HscEnv -> Hooks
HscTypes.hsc_hooks HscEnv
hsc_env1) HookedUse (ModIface, HomeModLinkable)
pipeline)
#if MIN_VERSION_ghc(9,6,0)
ModDetails
details <- IO ModDetails -> m ModDetails
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> ModIface -> IO ModDetails
HscMain.initModDetails HscEnv
hsc_env1 ModIface
iface)
Maybe Linkable
linkable1 <- IO (Maybe Linkable) -> m (Maybe Linkable)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO ((Linkable -> IO Linkable) -> Maybe Linkable -> IO (Maybe Linkable)
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: Type -> Type) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (HscEnv -> ModIface -> ModDetails -> Linkable -> IO Linkable
HscMain.initWholeCoreBindings HscEnv
hsc_env1 ModIface
iface ModDetails
details)
(HomeModLinkable -> Maybe Linkable
homeMod_bytecode HomeModLinkable
linkable))
let linkable2 :: HomeModLinkable
linkable2 = HomeModLinkable
linkable {homeMod_bytecode = linkable1}
#else
details <- liftIO (HscMain.initModDetails hsc_env1 upd_summary iface)
let linkable2 = linkable
#endif
let mod_info :: HomeModInfo
mod_info = ModIface -> ModDetails -> HomeModLinkable -> HomeModInfo
HomeModInfo ModIface
iface ModDetails
details HomeModLinkable
linkable2
(HscEnv -> HscEnv) -> m ()
forall (m :: Type -> Type).
GhcMonad m =>
(HscEnv -> HscEnv) -> m ()
modifySession ((HscEnv -> HscEnv) -> m ()) -> (HscEnv -> HscEnv) -> m ()
forall a b. (a -> b) -> a -> b
$ (HomeUnitGraph -> HomeUnitGraph) -> HscEnv -> HscEnv
HscTypes.hscUpdateHUG (HomeModInfo -> HomeUnitGraph -> HomeUnitGraph
addHomeModInfoToHug HomeModInfo
mod_info)
#endif
let pgm :: [CoreBind]
pgm = CgGuts -> [CoreBind]
HscTypes.cg_binds CgGuts
tidy_guts
let modFamInstEnv :: FamInstEnv
modFamInstEnv = TcGblEnv -> FamInstEnv
TcRnTypes.tcg_fam_inst_env (TcGblEnv -> FamInstEnv) -> TcGblEnv -> FamInstEnv
forall a b. (a -> b) -> a -> b
$ (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a, b) -> a
fst ((TcGblEnv, ModDetails) -> TcGblEnv)
-> (TcGblEnv, ModDetails) -> TcGblEnv
forall a b. (a -> b) -> a -> b
$ TypecheckedModule -> (TcGblEnv, ModDetails)
GHC.tm_internals_ TypecheckedModule
tcMod
()
_ <- DynFlags -> m ()
forall (m :: Type -> Type).
(HasCallStack, GhcMonad m) =>
DynFlags -> m ()
GHC.setSessionDynFlags DynFlags
oldDFlags
([CoreBind], FamInstEnv) -> m ([CoreBind], FamInstEnv)
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([CoreBind]
pgm,FamInstEnv
modFamInstEnv)
let ([[CoreBind]]
binders,[FamInstEnv]
modFamInstEnvs) = [([CoreBind], FamInstEnv)] -> ([[CoreBind]], [FamInstEnv])
forall a b. [(a, b)] -> ([a], [b])
unzip [([CoreBind], FamInstEnv)]
tidiedMods
binderIds :: [CoreBndr]
binderIds = ((CoreBndr, CoreExpr) -> CoreBndr)
-> [(CoreBndr, CoreExpr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst ([CoreBind] -> [(CoreBndr, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
CoreSyn.flattenBinds ([[CoreBind]] -> [CoreBind]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[CoreBind]]
binders))
plusFamInst :: FamInstEnv -> FamInstEnv -> FamInstEnv
plusFamInst FamInstEnv
f1 FamInstEnv
f2 = FamInstEnv -> [FamInst] -> FamInstEnv
FamInstEnv.extendFamInstEnvList FamInstEnv
f1 (FamInstEnv -> [FamInst]
FamInstEnv.famInstEnvElts FamInstEnv
f2)
modFamInstEnvs' :: FamInstEnv
modFamInstEnvs' = (FamInstEnv -> FamInstEnv -> FamInstEnv)
-> FamInstEnv -> [FamInstEnv] -> FamInstEnv
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' FamInstEnv -> FamInstEnv -> FamInstEnv
plusFamInst FamInstEnv
FamInstEnv.emptyFamInstEnv [FamInstEnv]
modFamInstEnvs
rootModule :: ModuleName
rootModule = ModSummary -> ModuleName
GHC.ms_mod_name (ModSummary -> ModuleName)
-> ([ModSummary] -> ModSummary) -> [ModSummary] -> ModuleName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ModSummary] -> ModSummary
forall a. HasCallStack => [a] -> a
last ([ModSummary] -> ModuleName) -> [ModSummary] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [ModSummary]
modGraph2
let rootIds :: [CoreBndr]
rootIds = ((CoreBndr, CoreExpr) -> CoreBndr)
-> [(CoreBndr, CoreExpr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst ([(CoreBndr, CoreExpr)] -> [CoreBndr])
-> ([CoreBind] -> [(CoreBndr, CoreExpr)])
-> [CoreBind]
-> [CoreBndr]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [CoreBind] -> [(CoreBndr, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
CoreSyn.flattenBinds ([CoreBind] -> [CoreBndr]) -> [CoreBind] -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$ [[CoreBind]] -> [CoreBind]
forall a. HasCallStack => [a] -> a
last [[CoreBind]]
binders
LoadedBinders
loaded0 <- HDL -> [CoreBind] -> m LoadedBinders
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> [CoreBind] -> m LoadedBinders
loadExternalExprs HDL
hdl ([[CoreBind]] -> [CoreBind]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[CoreBind]]
binders)
[Either UnresolvedPrimitive FilePath]
localPrims <- HDL -> [CoreBndr] -> m [Either UnresolvedPrimitive FilePath]
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> [CoreBndr] -> m [Either UnresolvedPrimitive FilePath]
findPrimitiveAnnotations HDL
hdl [CoreBndr]
binderIds
let loaded1 :: LoadedBinders
loaded1 = LoadedBinders
loaded0{lbPrims=lbPrims loaded0 <> Seq.fromList localPrims}
let allBinders :: [CoreBind]
allBinders = [(CoreBndr, CoreExpr)] -> [CoreBind]
makeRecursiveGroups (Map CoreBndr CoreExpr -> [(CoreBndr, CoreExpr)]
forall k a. Map k a -> [(k, a)]
Map.assocs (LoadedBinders -> Map CoreBndr CoreExpr
lbBinders LoadedBinders
loaded0))
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
-> m ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders,
[CoreBind])
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([CoreBndr]
rootIds, FamInstEnv
modFamInstEnvs', ModuleName
rootModule, LoadedBinders
loaded1, [CoreBind]
allBinders)
nameString :: Name.Name -> String
nameString :: Name -> FilePath
nameString = OccName -> FilePath
OccName.occNameString (OccName -> FilePath) -> (Name -> OccName) -> Name -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
Name.nameOccName
varNameString :: Var.Var -> String
varNameString :: CoreBndr -> FilePath
varNameString = Name -> FilePath
nameString (Name -> FilePath) -> (CoreBndr -> Name) -> CoreBndr -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
Var.varName
loadModules
:: GHC.Ghc ()
-> OverridingBool
-> HDL
-> String
-> Maybe (DynFlags.DynFlags)
-> [FilePath]
-> IO ( [CoreSyn.CoreBind]
, [(CoreSyn.CoreBndr,Int)]
, [CoreSyn.CoreBndr]
, FamInstEnv.FamInstEnvs
, [(CoreSyn.CoreBndr, Maybe TopEntity, Bool)]
, [Either UnresolvedPrimitive FilePath]
, [DataRepr']
, [(Text.Text, PrimitiveGuard ())]
, HashMap Text.Text VDomainConfiguration
)
loadModules :: Ghc ()
-> OverridingBool
-> HDL
-> FilePath
-> Maybe DynFlags
-> [FilePath]
-> IO
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
loadModules Ghc ()
startAction OverridingBool
useColor HDL
hdl FilePath
modName Maybe DynFlags
dflagsM [FilePath]
idirs = do
FilePath
libDir <- IO FilePath -> IO FilePath
forall a. IO a -> IO a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO IO FilePath
ghcLibDir
UTCTime
startTime <- IO UTCTime
Clock.getCurrentTime
Maybe FilePath
-> Ghc
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
-> IO
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
forall a. Maybe FilePath -> Ghc a -> IO a
GHC.runGhc (FilePath -> Maybe FilePath
forall a. a -> Maybe a
Just FilePath
libDir) (Ghc
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
-> IO
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration))
-> Ghc
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
-> IO
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
forall a b. (a -> b) -> a -> b
$ do
Ghc ()
startAction
OverridingBool -> Maybe DynFlags -> [FilePath] -> Ghc ()
forall (m :: Type -> Type).
GhcMonad m =>
OverridingBool -> Maybe DynFlags -> [FilePath] -> m ()
setupGhc OverridingBool
useColor ((\DynFlags
d -> DynFlags
d{GHC.mainFunIs=Nothing}) (DynFlags -> DynFlags) -> Maybe DynFlags -> Maybe DynFlags
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DynFlags
dflagsM) [FilePath]
idirs
UTCTime
setupTime <- IO UTCTime -> Ghc UTCTime
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO IO UTCTime
Clock.getCurrentTime
let setupStartDiff :: FilePath
setupStartDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
setupTime UTCTime
startTime
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"GHC: Setting up GHC took: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
setupStartDiff
([CoreBndr]
rootIds, FamInstEnv
modFamInstEnvs, ModuleName
_rootModule, LoadedBinders{Set CoreBndr
DeclCache
Map CoreBndr Int
Map CoreBndr CoreExpr
Seq (Either UnresolvedPrimitive FilePath)
Seq DataRepr'
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive FilePath)
lbBinders :: Map CoreBndr CoreExpr
lbClassOps :: Map CoreBndr Int
lbUnlocatable :: Set CoreBndr
lbPrims :: Seq (Either UnresolvedPrimitive FilePath)
lbReprs :: Seq DataRepr'
lbCache :: DeclCache
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbReprs :: LoadedBinders -> Seq DataRepr'
lbCache :: LoadedBinders -> DeclCache
..}, [CoreBind]
allBinders) <-
HDL
-> FilePath
-> Ghc
(Either
SomeException
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind]))
forall (m :: Type -> Type).
(HasCallStack, GhcMonad m) =>
HDL
-> FilePath
-> m (Either
SomeException
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind]))
loadExternalModule HDL
hdl FilePath
modName Ghc
(Either
SomeException
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind]))
-> (Either
SomeException
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
-> Ghc
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind]))
-> Ghc
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
forall a b. Ghc a -> (a -> Ghc b) -> Ghc b
forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left SomeException
_loadExternalErr -> HDL
-> FilePath
-> Ghc
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> FilePath
-> m ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders,
[CoreBind])
loadLocalModule HDL
hdl FilePath
modName
Right ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
res -> ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
-> Ghc
([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
forall a. a -> Ghc a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders, [CoreBind])
res
let allBinderIds :: [CoreBndr]
allBinderIds = ((CoreBndr, CoreExpr) -> CoreBndr)
-> [(CoreBndr, CoreExpr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst ([CoreBind] -> [(CoreBndr, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
CoreSyn.flattenBinds [CoreBind]
allBinders)
UTCTime
modTime <- [CoreBndr] -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreBndr]
allBinderIds Int -> Ghc UTCTime -> Ghc UTCTime
forall a b. a -> b -> b
`seq` IO UTCTime -> Ghc UTCTime
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO IO UTCTime
Clock.getCurrentTime
let modStartDiff :: FilePath
modStartDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
modTime UTCTime
setupTime
IO () -> Ghc ()
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO () -> Ghc ()) -> IO () -> Ghc ()
forall a b. (a -> b) -> a -> b
$ FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"GHC: Compiling and loading modules took: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
modStartDiff
HscEnv
hscEnv <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
FamInstEnvs
famInstEnvs <- do
(Messages TcRnMessage
msgs, Maybe FamInstEnvs
m) <- IO (Messages TcRnMessage, Maybe FamInstEnvs)
-> Ghc (Messages TcRnMessage, Maybe FamInstEnvs)
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
TcRnMonad.liftIO (IO (Messages TcRnMessage, Maybe FamInstEnvs)
-> Ghc (Messages TcRnMessage, Maybe FamInstEnvs))
-> IO (Messages TcRnMessage, Maybe FamInstEnvs)
-> Ghc (Messages TcRnMessage, Maybe FamInstEnvs)
forall a b. (a -> b) -> a -> b
$ HscEnv
-> TcM FamInstEnvs -> IO (Messages TcRnMessage, Maybe FamInstEnvs)
forall a. HscEnv -> TcM a -> IO (Messages TcRnMessage, Maybe a)
TcRnMonad.initTcInteractive HscEnv
hscEnv TcM FamInstEnvs
FamInst.tcGetFamInstEnvs
case Maybe FamInstEnvs
m of
Maybe FamInstEnvs
Nothing -> IO FamInstEnvs -> Ghc FamInstEnvs
forall a. IO a -> Ghc a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
TcRnMonad.liftIO (IO FamInstEnvs -> Ghc FamInstEnvs)
-> IO FamInstEnvs -> Ghc FamInstEnvs
forall a b. (a -> b) -> a -> b
$ SourceError -> IO FamInstEnvs
forall e a. Exception e => e -> IO a
throwIO
(SourceError -> IO FamInstEnvs) -> SourceError -> IO FamInstEnvs
forall a b. (a -> b) -> a -> b
$ Messages GhcMessage -> SourceError
HscTypes.mkSrcErr
#if MIN_VERSION_ghc(9,4,0)
(Messages GhcMessage -> SourceError)
-> Messages GhcMessage -> SourceError
forall a b. (a -> b) -> a -> b
$ (TcRnMessage -> GhcMessage)
-> Messages TcRnMessage -> Messages GhcMessage
forall a b. (a -> b) -> Messages a -> Messages b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap TcRnMessage -> GhcMessage
GhcTcRnMessage Messages TcRnMessage
msgs
#elif MIN_VERSION_ghc(9,2,0)
$ Error.getErrorMessages msgs
#else
$ snd msgs
#endif
Just FamInstEnvs
x -> FamInstEnvs -> Ghc FamInstEnvs
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return FamInstEnvs
x
Map CoreBndr TopEntity
allSyn <- [(CoreBndr, TopEntity)] -> Map CoreBndr TopEntity
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(CoreBndr, TopEntity)] -> Map CoreBndr TopEntity)
-> Ghc [(CoreBndr, TopEntity)] -> Ghc (Map CoreBndr TopEntity)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [CoreBndr] -> Ghc [(CoreBndr, TopEntity)]
forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(CoreBndr, TopEntity)]
findSynthesizeAnnotations [CoreBndr]
allBinderIds
[CoreBndr]
topSyn <- ((CoreBndr, TopEntity) -> CoreBndr)
-> [(CoreBndr, TopEntity)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, TopEntity) -> CoreBndr
forall a b. (a, b) -> a
fst ([(CoreBndr, TopEntity)] -> [CoreBndr])
-> Ghc [(CoreBndr, TopEntity)] -> Ghc [CoreBndr]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> [CoreBndr] -> Ghc [(CoreBndr, TopEntity)]
forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(CoreBndr, TopEntity)]
findSynthesizeAnnotations [CoreBndr]
rootIds
Map CoreBndr [CoreBndr]
benchAnn <- [CoreBndr] -> Ghc (Map CoreBndr [CoreBndr])
forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m (Map CoreBndr [CoreBndr])
findTestBenches [CoreBndr]
rootIds
[DataRepr']
reprs' <- Ghc [DataRepr']
forall (m :: Type -> Type). GhcMonad m => m [DataRepr']
findCustomReprAnnotations
[(Text, PrimitiveGuard ())]
primGuards <- [CoreBndr] -> Ghc [(Text, PrimitiveGuard ())]
forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(Text, PrimitiveGuard ())]
findPrimitiveGuardAnnotations [CoreBndr]
allBinderIds
let
isMagicName :: FilePath -> Bool
isMagicName = (FilePath -> [FilePath] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [FilePath
"topEntity", FilePath
"testBench"])
allImplicit :: [CoreBndr]
allImplicit = [CoreBndr] -> [CoreBndr]
forall a. Ord a => [a] -> [a]
nubSort ([CoreBndr] -> [CoreBndr]) -> [CoreBndr] -> [CoreBndr]
forall a b. (a -> b) -> a -> b
$
Map CoreBndr [CoreBndr] -> [CoreBndr]
forall k a. Map k a -> [k]
Map.keys Map CoreBndr [CoreBndr]
benchAnn
[CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. Semigroup a => a -> a -> a
<> Map CoreBndr TopEntity -> [CoreBndr]
forall k a. Map k a -> [k]
Map.keys Map CoreBndr TopEntity
allSyn
[CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. Semigroup a => a -> a -> a
<> [[CoreBndr]] -> [CoreBndr]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (Map CoreBndr [CoreBndr] -> [[CoreBndr]]
forall k a. Map k a -> [a]
Map.elems Map CoreBndr [CoreBndr]
benchAnn)
[CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. Semigroup a => a -> a -> a
<> (CoreBndr -> Bool) -> [CoreBndr] -> [CoreBndr]
forall a. (a -> Bool) -> [a] -> [a]
filter (FilePath -> Bool
isMagicName (FilePath -> Bool) -> (CoreBndr -> FilePath) -> CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> FilePath
varNameString) [CoreBndr]
rootIds
[CoreBndr] -> [CoreBndr] -> [CoreBndr]
forall a. Semigroup a => a -> a -> a
<> [CoreBndr]
topSyn
topEntities1 :: [CoreBndr]
topEntities1 =
case DynFlags -> Maybe FilePath
GHC.mainFunIs (DynFlags -> Maybe FilePath) -> Maybe DynFlags -> Maybe FilePath
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Maybe DynFlags
dflagsM of
Just FilePath
mainIsNm ->
case (CoreBndr -> Bool) -> [CoreBndr] -> Maybe CoreBndr
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
mainIsNm) (FilePath -> Bool) -> (CoreBndr -> FilePath) -> CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> FilePath
varNameString) [CoreBndr]
rootIds of
Maybe CoreBndr
Nothing ->
FilePath -> [CoreBndr]
forall a. HasCallStack => FilePath -> a
Panic.pgmError [I.i|
No top-level function called '#{mainIsNm}' found. Did you
forget to export it?
|]
Just CoreBndr
top ->
[CoreBndr] -> [CoreBndr]
forall a. Ord a => [a] -> [a]
nubSort (CoreBndr
topCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
allImplicit)
Maybe FilePath
Nothing ->
case [CoreBndr]
allImplicit of
[] ->
FilePath -> [CoreBndr]
forall a. HasCallStack => FilePath -> a
Panic.pgmError [I.i|
No top-level function called 'topEntity' or 'testBench' found,
nor any function annotated with a 'Synthesize' or 'TestBench'
annotation. If you want to synthesize a specific binder in
#{show modName}, use '-main-is myTopEntity'.
|]
[CoreBndr]
_ ->
[CoreBndr]
allImplicit
allBenchIds :: Set CoreBndr
allBenchIds = [CoreBndr] -> Set CoreBndr
forall a. Ord a => [a] -> Set a
Set.fromList ([[CoreBndr]] -> [CoreBndr]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat (Map CoreBndr [CoreBndr] -> [[CoreBndr]]
forall k a. Map k a -> [a]
Map.elems Map CoreBndr [CoreBndr]
benchAnn))
topEntities2 :: [(CoreBndr, Maybe TopEntity, Bool)]
topEntities2 = [CoreBndr]
topEntities1 [CoreBndr]
-> (CoreBndr -> (CoreBndr, Maybe TopEntity, Bool))
-> [(CoreBndr, Maybe TopEntity, Bool)]
forall (f :: Type -> Type) a b. Functor f => f a -> (a -> b) -> f b
<&> \CoreBndr
tid ->
( CoreBndr
tid
, CoreBndr
tid CoreBndr -> Map CoreBndr TopEntity -> Maybe TopEntity
forall k a. Ord k => k -> Map k a -> Maybe a
`Map.lookup` Map CoreBndr TopEntity
allSyn
, CoreBndr
tid CoreBndr -> Set CoreBndr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CoreBndr
allBenchIds
)
let reprs1 :: Seq DataRepr'
reprs1 = Seq DataRepr'
lbReprs Seq DataRepr' -> Seq DataRepr' -> Seq DataRepr'
forall a. Semigroup a => a -> a -> a
<> [DataRepr'] -> Seq DataRepr'
forall a. [a] -> Seq a
Seq.fromList [DataRepr']
reprs'
let famInstEnvs' :: FamInstEnvs
famInstEnvs' = (FamInstEnvs -> FamInstEnv
forall a b. (a, b) -> a
fst FamInstEnvs
famInstEnvs, FamInstEnv
modFamInstEnvs)
allTCInsts :: [FamInst]
allTCInsts = FamInstEnv -> [FamInst]
FamInstEnv.famInstEnvElts (FamInstEnvs -> FamInstEnv
forall a b. (a, b) -> a
fst FamInstEnvs
famInstEnvs')
[FamInst] -> [FamInst] -> [FamInst]
forall a. [a] -> [a] -> [a]
++ FamInstEnv -> [FamInst]
FamInstEnv.famInstEnvElts (FamInstEnvs -> FamInstEnv
forall a b. (a, b) -> b
snd FamInstEnvs
famInstEnvs')
knownConfs :: [FamInst]
knownConfs = (FamInst -> Bool) -> [FamInst] -> [FamInst]
forall a. (a -> Bool) -> [a] -> [a]
filter (\FamInst
x -> FilePath
"KnownConf" FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== Name -> FilePath
nameString (FamInst -> Name
FamInstEnv.fi_fam FamInst
x)) [FamInst]
allTCInsts
#if MIN_VERSION_ghc(8,10,0)
fsToText :: FastString -> Text
fsToText = ByteString -> Text
Text.decodeUtf8 (ByteString -> Text)
-> (FastString -> ByteString) -> FastString -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FastString -> ByteString
FastString.bytesFS
#else
fsToText = Text.decodeUtf8 . FastString.fastStringToByteString
#endif
famToDomain :: FamInst -> Text
famToDomain = Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> Text
forall a. HasCallStack => FilePath -> a
error FilePath
"KnownConf: Expected Symbol at LHS of type family")
(Maybe Text -> Text) -> (FamInst -> Maybe Text) -> FamInst -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Maybe Text) -> Maybe Text
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Text) -> Maybe Text)
-> (FamInst -> Maybe (Maybe Text)) -> FamInst -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Maybe FastString -> Maybe Text)
-> Maybe (Maybe FastString) -> Maybe (Maybe Text)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((FastString -> Text) -> Maybe FastString -> Maybe Text
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FastString -> Text
fsToText) (Maybe (Maybe FastString) -> Maybe (Maybe Text))
-> (FamInst -> Maybe (Maybe FastString))
-> FamInst
-> Maybe (Maybe Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Maybe FastString)
-> Maybe Type -> Maybe (Maybe FastString)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Maybe FastString
Type.isStrLitTy
(Maybe Type -> Maybe (Maybe FastString))
-> (FamInst -> Maybe Type) -> FamInst -> Maybe (Maybe FastString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Maybe Type
forall a. [a] -> Maybe a
listToMaybe ([Type] -> Maybe Type)
-> (FamInst -> [Type]) -> FamInst -> Maybe Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> [Type]
FamInstEnv.fi_tys
famToConf :: FamInst -> VDomainConfiguration
famToConf = Type -> VDomainConfiguration
unpackKnownConf (Type -> VDomainConfiguration)
-> (FamInst -> Type) -> FamInst -> VDomainConfiguration
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamInst -> Type
FamInstEnv.fi_rhs
knownConfNms :: [Text]
knownConfNms = (FamInst -> Text) -> [FamInst] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FamInst -> Text
famToDomain [FamInst]
knownConfs
knownConfDs :: [VDomainConfiguration]
knownConfDs = (FamInst -> VDomainConfiguration)
-> [FamInst] -> [VDomainConfiguration]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FamInst -> VDomainConfiguration
famToConf [FamInst]
knownConfs
knownConfMap :: HashMap Text VDomainConfiguration
knownConfMap = [(Text, VDomainConfiguration)] -> HashMap Text VDomainConfiguration
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ([Text] -> [VDomainConfiguration] -> [(Text, VDomainConfiguration)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Text]
knownConfNms [VDomainConfiguration]
knownConfDs)
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
-> Ghc
([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
[(CoreBndr, Maybe TopEntity, Bool)],
[Either UnresolvedPrimitive FilePath], [DataRepr'],
[(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
forall a. a -> Ghc a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( [CoreBind]
allBinders
, Map CoreBndr Int -> [(CoreBndr, Int)]
forall k a. Map k a -> [(k, a)]
Map.assocs Map CoreBndr Int
lbClassOps
, Set CoreBndr -> [CoreBndr]
forall a. Set a -> [a]
Set.toList Set CoreBndr
lbUnlocatable
, FamInstEnvs
famInstEnvs'
, [(CoreBndr, Maybe TopEntity, Bool)]
topEntities2
, Seq (Either UnresolvedPrimitive FilePath)
-> [Either UnresolvedPrimitive FilePath]
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq (Either UnresolvedPrimitive FilePath)
lbPrims
, Seq DataRepr' -> [DataRepr']
forall a. Seq a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq DataRepr'
reprs1
, [(Text, PrimitiveGuard ())]
primGuards
, HashMap Text VDomainConfiguration
knownConfMap
)
unpackKnownConf :: Type.Type -> VDomainConfiguration
unpackKnownConf :: Type -> VDomainConfiguration
unpackKnownConf Type
ty
| [Type
d,Type
p,Type
ae,Type
rk,Type
ib,Type
rp] <- HasCallStack => Type -> [Type]
Type -> [Type]
Type.tyConAppArgs Type
ty
, Just FilePath
dom <- (FastString -> FilePath) -> Maybe FastString -> Maybe FilePath
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FastString -> FilePath
FastString.unpackFS (Type -> Maybe FastString
Type.isStrLitTy Type
d)
, Just Natural
period <- (Integer -> Natural) -> Maybe Integer -> Maybe Natural
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Integer -> Natural
naturalFromInteger (Type -> Maybe Integer
Type.isNumLitTy Type
p)
, TyCon
aeTc <- (() :: Constraint) => Type -> TyCon
Type -> TyCon
Type.tyConAppTyCon Type
ae
, Just DataCon
aeDc <- TyCon -> Maybe DataCon
TyCon.isPromotedDataCon_maybe TyCon
aeTc
, FilePath
aeNm <- OccName -> FilePath
OccName.occNameString (OccName -> FilePath) -> OccName -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> OccName
Name.nameOccName (DataCon -> Name
DataCon.dataConName DataCon
aeDc)
, TyCon
rkTc <- (() :: Constraint) => Type -> TyCon
Type -> TyCon
Type.tyConAppTyCon Type
rk
, Just DataCon
rkDc <- TyCon -> Maybe DataCon
TyCon.isPromotedDataCon_maybe TyCon
rkTc
, FilePath
rkNm <- OccName -> FilePath
OccName.occNameString (OccName -> FilePath) -> OccName -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> OccName
Name.nameOccName (DataCon -> Name
DataCon.dataConName DataCon
rkDc)
, TyCon
ibTc <- (() :: Constraint) => Type -> TyCon
Type -> TyCon
Type.tyConAppTyCon Type
ib
, Just DataCon
ibDc <- TyCon -> Maybe DataCon
TyCon.isPromotedDataCon_maybe TyCon
ibTc
, FilePath
ibNm <- OccName -> FilePath
OccName.occNameString (OccName -> FilePath) -> OccName -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> OccName
Name.nameOccName (DataCon -> Name
DataCon.dataConName DataCon
ibDc)
, TyCon
rpTc <- (() :: Constraint) => Type -> TyCon
Type -> TyCon
Type.tyConAppTyCon Type
rp
, Just DataCon
rpDc <- TyCon -> Maybe DataCon
TyCon.isPromotedDataCon_maybe TyCon
rpTc
, FilePath
rpNm <- OccName -> FilePath
OccName.occNameString (OccName -> FilePath) -> OccName -> FilePath
forall a b. (a -> b) -> a -> b
$ Name -> OccName
Name.nameOccName (DataCon -> Name
DataCon.dataConName DataCon
rpDc)
= FilePath
-> Natural
-> ActiveEdge
-> ResetKind
-> InitBehavior
-> ResetPolarity
-> VDomainConfiguration
VDomainConfiguration FilePath
dom Natural
period
(HasCallStack => FilePath -> ActiveEdge
FilePath -> ActiveEdge
asActiveEdge FilePath
aeNm)
(HasCallStack => FilePath -> ResetKind
FilePath -> ResetKind
asResetKind FilePath
rkNm)
(HasCallStack => FilePath -> InitBehavior
FilePath -> InitBehavior
asInitBehavior FilePath
ibNm)
(HasCallStack => FilePath -> ResetPolarity
FilePath -> ResetPolarity
asResetPolarity FilePath
rpNm)
| Bool
otherwise
= FilePath -> VDomainConfiguration
forall a. HasCallStack => FilePath -> a
error (FilePath -> VDomainConfiguration)
-> FilePath -> VDomainConfiguration
forall a b. (a -> b) -> a -> b
$ $(curLoc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Could not unpack domain configuration."
where
asActiveEdge :: HasCallStack => String -> ActiveEdge
asActiveEdge :: HasCallStack => FilePath -> ActiveEdge
asActiveEdge FilePath
x = ActiveEdge -> Maybe ActiveEdge -> ActiveEdge
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ActiveEdge
forall a. HasCallStack => FilePath -> a
error (FilePath -> ActiveEdge) -> FilePath -> ActiveEdge
forall a b. (a -> b) -> a -> b
$ $(curLoc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Unknown active edge: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
x) (FilePath -> Maybe ActiveEdge
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
x)
asResetKind :: HasCallStack => String -> ResetKind
asResetKind :: HasCallStack => FilePath -> ResetKind
asResetKind FilePath
x = ResetKind -> Maybe ResetKind -> ResetKind
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ResetKind
forall a. HasCallStack => FilePath -> a
error (FilePath -> ResetKind) -> FilePath -> ResetKind
forall a b. (a -> b) -> a -> b
$ $(curLoc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Unknown reset kind: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
x) (FilePath -> Maybe ResetKind
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
x)
asInitBehavior :: HasCallStack => String -> InitBehavior
asInitBehavior :: HasCallStack => FilePath -> InitBehavior
asInitBehavior FilePath
x = InitBehavior -> Maybe InitBehavior -> InitBehavior
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> InitBehavior
forall a. HasCallStack => FilePath -> a
error (FilePath -> InitBehavior) -> FilePath -> InitBehavior
forall a b. (a -> b) -> a -> b
$ $(curLoc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Unknown init behavior: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
x) (FilePath -> Maybe InitBehavior
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
x)
asResetPolarity :: HasCallStack => String -> ResetPolarity
asResetPolarity :: HasCallStack => FilePath -> ResetPolarity
asResetPolarity FilePath
x = ResetPolarity -> Maybe ResetPolarity -> ResetPolarity
forall a. a -> Maybe a -> a
fromMaybe (FilePath -> ResetPolarity
forall a. HasCallStack => FilePath -> a
error (FilePath -> ResetPolarity) -> FilePath -> ResetPolarity
forall a b. (a -> b) -> a -> b
$ $(curLoc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Unknown reset polarity: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath -> FilePath
forall a. Show a => a -> FilePath
show FilePath
x) (FilePath -> Maybe ResetPolarity
forall a. Read a => FilePath -> Maybe a
readMaybe FilePath
x)
makeRecursiveGroups
:: [(CoreSyn.CoreBndr,CoreSyn.CoreExpr)]
-> [CoreSyn.CoreBind]
makeRecursiveGroups :: [(CoreBndr, CoreExpr)] -> [CoreBind]
makeRecursiveGroups
= (SCC (CoreBndr, CoreExpr) -> CoreBind)
-> [SCC (CoreBndr, CoreExpr)] -> [CoreBind]
forall a b. (a -> b) -> [a] -> [b]
map SCC (CoreBndr, CoreExpr) -> CoreBind
makeBind
([SCC (CoreBndr, CoreExpr)] -> [CoreBind])
-> ([(CoreBndr, CoreExpr)] -> [SCC (CoreBndr, CoreExpr)])
-> [(CoreBndr, CoreExpr)]
-> [CoreBind]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Node Unique (CoreBndr, CoreExpr)] -> [SCC (CoreBndr, CoreExpr)]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
Digraph.stronglyConnCompFromEdgedVerticesUniq
([Node Unique (CoreBndr, CoreExpr)] -> [SCC (CoreBndr, CoreExpr)])
-> ([(CoreBndr, CoreExpr)] -> [Node Unique (CoreBndr, CoreExpr)])
-> [(CoreBndr, CoreExpr)]
-> [SCC (CoreBndr, CoreExpr)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((CoreBndr, CoreExpr) -> Node Unique (CoreBndr, CoreExpr))
-> [(CoreBndr, CoreExpr)] -> [Node Unique (CoreBndr, CoreExpr)]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> Node Unique (CoreBndr, CoreExpr)
makeNode
where
makeNode
:: (CoreSyn.CoreBndr,CoreSyn.CoreExpr)
-> Digraph.Node Unique.Unique (CoreSyn.CoreBndr,CoreSyn.CoreExpr)
makeNode :: (CoreBndr, CoreExpr) -> Node Unique (CoreBndr, CoreExpr)
makeNode (CoreBndr
b,CoreExpr
e) =
(CoreBndr, CoreExpr)
-> Unique -> [Unique] -> Node Unique (CoreBndr, CoreExpr)
forall key payload. payload -> key -> [key] -> Node key payload
Digraph.DigraphNode
(CoreBndr
b,CoreExpr
e)
(CoreBndr -> Unique
Var.varUnique CoreBndr
b)
(UniqSet CoreBndr -> [Unique]
forall elt. UniqSet elt -> [Unique]
UniqSet.nonDetKeysUniqSet ((CoreBndr -> Bool) -> CoreExpr -> UniqSet CoreBndr
CoreFVs.exprSomeFreeVars CoreBndr -> Bool
Var.isId CoreExpr
e))
makeBind
:: Digraph.SCC (CoreSyn.CoreBndr,CoreSyn.CoreExpr)
-> CoreSyn.CoreBind
makeBind :: SCC (CoreBndr, CoreExpr) -> CoreBind
makeBind (Digraph.AcyclicSCC (CoreBndr
b,CoreExpr
e)) = CoreBndr -> CoreExpr -> CoreBind
forall b. b -> Expr b -> Bind b
CoreSyn.NonRec CoreBndr
b CoreExpr
e
makeBind (Digraph.CyclicSCC [(CoreBndr, CoreExpr)]
bs) = [(CoreBndr, CoreExpr)] -> CoreBind
forall b. [(b, Expr b)] -> Bind b
CoreSyn.Rec [(CoreBndr, CoreExpr)]
bs
errOnDuplicateAnnotations
:: String
-> [CoreSyn.CoreBndr]
-> [[a]]
-> [(CoreSyn.CoreBndr, a)]
errOnDuplicateAnnotations :: forall a. FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
errOnDuplicateAnnotations FilePath
nm =
(a -> a -> Either FilePath a)
-> FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
forall a.
(a -> a -> Either FilePath a)
-> FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
combineAnnotationsWith a -> a -> Either FilePath a
forall {p} {p} {b}. p -> p -> Either FilePath b
err FilePath
nm
where
err :: p -> p -> Either FilePath b
err p
_ p
_ = FilePath -> Either FilePath b
forall a b. a -> Either a b
Left (FilePath -> Either FilePath b) -> FilePath -> Either FilePath b
forall a b. (a -> b) -> a -> b
$ FilePath
"A binder can't have more than one '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
nm FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' annotation."
combineAnnotationsWith
:: forall a. (a -> a -> Either String a)
-> String
-> [CoreSyn.CoreBndr]
-> [[a]]
-> [(CoreSyn.CoreBndr, a)]
combineAnnotationsWith :: forall a.
(a -> a -> Either FilePath a)
-> FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
combineAnnotationsWith a -> a -> Either FilePath a
f FilePath
nm [CoreBndr]
bndrs [[a]]
anns =
[(CoreBndr, [a])] -> [(CoreBndr, a)]
go ([CoreBndr] -> [[a]] -> [(CoreBndr, [a])]
forall a b. [a] -> [b] -> [(a, b)]
zip [CoreBndr]
bndrs [[a]]
anns)
where
go :: [(CoreSyn.CoreBndr, [a])] -> [(CoreSyn.CoreBndr, a)]
go :: [(CoreBndr, [a])] -> [(CoreBndr, a)]
go [] = []
go ((CoreBndr
_, []):[(CoreBndr, [a])]
ps) = [(CoreBndr, [a])] -> [(CoreBndr, a)]
go [(CoreBndr, [a])]
ps
go ((CoreBndr
b, (a
a:[a]
as)):[(CoreBndr, [a])]
ps) = case (a -> a -> Either FilePath a) -> a -> [a] -> Either FilePath a
forall (t :: Type -> Type) (m :: Type -> Type) b a.
(Foldable t, Monad m) =>
(b -> a -> m b) -> b -> t a -> m b
foldM a -> a -> Either FilePath a
f a
a [a]
as of
Left FilePath
err ->
FilePath -> [(CoreBndr, a)]
forall a. HasCallStack => FilePath -> a
Panic.pgmError (FilePath -> [(CoreBndr, a)]) -> FilePath -> [(CoreBndr, a)]
forall a b. (a -> b) -> a -> b
$ FilePath
"Error processing '" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
nm FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' annotations on "
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SDoc -> FilePath
Outputable.showSDocUnsafe (Name -> SDoc
pprQualified (Name -> SDoc) -> Name -> SDoc
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Name
Var.varName CoreBndr
b)
FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
":\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
err
Right a
x -> (CoreBndr
b, a
x) (CoreBndr, a) -> [(CoreBndr, a)] -> [(CoreBndr, a)]
forall a. a -> [a] -> [a]
: [(CoreBndr, [a])] -> [(CoreBndr, a)]
go [(CoreBndr, [a])]
ps
pprQualified :: Name.Name -> Outputable.SDoc
pprQualified :: Name -> SDoc
pprQualified Name
x = case Name -> Maybe Module
Name.nameModule_maybe Name
x of
Just Module
m -> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
Outputable.hcat [Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
m, SDoc
forall doc. IsLine doc => doc
Outputable.dot, Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
x]
Maybe Module
Nothing -> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
x
findAnnotationsByTargets
:: (GHC.GhcMonad m, Data a, Typeable a)
=> [Annotations.AnnTarget Name.Name]
-> m [[a]]
findAnnotationsByTargets :: forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[AnnTarget Name] -> m [[a]]
findAnnotationsByTargets [AnnTarget Name]
targets =
#if MIN_VERSION_ghc(9,0,0)
(AnnTarget Name -> m [a]) -> [AnnTarget Name] -> m [[a]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (([Word8] -> a) -> AnnTarget Name -> m [a]
forall (m :: Type -> Type) a.
(GhcMonad m, Typeable a) =>
([Word8] -> a) -> AnnTarget Name -> m [a]
GHC.findGlobalAnns [Word8] -> a
forall a. Data a => [Word8] -> a
Serialized.deserializeWithData) [AnnTarget Name]
targets
#else
mapM (GHC.findGlobalAnns GhcPlugins.deserializeWithData) targets
#endif
findAllModuleAnnotations
:: (GHC.GhcMonad m, Data a, Typeable a)
=> m [a]
findAllModuleAnnotations :: forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
m [a]
findAllModuleAnnotations = do
HscEnv
hsc_env <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
AnnEnv
ann_env <- IO AnnEnv -> m AnnEnv
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (IO AnnEnv -> m AnnEnv) -> IO AnnEnv -> m AnnEnv
forall a b. (a -> b) -> a -> b
$ HscEnv -> Maybe ModGuts -> IO AnnEnv
HscTypes.prepareAnnotations HscEnv
hsc_env Maybe ModGuts
forall a. Maybe a
Nothing
[a] -> m [a]
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ([a] -> m [a]) -> [a] -> m [a]
forall a b. (a -> b) -> a -> b
$ [[a]] -> [a]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
#if MIN_VERSION_ghc(9,4,0)
([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ (\(ModuleEnv [a]
mEnv,NameEnv [a]
nEnv) -> ModuleEnv [a] -> [[a]]
forall a. ModuleEnv a -> [a]
ModuleEnv.moduleEnvElts ModuleEnv [a]
mEnv [[a]] -> [[a]] -> [[a]]
forall a. Semigroup a => a -> a -> a
<> NameEnv [a] -> [[a]]
forall a. NameEnv a -> [a]
NameEnv.nonDetNameEnvElts NameEnv [a]
nEnv)
#elif MIN_VERSION_ghc(9,0,0)
$ (\(mEnv,nEnv) -> ModuleEnv.moduleEnvElts mEnv <> NameEnv.nameEnvElts nEnv)
#else
$ UniqFM.nonDetEltsUFM
#endif
((ModuleEnv [a], NameEnv [a]) -> [[a]])
-> (ModuleEnv [a], NameEnv [a]) -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
Annotations.deserializeAnns
#if MIN_VERSION_ghc(9,0,0)
[Word8] -> a
forall a. Data a => [Word8] -> a
Serialized.deserializeWithData
#else
GhcPlugins.deserializeWithData
#endif
AnnEnv
ann_env
findNamedAnnotations
:: (GHC.GhcMonad m, Data a, Typeable a)
=> [CoreSyn.CoreBndr]
-> m [[a]]
findNamedAnnotations :: forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[CoreBndr] -> m [[a]]
findNamedAnnotations [CoreBndr]
bndrs =
[AnnTarget Name] -> m [[a]]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[AnnTarget Name] -> m [[a]]
findAnnotationsByTargets ((CoreBndr -> AnnTarget Name) -> [CoreBndr] -> [AnnTarget Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> AnnTarget Name
forall name. name -> AnnTarget name
Annotations.NamedTarget (Name -> AnnTarget Name)
-> (CoreBndr -> Name) -> CoreBndr -> AnnTarget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
Var.varName) [CoreBndr]
bndrs)
findPrimitiveGuardAnnotations
:: GHC.GhcMonad m
=> [CoreSyn.CoreBndr]
-> m [(Text.Text, (PrimitiveGuard ()))]
findPrimitiveGuardAnnotations :: forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(Text, PrimitiveGuard ())]
findPrimitiveGuardAnnotations [CoreBndr]
bndrs = do
[[PrimitiveGuard ()]]
anns0 <- [CoreBndr] -> m [[PrimitiveGuard ()]]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[CoreBndr] -> m [[a]]
findNamedAnnotations [CoreBndr]
bndrs
let anns1 :: [(CoreBndr, PrimitiveGuard ())]
anns1 = (PrimitiveGuard ()
-> PrimitiveGuard () -> Either FilePath (PrimitiveGuard ()))
-> FilePath
-> [CoreBndr]
-> [[PrimitiveGuard ()]]
-> [(CoreBndr, PrimitiveGuard ())]
forall a.
(a -> a -> Either FilePath a)
-> FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
combineAnnotationsWith PrimitiveGuard ()
-> PrimitiveGuard () -> Either FilePath (PrimitiveGuard ())
forall {a} {a}.
PrimitiveGuard a
-> PrimitiveGuard a -> Either FilePath (PrimitiveGuard ())
combinePrimGuards FilePath
"PrimitiveGuard" [CoreBndr]
bndrs [[PrimitiveGuard ()]]
anns0
[(Text, PrimitiveGuard ())] -> m [(Text, PrimitiveGuard ())]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (((CoreBndr, PrimitiveGuard ()) -> (Text, PrimitiveGuard ()))
-> [(CoreBndr, PrimitiveGuard ())] -> [(Text, PrimitiveGuard ())]
forall a b. (a -> b) -> [a] -> [b]
map ((CoreBndr -> Text)
-> (CoreBndr, PrimitiveGuard ()) -> (Text, PrimitiveGuard ())
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (Name -> Text
qualifiedNameString' (Name -> Text) -> (CoreBndr -> Name) -> CoreBndr -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
Var.varName)) [(CoreBndr, PrimitiveGuard ())]
anns1)
where
combinePrimGuards :: PrimitiveGuard a
-> PrimitiveGuard a -> Either FilePath (PrimitiveGuard ())
combinePrimGuards PrimitiveGuard a
a PrimitiveGuard a
b = case (PrimitiveGuard a
a,PrimitiveGuard a
b) of
(HasBlackBox [PrimitiveWarning]
x a
_, HasBlackBox [PrimitiveWarning]
y a
_) -> PrimitiveGuard () -> Either FilePath (PrimitiveGuard ())
forall a b. b -> Either a b
Right ([PrimitiveWarning] -> () -> PrimitiveGuard ()
forall a. [PrimitiveWarning] -> a -> PrimitiveGuard a
HasBlackBox ([PrimitiveWarning]
x[PrimitiveWarning] -> [PrimitiveWarning] -> [PrimitiveWarning]
forall a. [a] -> [a] -> [a]
++[PrimitiveWarning]
y) ())
(PrimitiveGuard a
DontTranslate , PrimitiveGuard a
DontTranslate) -> PrimitiveGuard () -> Either FilePath (PrimitiveGuard ())
forall a b. b -> Either a b
Right PrimitiveGuard ()
forall a. PrimitiveGuard a
DontTranslate
(PrimitiveGuard a
_,PrimitiveGuard a
_) -> FilePath -> Either FilePath (PrimitiveGuard ())
forall a b. a -> Either a b
Left FilePath
"One binder can't have both HasBlackBox and DontTranslate annotations."
findCustomReprAnnotations
:: GHC.GhcMonad m
=> m [DataRepr']
findCustomReprAnnotations :: forall (m :: Type -> Type). GhcMonad m => m [DataRepr']
findCustomReprAnnotations =
(DataReprAnn -> DataRepr') -> [DataReprAnn] -> [DataRepr']
forall a b. (a -> b) -> [a] -> [b]
map DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' ([DataReprAnn] -> [DataRepr']) -> m [DataReprAnn] -> m [DataRepr']
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> m [DataReprAnn]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
m [a]
findAllModuleAnnotations
findSynthesizeAnnotations
:: GHC.GhcMonad m
=> [CoreSyn.CoreBndr]
-> m [(CoreSyn.CoreBndr, TopEntity)]
findSynthesizeAnnotations :: forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m [(CoreBndr, TopEntity)]
findSynthesizeAnnotations [CoreBndr]
bndrs = do
[[TopEntity]]
anns <- [CoreBndr] -> m [[TopEntity]]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[CoreBndr] -> m [[a]]
findNamedAnnotations [CoreBndr]
bndrs
[(CoreBndr, TopEntity)] -> m [(CoreBndr, TopEntity)]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FilePath -> [CoreBndr] -> [[TopEntity]] -> [(CoreBndr, TopEntity)]
forall a. FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
errOnDuplicateAnnotations FilePath
"Synthesize" [CoreBndr]
bndrs (([TopEntity] -> [TopEntity]) -> [[TopEntity]] -> [[TopEntity]]
forall a b. (a -> b) -> [a] -> [b]
map ((TopEntity -> Bool) -> [TopEntity] -> [TopEntity]
forall a. (a -> Bool) -> [a] -> [a]
filter TopEntity -> Bool
isSyn) [[TopEntity]]
anns))
where
isSyn :: TopEntity -> Bool
isSyn (Synthesize {}) = Bool
True
isSyn TopEntity
_ = Bool
False
findTestBenches ::
GHC.GhcMonad m =>
[CoreSyn.CoreBndr] ->
m (Map.Map CoreSyn.CoreBndr [CoreSyn.CoreBndr])
findTestBenches :: forall (m :: Type -> Type).
GhcMonad m =>
[CoreBndr] -> m (Map CoreBndr [CoreBndr])
findTestBenches [CoreBndr]
bndrs0 = do
[[TopEntity]]
anns <- [CoreBndr] -> m [[TopEntity]]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[CoreBndr] -> m [[a]]
findNamedAnnotations [CoreBndr]
bndrs0
let
duts0 :: Map CoreBndr [CoreBndr]
duts0 = (Map CoreBndr [CoreBndr]
-> (CoreBndr, CoreBndr) -> Map CoreBndr [CoreBndr])
-> Map CoreBndr [CoreBndr]
-> [(CoreBndr, CoreBndr)]
-> Map CoreBndr [CoreBndr]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map CoreBndr [CoreBndr]
-> (CoreBndr, CoreBndr) -> Map CoreBndr [CoreBndr]
forall {k} {a}. Ord k => Map k [a] -> (k, a) -> Map k [a]
insertTb Map CoreBndr [CoreBndr]
forall k a. Map k a
Map.empty ([[(CoreBndr, CoreBndr)]] -> [(CoreBndr, CoreBndr)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ((CoreBndr -> [TopEntity] -> [(CoreBndr, CoreBndr)])
-> [CoreBndr] -> [[TopEntity]] -> [[(CoreBndr, CoreBndr)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith CoreBndr -> [TopEntity] -> [(CoreBndr, CoreBndr)]
go0 [CoreBndr]
bndrs0 [[TopEntity]]
anns))
duts1 :: Map CoreBndr [CoreBndr]
duts1 = Map CoreBndr [CoreBndr] -> Map CoreBndr [CoreBndr]
specialCaseMagicName Map CoreBndr [CoreBndr]
duts0
Map CoreBndr [CoreBndr] -> m (Map CoreBndr [CoreBndr])
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Map CoreBndr [CoreBndr]
duts1
where
insertTb :: Map k [a] -> (k, a) -> Map k [a]
insertTb Map k [a]
m (k
dut, a
tb) = ([a] -> [a] -> [a]) -> k -> [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
(<>) k
dut [a
tb] Map k [a]
m
bndrsMap :: HashMap Text CoreBndr
bndrsMap = [(Text, CoreBndr)] -> HashMap Text CoreBndr
forall k v. (Eq k, Hashable k) => [(k, v)] -> HashMap k v
HashMap.fromList ((CoreBndr -> (Text, CoreBndr)) -> [CoreBndr] -> [(Text, CoreBndr)]
forall a b. (a -> b) -> [a] -> [b]
map (\CoreBndr
x -> (CoreBndr -> Text
toQualNm CoreBndr
x, CoreBndr
x)) [CoreBndr]
bndrs0)
specialCaseMagicName :: Map CoreBndr [CoreBndr] -> Map CoreBndr [CoreBndr]
specialCaseMagicName Map CoreBndr [CoreBndr]
m =
let
topEntM :: Maybe CoreBndr
topEntM = (CoreBndr -> Bool) -> [CoreBndr] -> Maybe CoreBndr
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"topEntity") (FilePath -> Bool) -> (CoreBndr -> FilePath) -> CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> FilePath
varNameString) [CoreBndr]
bndrs0
tbM :: Maybe CoreBndr
tbM = (CoreBndr -> Bool) -> [CoreBndr] -> Maybe CoreBndr
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
==FilePath
"testBench") (FilePath -> Bool) -> (CoreBndr -> FilePath) -> CoreBndr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> FilePath
varNameString) [CoreBndr]
bndrs0
in
case (Maybe CoreBndr
topEntM, Maybe CoreBndr
tbM) of
(Just CoreBndr
dut, Just CoreBndr
tb) -> Map CoreBndr [CoreBndr]
-> (CoreBndr, CoreBndr) -> Map CoreBndr [CoreBndr]
forall {k} {a}. Ord k => Map k [a] -> (k, a) -> Map k [a]
insertTb Map CoreBndr [CoreBndr]
m (CoreBndr
dut, CoreBndr
tb)
(Maybe CoreBndr, Maybe CoreBndr)
_ -> Map CoreBndr [CoreBndr]
m
go0 :: CoreBndr -> [TopEntity] -> [(CoreBndr, CoreBndr)]
go0 CoreBndr
bndr [TopEntity]
anns = (TopEntity -> Maybe (CoreBndr, CoreBndr))
-> [TopEntity] -> [(CoreBndr, CoreBndr)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (CoreBndr -> TopEntity -> Maybe (CoreBndr, CoreBndr)
go1 CoreBndr
bndr) [TopEntity]
anns
go1 :: CoreBndr -> TopEntity -> Maybe (CoreBndr, CoreBndr)
go1 CoreBndr
tbBndr (TestBench Name
dutNm) =
case Text -> HashMap Text CoreBndr -> Maybe CoreBndr
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup (FilePath -> Text
Text.pack (Name -> FilePath
forall a. Show a => a -> FilePath
show Name
dutNm)) HashMap Text CoreBndr
bndrsMap of
Maybe CoreBndr
Nothing ->
FilePath -> Maybe (CoreBndr, CoreBndr)
forall a. HasCallStack => FilePath -> a
Panic.pgmError [I.i|
Could not find design under test #{show (show dutNm)}, associated with
test bench #{show (toQualNm tbBndr)}. Note that testbenches should be
exported from the same module as the design under test.
|]
Just CoreBndr
dutBndr ->
(CoreBndr, CoreBndr) -> Maybe (CoreBndr, CoreBndr)
forall a. a -> Maybe a
Just (CoreBndr
dutBndr, CoreBndr
tbBndr)
go1 CoreBndr
_ TopEntity
_ = Maybe (CoreBndr, CoreBndr)
forall a. Maybe a
Nothing
toQualNm :: Var.Var -> Text.Text
toQualNm :: CoreBndr -> Text
toQualNm CoreBndr
bndr =
let
bndrNm :: Name
bndrNm = CoreBndr -> Name
Var.varName CoreBndr
bndr
occName :: Text
occName = FilePath -> Text
Text.pack (OccName -> FilePath
OccName.occNameString (Name -> OccName
Name.nameOccName Name
bndrNm))
in
Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe
Text
occName
(\Text
modName -> Text
modName Text -> Text -> Text
`Text.append` (Char
'.' Char -> Text -> Text
`Text.cons` Text
occName))
(Name -> Maybe Text
modNameM Name
bndrNm)
findPrimitiveAnnotations
:: GHC.GhcMonad m
=> HDL
-> [CoreSyn.CoreBndr]
-> m [Either UnresolvedPrimitive FilePath]
findPrimitiveAnnotations :: forall (m :: Type -> Type).
GhcMonad m =>
HDL -> [CoreBndr] -> m [Either UnresolvedPrimitive FilePath]
findPrimitiveAnnotations HDL
hdl [CoreBndr]
bndrs = do
let
annTargets :: [Maybe (AnnTarget name)]
annTargets =
(Name -> Maybe (AnnTarget name))
-> [Name] -> [Maybe (AnnTarget name)]
forall a b. (a -> b) -> [a] -> [b]
map
((Module -> AnnTarget name)
-> Maybe Module -> Maybe (AnnTarget name)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap Module -> AnnTarget name
forall name. Module -> AnnTarget name
Annotations.ModuleTarget (Maybe Module -> Maybe (AnnTarget name))
-> (Name -> Maybe Module) -> Name -> Maybe (AnnTarget name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Maybe Module
Name.nameModule_maybe)
((CoreBndr -> Name) -> [CoreBndr] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Name
Var.varName [CoreBndr]
bndrs)
let
targets :: [AnnTarget Name]
targets =
([Maybe (AnnTarget Name)] -> [AnnTarget Name]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (AnnTarget Name)]
forall {name}. [Maybe (AnnTarget name)]
annTargets) [AnnTarget Name] -> [AnnTarget Name] -> [AnnTarget Name]
forall a. [a] -> [a] -> [a]
++
((CoreBndr -> AnnTarget Name) -> [CoreBndr] -> [AnnTarget Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> AnnTarget Name
forall name. name -> AnnTarget name
Annotations.NamedTarget (Name -> AnnTarget Name)
-> (CoreBndr -> Name) -> CoreBndr -> AnnTarget Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CoreBndr -> Name
Var.varName) [CoreBndr]
bndrs)
[[Primitive]]
anns <- [AnnTarget Name] -> m [[Primitive]]
forall (m :: Type -> Type) a.
(GhcMonad m, Data a, Typeable a) =>
[AnnTarget Name] -> m [[a]]
findAnnotationsByTargets [AnnTarget Name]
targets
[[Either UnresolvedPrimitive FilePath]]
-> [Either UnresolvedPrimitive FilePath]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Either UnresolvedPrimitive FilePath]]
-> [Either UnresolvedPrimitive FilePath])
-> m [[Either UnresolvedPrimitive FilePath]]
-> m [Either UnresolvedPrimitive FilePath]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
((AnnTarget Name, Primitive)
-> m [Either UnresolvedPrimitive FilePath])
-> [(AnnTarget Name, Primitive)]
-> m [[Either UnresolvedPrimitive FilePath]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (HDL
-> (AnnTarget Name, Primitive)
-> m [Either UnresolvedPrimitive FilePath]
forall (m :: Type -> Type).
MonadIO m =>
HDL
-> (AnnTarget Name, Primitive)
-> m [Either UnresolvedPrimitive FilePath]
getUnresolvedPrimitives HDL
hdl)
([[(AnnTarget Name, Primitive)]] -> [(AnnTarget Name, Primitive)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[(AnnTarget Name, Primitive)]] -> [(AnnTarget Name, Primitive)])
-> [[(AnnTarget Name, Primitive)]] -> [(AnnTarget Name, Primitive)]
forall a b. (a -> b) -> a -> b
$ (AnnTarget Name -> [Primitive] -> [(AnnTarget Name, Primitive)])
-> [AnnTarget Name]
-> [[Primitive]]
-> [[(AnnTarget Name, Primitive)]]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\AnnTarget Name
t -> (Primitive -> (AnnTarget Name, Primitive))
-> [Primitive] -> [(AnnTarget Name, Primitive)]
forall a b. (a -> b) -> [a] -> [b]
map ((,) AnnTarget Name
t)) [AnnTarget Name]
targets [[Primitive]]
anns)
parseModule :: GHC.GhcMonad m => GHC.ModSummary -> m GHC.ParsedModule
parseModule :: forall (m :: Type -> Type).
GhcMonad m =>
ModSummary -> m ParsedModule
parseModule ModSummary
modSum = do
#if MIN_VERSION_ghc(9,2,0)
(GHC.ParsedModule ModSummary
pmModSum ParsedSource
pmParsedSource [FilePath]
extraSrc) <-
ModSummary -> m ParsedModule
forall (m :: Type -> Type).
GhcMonad m =>
ModSummary -> m ParsedModule
GHC.parseModule ModSummary
modSum
ParsedModule -> m ParsedModule
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModSummary -> ParsedSource -> [FilePath] -> ParsedModule
GHC.ParsedModule
(ModSummary -> ModSummary
disableOptimizationsFlags ModSummary
pmModSum)
ParsedSource
pmParsedSource [FilePath]
extraSrc)
#else
(GHC.ParsedModule pmModSum pmParsedSource extraSrc anns) <-
GHC.parseModule modSum
return (GHC.ParsedModule
(disableOptimizationsFlags pmModSum)
pmParsedSource extraSrc anns)
#endif
disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary
disableOptimizationsFlags :: ModSummary -> ModSummary
disableOptimizationsFlags ms :: ModSummary
ms@(GHC.ModSummary {Bool
FilePath
[(PkgQual, Located ModuleName)]
Maybe StringBuffer
Maybe HsParsedModule
Maybe UTCTime
Fingerprint
Module
ModLocation
HscSource
DynFlags
ms_hspp_opts :: ModSummary -> DynFlags
ms_location :: ModSummary -> ModLocation
ms_mod :: Module
ms_hsc_src :: HscSource
ms_location :: ModLocation
ms_hs_hash :: Fingerprint
ms_obj_date :: Maybe UTCTime
ms_dyn_obj_date :: Maybe UTCTime
ms_iface_date :: Maybe UTCTime
ms_hie_date :: Maybe UTCTime
ms_srcimps :: [(PkgQual, Located ModuleName)]
ms_textual_imps :: [(PkgQual, Located ModuleName)]
ms_ghc_prim_import :: Bool
ms_parsed_mod :: Maybe HsParsedModule
ms_hspp_file :: FilePath
ms_hspp_opts :: DynFlags
ms_hspp_buf :: Maybe StringBuffer
ms_mod :: ModSummary -> Module
ms_hsc_src :: ModSummary -> HscSource
ms_hs_hash :: ModSummary -> Fingerprint
ms_obj_date :: ModSummary -> Maybe UTCTime
ms_dyn_obj_date :: ModSummary -> Maybe UTCTime
ms_iface_date :: ModSummary -> Maybe UTCTime
ms_hie_date :: ModSummary -> Maybe UTCTime
ms_srcimps :: ModSummary -> [(PkgQual, Located ModuleName)]
ms_textual_imps :: ModSummary -> [(PkgQual, Located ModuleName)]
ms_ghc_prim_import :: ModSummary -> Bool
ms_parsed_mod :: ModSummary -> Maybe HsParsedModule
ms_hspp_file :: ModSummary -> FilePath
ms_hspp_buf :: ModSummary -> Maybe StringBuffer
..})
= ModSummary
ms {GHC.ms_hspp_opts = dflags}
where
dflags :: DynFlags
dflags = DynFlags -> DynFlags
unwantedOptimizationFlags (DynFlags
ms_hspp_opts
{ DynFlags.reductionDepth = 1000
#if !MIN_VERSION_ghc(9,4,0)
, DynFlags.optLevel = 2
#endif
})
unwantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags
unwantedOptimizationFlags :: DynFlags -> DynFlags
unwantedOptimizationFlags DynFlags
df =
(DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
DynFlags.xopt_unset
((DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> GeneralFlag -> DynFlags
DynFlags.gopt_unset DynFlags
df [GeneralFlag]
unwanted) [Extension]
unwantedLang
where
unwanted :: [GeneralFlag]
unwanted = [ GeneralFlag
Opt_LiberateCase
, GeneralFlag
Opt_SpecConstr
, GeneralFlag
Opt_IgnoreAsserts
, GeneralFlag
Opt_DoEtaReduction
, GeneralFlag
Opt_UnboxStrictFields
, GeneralFlag
Opt_UnboxSmallStrictFields
, GeneralFlag
Opt_RegsGraph
, GeneralFlag
Opt_RegsGraph
, GeneralFlag
Opt_PedanticBottoms
, GeneralFlag
Opt_CmmSink
, GeneralFlag
Opt_CmmElimCommonBlocks
, GeneralFlag
Opt_OmitYields
, GeneralFlag
Opt_IgnoreInterfacePragmas
, GeneralFlag
Opt_OmitInterfacePragmas
, GeneralFlag
Opt_IrrefutableTuples
, GeneralFlag
Opt_Loopification
, GeneralFlag
Opt_CprAnal
, GeneralFlag
Opt_FullLaziness
]
unwantedLang :: [Extension]
unwantedLang = [ Extension
LangExt.Strict
, Extension
LangExt.StrictData
]
setWantedLanguageExtensions :: GHC.DynFlags -> GHC.DynFlags
setWantedLanguageExtensions :: DynFlags -> DynFlags
setWantedLanguageExtensions DynFlags
df =
(DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> GeneralFlag -> DynFlags
DynFlags.gopt_set
((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
DynFlags.xopt_unset
((DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' DynFlags -> Extension -> DynFlags
DynFlags.xopt_set DynFlags
df [Extension]
wantedLanguageExtensions)
[Extension]
unwantedLanguageExtensions)
[GeneralFlag]
wantedOptimizations
where
wantedOptimizations :: [GeneralFlag]
wantedOptimizations =
[ GeneralFlag
Opt_CSE
, GeneralFlag
Opt_Specialise
, GeneralFlag
Opt_DoLambdaEtaExpansion
, GeneralFlag
Opt_CaseMerge
, GeneralFlag
Opt_DictsCheap
, GeneralFlag
Opt_ExposeAllUnfoldings
, GeneralFlag
Opt_ForceRecomp
, GeneralFlag
Opt_EnableRewriteRules
, GeneralFlag
Opt_SimplPreInlining
, GeneralFlag
Opt_StaticArgumentTransformation
, GeneralFlag
Opt_FloatIn
, GeneralFlag
Opt_DictsStrict
, GeneralFlag
Opt_DmdTxDictSel
, GeneralFlag
Opt_Strictness
, GeneralFlag
Opt_SpecialiseAggressively
, GeneralFlag
Opt_CrossModuleSpecialise
]
removeStrictnessAnnotations ::
GHC.ParsedModule
-> GHC.ParsedModule
removeStrictnessAnnotations :: ParsedModule -> ParsedModule
removeStrictnessAnnotations ParsedModule
pm =
ParsedModule
pm {GHC.pm_parsed_source = fmap rmPS (GHC.pm_parsed_source pm)}
where
rmPS :: HsModule p -> HsModule p
rmPS HsModule p
hsm = HsModule p
hsm {GHC.hsmodDecls = (fmap . fmap) rmHSD (GHC.hsmodDecls hsm)}
rmHSD :: HsDecl GhcPs -> HsDecl GhcPs
rmHSD (GHC.TyClD XTyClD GhcPs
x TyClDecl GhcPs
tyClDecl) = XTyClD GhcPs -> TyClDecl GhcPs -> HsDecl GhcPs
forall p. XTyClD p -> TyClDecl p -> HsDecl p
GHC.TyClD XTyClD GhcPs
x (TyClDecl GhcPs -> TyClDecl GhcPs
rmTyClD TyClDecl GhcPs
tyClDecl)
rmHSD HsDecl GhcPs
hsd = HsDecl GhcPs
hsd
rmTyClD :: TyClDecl GhcPs -> TyClDecl GhcPs
rmTyClD dc :: TyClDecl GhcPs
dc@(GHC.DataDecl {}) = TyClDecl GhcPs
dc {GHC.tcdDataDefn = rmDataDefn (GHC.tcdDataDefn dc)}
rmTyClD TyClDecl GhcPs
tyClD = TyClDecl GhcPs
tyClD
#if MIN_VERSION_ghc(9,2,0)
rmDataDefn :: GHC.HsDataDefn GHC.GhcPs -> GHC.HsDataDefn GHC.GhcPs
#endif
rmDataDefn :: HsDataDefn GhcPs -> HsDataDefn GhcPs
rmDataDefn HsDataDefn GhcPs
hdf = HsDataDefn GhcPs
hdf {GHC.dd_cons = (fmap . fmap) rmCD (GHC.dd_cons hdf)}
rmCD :: ConDecl GhcPs -> ConDecl GhcPs
rmCD gadt :: ConDecl GhcPs
gadt@(GHC.ConDeclGADT {}) = ConDecl GhcPs
gadt {GHC.con_res_ty = rmHsType (GHC.con_res_ty gadt)
#if MIN_VERSION_ghc(9,2,0)
,GHC.con_g_args = rmGConDetails (GHC.con_g_args gadt)
#else
,GHC.con_args = rmConDetails (GHC.con_args gadt)
#endif
}
rmCD h98 :: ConDecl GhcPs
h98@(GHC.ConDeclH98 {}) = ConDecl GhcPs
h98 {GHC.con_args = rmConDetails (GHC.con_args h98)}
#if !MIN_VERSION_ghc(9,0,0)
rmCD xcon = xcon
#endif
#if MIN_VERSION_ghc(9,4,0)
rmGConDetails :: GHC.HsConDeclGADTDetails GHC.GhcPs -> GHC.HsConDeclGADTDetails GHC.GhcPs
rmGConDetails :: HsConDeclGADTDetails GhcPs -> HsConDeclGADTDetails GhcPs
rmGConDetails (GHC.PrefixConGADT [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
args) = [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
-> HsConDeclGADTDetails GhcPs
forall pass.
[HsScaled pass (LBangType pass)] -> HsConDeclGADTDetails pass
GHC.PrefixConGADT ((HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
rmHsScaledType [HsScaled GhcPs (XRec GhcPs (HsType GhcPs))]
[HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
args)
rmGConDetails (GHC.RecConGADT XRec GhcPs [XRec GhcPs (ConDeclField GhcPs)]
rec LHsUniToken "->" "\8594" GhcPs
tkn) = XRec GhcPs [XRec GhcPs (ConDeclField GhcPs)]
-> LHsUniToken "->" "\8594" GhcPs -> HsConDeclGADTDetails GhcPs
forall pass.
XRec pass [LConDeclField pass]
-> LHsUniToken "->" "\8594" pass -> HsConDeclGADTDetails pass
GHC.RecConGADT ((([GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
-> GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall a b.
(a -> b) -> GenLocated SrcSpanAnnL a -> GenLocated SrcSpanAnnL b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap (([GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
-> GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
-> ((ConDeclField GhcPs -> ConDeclField GhcPs)
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
-> (ConDeclField GhcPs -> ConDeclField GhcPs)
-> GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs))
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)])
-> ((ConDeclField GhcPs -> ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs))
-> (ConDeclField GhcPs -> ConDeclField GhcPs)
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
-> [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConDeclField GhcPs -> ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
-> GenLocated SrcSpanAnnA (ConDeclField GhcPs)
forall a b.
(a -> b) -> GenLocated SrcSpanAnnA a -> GenLocated SrcSpanAnnA b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap) ConDeclField GhcPs -> ConDeclField GhcPs
rmConDeclF XRec GhcPs [XRec GhcPs (ConDeclField GhcPs)]
GenLocated
SrcSpanAnnL [GenLocated SrcSpanAnnA (ConDeclField GhcPs)]
rec) LHsUniToken "->" "\8594" GhcPs
tkn
#elif MIN_VERSION_ghc(9,2,0)
rmGConDetails :: GHC.HsConDeclGADTDetails GHC.GhcPs -> GHC.HsConDeclGADTDetails GHC.GhcPs
rmGConDetails (GHC.PrefixConGADT args) = GHC.PrefixConGADT (fmap rmHsScaledType args)
rmGConDetails (GHC.RecConGADT rec) = GHC.RecConGADT ((fmap . fmap . fmap) rmConDeclF rec)
#endif
#if MIN_VERSION_ghc(9,2,0)
rmConDetails :: HsConDetails
tyarg
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(f (f (f (ConDeclField GhcPs))))
-> HsConDetails
tyarg
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(f (f (f (ConDeclField GhcPs))))
rmConDetails (GHC.PrefixCon [tyarg]
tys [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
args) = [tyarg]
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> HsConDetails
tyarg
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(f (f (f (ConDeclField GhcPs))))
forall tyarg arg rec.
[tyarg] -> [arg] -> HsConDetails tyarg arg rec
GHC.PrefixCon [tyarg]
tys ((HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
-> [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
rmHsScaledType [HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))]
args)
rmConDetails (GHC.InfixCon HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
l HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
r) = HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsConDetails
tyarg
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(f (f (f (ConDeclField GhcPs))))
forall tyarg arg rec. arg -> arg -> HsConDetails tyarg arg rec
GHC.InfixCon (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
rmHsScaledType HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
l) (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
rmHsScaledType HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
r)
#elif MIN_VERSION_ghc(9,0,0)
rmConDetails (GHC.PrefixCon args) = GHC.PrefixCon (fmap rmHsScaledType args)
rmConDetails (GHC.InfixCon l r) = GHC.InfixCon (rmHsScaledType l) (rmHsScaledType r)
#else
rmConDetails (GHC.PrefixCon args) = GHC.PrefixCon (fmap rmHsType args)
rmConDetails (GHC.InfixCon l r) = GHC.InfixCon (rmHsType l) (rmHsType r)
#endif
rmConDetails (GHC.RecCon f (f (f (ConDeclField GhcPs)))
rec) = f (f (f (ConDeclField GhcPs)))
-> HsConDetails
tyarg
(HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
(f (f (f (ConDeclField GhcPs))))
forall tyarg arg rec. rec -> HsConDetails tyarg arg rec
GHC.RecCon (((f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
-> f (f (f (ConDeclField GhcPs))) -> f (f (f (ConDeclField GhcPs)))
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
-> f (f (f (ConDeclField GhcPs)))
-> f (f (f (ConDeclField GhcPs))))
-> ((ConDeclField GhcPs -> ConDeclField GhcPs)
-> f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
-> (ConDeclField GhcPs -> ConDeclField GhcPs)
-> f (f (f (ConDeclField GhcPs)))
-> f (f (f (ConDeclField GhcPs)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (f (ConDeclField GhcPs) -> f (ConDeclField GhcPs))
-> f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs))
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((f (ConDeclField GhcPs) -> f (ConDeclField GhcPs))
-> f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
-> ((ConDeclField GhcPs -> ConDeclField GhcPs)
-> f (ConDeclField GhcPs) -> f (ConDeclField GhcPs))
-> (ConDeclField GhcPs -> ConDeclField GhcPs)
-> f (f (ConDeclField GhcPs))
-> f (f (ConDeclField GhcPs))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConDeclField GhcPs -> ConDeclField GhcPs)
-> f (ConDeclField GhcPs) -> f (ConDeclField GhcPs)
forall a b. (a -> b) -> f a -> f b
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap) ConDeclField GhcPs -> ConDeclField GhcPs
rmConDeclF f (f (f (ConDeclField GhcPs)))
rec)
rmHsType :: GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
rmHsType = (GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs))
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
forall on. Uniplate on => (on -> on) -> on -> on
transform XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
GenLocated SrcSpanAnnA (HsType GhcPs)
-> GenLocated SrcSpanAnnA (HsType GhcPs)
go
where
#if MIN_VERSION_ghc(9,2,0)
go ::
GHC.LBangType GHC.GhcPs ->
GHC.LBangType GHC.GhcPs
#endif
go :: XRec GhcPs (HsType GhcPs) -> XRec GhcPs (HsType GhcPs)
go (XRec GhcPs (HsType GhcPs) -> HsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
GHC.unLoc -> GHC.HsBangTy XBangTy GhcPs
_ HsSrcBang
_ XRec GhcPs (HsType GhcPs)
ty) = XRec GhcPs (HsType GhcPs)
ty
go XRec GhcPs (HsType GhcPs)
ty = XRec GhcPs (HsType GhcPs)
ty
#if MIN_VERSION_ghc(9,0,0)
rmHsScaledType :: HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
rmHsScaledType = (HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs)))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall on. Uniplate on => (on -> on) -> on -> on
transform HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
-> HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
go
where
#if MIN_VERSION_ghc(9,2,0)
go ::
GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs) ->
GHC.HsScaled GHC.GhcPs (GHC.LBangType GHC.GhcPs)
#endif
go :: HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
-> HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
go (GHC.HsScaled HsArrow GhcPs
m (XRec GhcPs (HsType GhcPs) -> HsType GhcPs
GenLocated SrcSpanAnnA (HsType GhcPs) -> HsType GhcPs
forall l e. GenLocated l e -> e
GHC.unLoc -> GHC.HsBangTy XBangTy GhcPs
_ HsSrcBang
_ XRec GhcPs (HsType GhcPs)
ty)) = HsArrow GhcPs
-> GenLocated SrcSpanAnnA (HsType GhcPs)
-> HsScaled GhcPs (GenLocated SrcSpanAnnA (HsType GhcPs))
forall pass a. HsArrow pass -> a -> HsScaled pass a
GHC.HsScaled HsArrow GhcPs
m XRec GhcPs (HsType GhcPs)
GenLocated SrcSpanAnnA (HsType GhcPs)
ty
go HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
ty = HsScaled GhcPs (XRec GhcPs (HsType GhcPs))
ty
#endif
rmConDeclF :: ConDeclField GhcPs -> ConDeclField GhcPs
rmConDeclF ConDeclField GhcPs
cdf = ConDeclField GhcPs
cdf {GHC.cd_fld_type = rmHsType (GHC.cd_fld_type cdf)}
preludePkgId :: String
preludePkgId :: FilePath
preludePkgId = $(lift $ pkgIdFromTypeable (undefined :: TopEntity))
checkForInvalidPrelude :: Monad m => HscTypes.ModGuts -> m ()
checkForInvalidPrelude :: forall (m :: Type -> Type). Monad m => ModGuts -> m ()
checkForInvalidPrelude ModGuts
guts =
case (FilePath -> Bool) -> [FilePath] -> [FilePath]
forall a. (a -> Bool) -> [a] -> [a]
filter FilePath -> Bool
isWrongPrelude [FilePath]
pkgIds of
[] -> () -> m ()
forall a. a -> m a
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
(FilePath
x:[FilePath]
_) -> ClashException -> m ()
forall a e. Exception e => e -> a
throw (SrcSpan -> FilePath -> Maybe FilePath -> ClashException
ClashException SrcSpan
noSrcSpan (FilePath -> FilePath
msgWrongPrelude FilePath
x) Maybe FilePath
forall a. Maybe a
Nothing)
where
#if MIN_VERSION_ghc(9,4,0)
pkgs :: Set UnitId
pkgs = Dependencies -> Set UnitId
HscTypes.dep_direct_pkgs (Dependencies -> Set UnitId)
-> (ModGuts -> Dependencies) -> ModGuts -> Set UnitId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> Dependencies
HscTypes.mg_deps (ModGuts -> Set UnitId) -> ModGuts -> Set UnitId
forall a b. (a -> b) -> a -> b
$ ModGuts
guts
#else
pkgs = HscTypes.dep_pkgs . HscTypes.mg_deps $ guts
#endif
#if MIN_VERSION_ghc(9,4,0)
pkgIds :: [FilePath]
pkgIds = (UnitId -> FilePath) -> [UnitId] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (UnitId -> FilePath
UnitTypes.unitIdString) (Set UnitId -> [UnitId]
forall a. Set a -> [a]
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Set UnitId
pkgs)
#elif MIN_VERSION_ghc(9,0,0)
pkgIds = map (UnitTypes.unitIdString . fst) pkgs
#else
pkgIds = map (GhcPlugins.installedUnitIdString . fst) pkgs
#endif
prelude :: FilePath
prelude = FilePath
"clash-prelude-"
isPrelude :: FilePath -> Bool
isPrelude FilePath
pkg = case Int -> FilePath -> (FilePath, FilePath)
forall a. Int -> [a] -> ([a], [a])
splitAt (FilePath -> Int
forall a. [a] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length FilePath
prelude) FilePath
pkg of
(FilePath
x,Char
y:FilePath
_) | FilePath
x FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
prelude Bool -> Bool -> Bool
&& Char -> Bool
isDigit Char
y -> Bool
True
(FilePath, FilePath)
_ -> Bool
False
isWrongPrelude :: FilePath -> Bool
isWrongPrelude FilePath
pkg = FilePath -> Bool
isPrelude FilePath
pkg Bool -> Bool -> Bool
&& FilePath
pkg FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
preludePkgId
msgWrongPrelude :: FilePath -> FilePath
msgWrongPrelude FilePath
pkg = [FilePath] -> FilePath
unlines [FilePath
"Clash only works with the exact clash-prelude it was built with."
,FilePath
"Clash was built with: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
preludePkgId
,FilePath
"So can't run with: " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
pkg
]