{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd,
                     2017     , Google Inc.
                     2021     , QBayLogic B.V.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  QBayLogic B.V. <devops@qbaylogic.com>
-}

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

-- External Modules
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, when)
import           Data.List.Extra                 (nubSort)
import           Control.Exception               (throwIO)
#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, 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)
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

-- GHC API
#if MIN_VERSION_ghc(9,0,0)
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.Driver.Types as HscTypes
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           GHC.Utils.Misc (OverridingBool)
import qualified GHC.Types.Var as Var
import qualified GHC.Driver.Ways as Ways
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

-- Internal Modules
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 (m :: Type -> Type) a. Monad m => a -> m a
return FilePath
libDir
       Maybe FilePath
Nothing     -> FilePath -> IO FilePath
forall a. FilePath -> a
Panic.pgmError FilePath
noGHC
     ExitFailure Int
i -> case Int
i of
       Int
127         -> FilePath -> IO FilePath
forall a. FilePath -> a
Panic.pgmError FilePath
noGHC
       Int
i'          -> FilePath -> IO FilePath
forall a. 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 =
     -- Create the process
  do (Handle
_, Handle
pOut, Handle
_, ProcessHandle
handle) <- FilePath -> IO (Handle, Handle, Handle, ProcessHandle)
runInteractiveCommand FilePath
command
     -- Wait for the process to finish and store its exit code
     ExitCode
exitCode <- ProcessHandle -> IO ExitCode
waitForProcess ProcessHandle
handle
     -- Get the standard output.
     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)
     -- return both the output and the exit code.
     (Maybe FilePath, ExitCode) -> IO (Maybe FilePath, ExitCode)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Maybe FilePath
output, ExitCode
exitCode)
#endif

-- | Search databases for given module
loadExternalModule
  :: (HasCallStack, GHC.GhcMonad m)
  => HDL
  -> String
  -- ^ Module name. Can either be a filepath pointing to a .hs file, or a
  -- qualified module name (example: "Data.List").
  -> m (Either
          SomeException
          ( [CoreSyn.CoreBndr]                     -- Root binders
          , FamInstEnv.FamInstEnv                  -- Local type family instances
          , GHC.ModuleName                         -- Module name
          , LoadedBinders
          , [CoreSyn.CoreBind]                     -- All bindings
          ) )
#if MIN_VERSION_ghc(9,0,0)
loadExternalModule hdl modName0 = MC.try $ do
#else
loadExternalModule :: 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.
(ExceptionMonad m, Exception e) =>
m a -> m (Either e a)
Exception.gtry (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
#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)
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 (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 :: 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 (m :: Type -> Type) a. Monad m => a -> m a
return DynFlags
df
      Maybe DynFlags
Nothing -> do
        -- Make sure we read the .ghc environment files
        DynFlags
df <- do
          DynFlags
df <- m DynFlags
forall (m :: Type -> Type). GhcMonad m => m DynFlags
GHC.getSessionDynFlags
#if MIN_VERSION_ghc(9,0,0)
          df1 <- liftIO (GHC.interpretPackageEnv df)
          _ <- GHC.setSessionDynFlags df1

#else
          [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
df {pkgDatabase :: Maybe [(FilePath, [PackageConfig])]
DynFlags.pkgDatabase = Maybe [(FilePath, [PackageConfig])]
forall a. Maybe a
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 { pluginModNames :: [ModuleName]
DynFlags.pluginModNames = [ModuleName] -> [ModuleName]
forall a. Eq a => [a] -> [a]
nub ([ModuleName] -> [ModuleName]) -> [ModuleName] -> [ModuleName]
forall a b. (a -> b) -> a -> b
$
                                ModuleName
ghcTyLitNormPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: ModuleName
ghcTyLitExtrPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
:
                                ModuleName
ghcTyLitKNPlugin ModuleName -> [ModuleName] -> [ModuleName]
forall a. a -> [a] -> [a]
: DynFlags -> [ModuleName]
DynFlags.pluginModNames DynFlags
df1
                           , useColor :: OverridingBool
DynFlags.useColor = OverridingBool
useColor
                           , importPaths :: [FilePath]
DynFlags.importPaths = [FilePath]
idirs
                           }
        DynFlags -> m DynFlags
forall (m :: Type -> Type) a. Monad m => a -> m a
return DynFlags
dfPlug

  let dflags1 :: DynFlags
dflags1 = DynFlags
dflags
                  { optLevel :: Int
DynFlags.optLevel = Int
2
                  , ghcMode :: GhcMode
DynFlags.ghcMode  = GhcMode
GHC.CompManager
                  , ghcLink :: GhcLink
DynFlags.ghcLink  = GhcLink
GHC.LinkInMemory
                  , hscTarget :: HscTarget
DynFlags.hscTarget
#if MIN_VERSION_ghc(9,0,0)
                      = if Ways.hostIsProfiled
#else
                      = if Bool
DynFlags.rtsIsProfiled
#endif
                           then HscTarget
DynFlags.HscNothing
                           else DynFlags -> HscTarget
DynFlags.defaultObjectTarget (DynFlags -> HscTarget) -> DynFlags -> HscTarget
forall a b. (a -> b) -> a -> b
$
#if !MIN_VERSION_ghc(8,10,0)
                                  DynFlags.targetPlatform
#endif
                                    DynFlags
dflags
                  , reductionDepth :: IntWithInf
DynFlags.reductionDepth = IntWithInf
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 (m :: Type -> Type) a. Monad m => a -> m a
return ())

#if MIN_VERSION_ghc(9,0,0)
  _ <- GHC.setSessionDynFlags dflags3
  hscenv <- GHC.getSession
  dflags4 <- MonadUtils.liftIO (DynamicLoading.initializePlugins hscenv dflags3)
  _ <- GHC.setSessionDynFlags dflags4
#else
  HscEnv
hscenv <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  DynFlags
dflags4 <- IO DynFlags -> m DynFlags
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (HscEnv -> DynFlags -> IO DynFlags
DynamicLoading.initializePlugins HscEnv
hscenv DynFlags
dflags3)
  [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
dflags4
#endif

  () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()

-- | Load a module from a Haskell file. Function does NOT look in currently
-- loaded modules.
loadLocalModule
  :: GHC.GhcMonad m
  => HDL
  -> String
  -- ^ Module name. Can either be a filepath pointing to a .hs file, or a
  -- qualified module name (example: "Data.List").
  -> m ( [CoreSyn.CoreBndr]                     -- Root binders
       , FamInstEnv.FamInstEnv                  -- Local type family instances
       , GHC.ModuleName                         -- Module name
       , LoadedBinders
       , [CoreSyn.CoreBind]                     -- All bindings
       )
loadLocalModule :: HDL
-> FilePath
-> m ([CoreBndr], FamInstEnv, ModuleName, LoadedBinders,
      [CoreBind])
loadLocalModule HDL
hdl FilePath
modName = do
  Target
target <- FilePath -> Maybe Phase -> m Target
forall (m :: Type -> Type).
GhcMonad m =>
FilePath -> Maybe Phase -> m Target
GHC.guessTarget FilePath
modName Maybe Phase
forall a. Maybe a
Nothing
  [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
      -- 'topSortModuleGraph' ensures that modGraph2, and hence tidiedMods
      -- are in topological order, i.e. the root module is last.
      modGraph2 :: [ModSummary]
modGraph2 = [SCC ModSummary] -> [ModSummary]
forall a. [SCC a] -> [a]
Digraph.flattenSCCs (Bool -> ModuleGraph -> Maybe ModuleName -> [SCC ModSummary]
GHC.topSortModuleGraph Bool
True ModuleGraph
modGraph' Maybe ModuleName
forall a. Maybe a
Nothing)

  IO () -> m ()
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
    [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
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)

    -- The purpose of the home package table (HPT) is to track
    -- the already compiled modules, so subsequent modules can
    -- rely/use those compilation results
    --
    -- We need to update the home package table (HPT) ourselves
    -- as we can no longer depend on 'GHC.load' to create a
    -- proper HPT.
    --
    -- The reason we have to cannot rely on 'GHC.load' is that
    -- it runs the rename/type-checker, which we also run in
    -- the code above. This would mean that the renamer/type-checker
    -- is run twice, which in turn means that template haskell
    -- splices are run twice.
    --
    -- Given that TH splices can do non-trivial computation and I/O,
    -- running TH twice must be avoid.
    TypecheckedModule
tcMod' <- TypecheckedModule -> m TypecheckedModule
forall mod (m :: Type -> Type).
(TypecheckedMod mod, GhcMonad m) =>
mod -> m mod
GHC.loadModule TypecheckedModule
tcMod
    ModGuts
dsMod <- (DesugaredModule -> ModGuts) -> m DesugaredModule -> m ModGuts
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 (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
    (CgGuts
tidy_guts,ModDetails
_) <- IO (CgGuts, ModDetails) -> m (CgGuts, ModDetails)
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
$ HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
TidyPgm.tidyProgram HscEnv
hsc_env ModGuts
simpl_guts
    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
    [InstalledUnitId]
_ <- DynFlags -> m [InstalledUnitId]
forall (m :: Type -> Type).
GhcMonad m =>
DynFlags -> m [InstalledUnitId]
GHC.setSessionDynFlags DynFlags
oldDFlags
    ([CoreBind], FamInstEnv) -> m ([CoreBind], FamInstEnv)
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 (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. [a] -> a
last ([ModSummary] -> ModuleName) -> [ModSummary] -> ModuleName
forall a b. (a -> b) -> a -> b
$ [ModSummary]
modGraph2

  -- Because tidiedMods is in topological order, binders is also, and hence
  -- the binders belonging to the "root" module are the last binders
  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. [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)

  -- Find local primitive annotations
  [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 :: Seq (Either UnresolvedPrimitive FilePath)
lbPrims=LoadedBinders -> Seq (Either UnresolvedPrimitive FilePath)
lbPrims LoadedBinders
loaded0 Seq (Either UnresolvedPrimitive FilePath)
-> Seq (Either UnresolvedPrimitive FilePath)
-> Seq (Either UnresolvedPrimitive FilePath)
forall a. Semigroup a => a -> a -> a
<> [Either UnresolvedPrimitive FilePath]
-> Seq (Either UnresolvedPrimitive FilePath)
forall a. [a] -> Seq a
Seq.fromList [Either UnresolvedPrimitive FilePath]
localPrims}

  let allBinders :: [CoreBind]
allBinders = [[CoreBind]] -> [CoreBind]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[CoreBind]]
binders [CoreBind] -> [CoreBind] -> [CoreBind]
forall a. [a] -> [a] -> [a]
++ [(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 (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 ()
  -- ^ Allows us to have some initial action, such as sharing a linker state
  -- See https://github.com/clash-lang/clash-compiler/issues/1686 and
  -- https://mail.haskell.org/pipermail/ghc-devs/2021-March/019605.html
  -> OverridingBool
  -- ^ Use color
  -> HDL
  -- ^ HDL target
  -> String
  -- ^ Module name
  -> Maybe (DynFlags.DynFlags)
  -- ^ Flags to run GHC with
  -> [FilePath]
  -- ^ Import dirs to use when no DynFlags are provided
  -> IO ( [CoreSyn.CoreBind]                     -- Binders
        , [(CoreSyn.CoreBndr,Int)]               -- Class operations
        , [CoreSyn.CoreBndr]                     -- Unlocatable Expressions
        , FamInstEnv.FamInstEnvs
        , [(CoreSyn.CoreBndr, Maybe TopEntity, Bool)]  -- binder + synthesize annotation + is testbench?
        , [Either UnresolvedPrimitive FilePath]
        , [DataRepr']
        , [(Text.Text, PrimitiveGuard ())]
        , HashMap Text.Text VDomainConfiguration -- domain names to configuration
        )
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 (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
    -- 'mainFunIs' is set to Nothing due to issue #1304:
    -- https://github.com/clash-lang/clash-compiler/issues/1304
    OverridingBool -> Maybe DynFlags -> [FilePath] -> Ghc ()
forall (m :: Type -> Type).
GhcMonad m =>
OverridingBool -> Maybe DynFlags -> [FilePath] -> m ()
setupGhc OverridingBool
useColor ((\DynFlags
d -> DynFlags
d{mainFunIs :: Maybe FilePath
GHC.mainFunIs=Maybe FilePath
forall a. Maybe a
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 (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 (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

    -- TODO: We currently load the transitive closure of _all_ bindings found
    -- TODO: in the top module. This is wasteful if one or more binders don't
    -- TODO: contribute to any top entities. This effect is worsened when using
    -- TODO: -main-is, which only synthesizes a single top entity (and all its
    -- TODO: dependencies).
    ([CoreBndr]
rootIds, FamInstEnv
modFamInstEnvs, ModuleName
_rootModule, LoadedBinders{Set CoreBndr
Map CoreBndr Int
Map CoreBndr CoreExpr
DeclCache
Seq (Either UnresolvedPrimitive FilePath)
Seq DataRepr'
lbCache :: LoadedBinders -> DeclCache
lbReprs :: LoadedBinders -> Seq DataRepr'
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbCache :: DeclCache
lbReprs :: Seq DataRepr'
lbPrims :: Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: Set CoreBndr
lbClassOps :: Map CoreBndr Int
lbBinders :: Map CoreBndr CoreExpr
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive FilePath)
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
..}, [CoreBind]
allBinders) <-
      -- We need to try and load external modules first, because we can't
      -- recover from errors in 'loadLocalModule'.
      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 (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 (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 (t :: Type -> Type) a. Foldable t => t a -> Int
length [CoreBndr]
allBinderIds Int -> Ghc UTCTime -> Ghc UTCTime
`seq` IO UTCTime -> Ghc UTCTime
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 (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

    -- Get type family instances: accumulated by GhcMonad during
    -- 'loadExternalBinders' / 'loadExternalExprs'
    HscEnv
hscEnv <- Ghc HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
    FamInstEnvs
famInstEnvs <- do
      (Messages
msgs, Maybe FamInstEnvs
m) <- IO (Messages, Maybe FamInstEnvs)
-> Ghc (Messages, Maybe FamInstEnvs)
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
TcRnMonad.liftIO (IO (Messages, Maybe FamInstEnvs)
 -> Ghc (Messages, Maybe FamInstEnvs))
-> IO (Messages, Maybe FamInstEnvs)
-> Ghc (Messages, Maybe FamInstEnvs)
forall a b. (a -> b) -> a -> b
$ HscEnv -> TcM FamInstEnvs -> IO (Messages, Maybe FamInstEnvs)
forall a. HscEnv -> TcM a -> IO (Messages, Maybe a)
TcRnMonad.initTcInteractive HscEnv
hscEnv TcM FamInstEnvs
FamInst.tcGetFamInstEnvs
      case Maybe FamInstEnvs
m of
        Maybe FamInstEnvs
Nothing -> IO FamInstEnvs -> Ghc FamInstEnvs
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 (ErrorMessages -> SourceError
HscTypes.mkSrcErr (Messages -> ErrorMessages
forall a b. (a, b) -> b
snd Messages
msgs))
        Just FamInstEnvs
x  -> FamInstEnvs -> Ghc FamInstEnvs
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
      -- All binders synthesized with Synthesize, all binders annotated with
      -- TestBench and the binders they're pointing to, plus magically named
      -- functions called "topEntity" or "testBench". Synthesized in case user
      -- didn't specify a particular target.
      isMagicName :: FilePath -> Bool
isMagicName = (FilePath -> [FilePath] -> 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

      -- Top entities we wish to synthesize. Users can filter these with -main-is.
      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 ->
            -- Use requested top entity.
            --
            -- TODO: Look up associated test benches in 'benchAnn'. This would
            --       be wasted effort if implemented right now, as 'getMainTopEntity'
            --       would later remove them again. Functionality of that function
            --       should be moved here.
            --
            -- TODO: Handle fully qualified names to -main-is
            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. FilePath -> a
Panic.pgmError [I.i|
                  No top-level function called '#{mainIsNm}' found. Did you
                  forget to export it?
                |]
              Just CoreBndr
top ->
                -- Note that we return /all/ top entities here, even the ones
                -- we don't which to synthesize. 'getMainTopEntity' will later
                -- restrict this to just this top entity (and its dependencies,
                -- which is why we return everything in the first place).
                --
                -- This is quite wasteful though; als Clash will load all
                -- definitions even though it will end up using just a few. TODO
                [CoreBndr] -> [CoreBndr]
forall a. Ord a => [a] -> [a]
nubSort (CoreBndr
topCoreBndr -> [CoreBndr] -> [CoreBndr]
forall a. a -> [a] -> [a]
:[CoreBndr]
allImplicit)
          Maybe FilePath
Nothing ->
            -- User didn't specify anything.
            case [CoreBndr]
allImplicit of
              [] ->
                FilePath -> [CoreBndr]
forall a. 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

      -- Include whether found top entity is a test bench
      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       -- include top entity annotation (if any)
        , CoreBndr
tid CoreBndr -> Set CoreBndr -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set CoreBndr
allBenchIds  -- indicate whether top entity is test bench
        )

    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
. (FastString -> Text) -> Maybe FastString -> Maybe Text
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap FastString -> Text
fsToText (Maybe FastString -> Maybe Text)
-> (FamInst -> Maybe FastString) -> FamInst -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Maybe FastString
Type.isStrLitTy (Type -> Maybe FastString)
-> (FamInst -> Type) -> FamInst -> Maybe FastString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Type] -> Type
forall a. [a] -> a
head ([Type] -> Type) -> (FamInst -> [Type]) -> FamInst -> 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 (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 (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 (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 (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq (Either UnresolvedPrimitive FilePath)
lbPrims
           , Seq DataRepr' -> [DataRepr']
forall (t :: Type -> Type) a. Foldable t => t a -> [a]
toList Seq DataRepr'
reprs1
           , [(Text, PrimitiveGuard ())]
primGuards
           , HashMap Text VDomainConfiguration
knownConfMap
           )

-- | Given a type that represents the RHS of a KnownConf type family instance,
-- unpack the fields of the DomainConfiguration and make a VDomainConfiguration.
--
unpackKnownConf :: Type.Type -> VDomainConfiguration
unpackKnownConf :: Type -> VDomainConfiguration
unpackKnownConf Type
ty
  | [Type
d,Type
p,Type
ae,Type
rk,Type
ib,Type
rp] <- Type -> [Type]
Type.tyConAppArgs Type
ty
    -- Domain name
  , Just FilePath
dom <- (FastString -> FilePath) -> Maybe FastString -> Maybe FilePath
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)
    -- Period
  , Just Natural
period <- (Integer -> Natural) -> Maybe Integer -> Maybe Natural
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)
    -- Active Edge
  , TyCon
aeTc <- 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)
    -- Reset Kind
  , TyCon
rkTc <- 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)
    -- Init Behavior
  , TyCon
ibTc <- 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)
    -- Reset Polarity
  , TyCon
rpTc <- 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
$ $(FilePath
curLoc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Could not unpack domain configuration."
 where
  asActiveEdge :: HasCallStack => String -> ActiveEdge
  asActiveEdge :: 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
$ $(FilePath
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 :: 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
$ $(FilePath
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 :: 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
$ $(FilePath
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 :: 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
$ $(FilePath
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)

-- | Given a set of bindings, make explicit non-recursive bindings and
-- recursive binding groups.
--
-- Needed because:
-- 1. GHC does not preserve this information in interface files,
-- 2. Binders in Clash's BindingsMap are not allowed to be mutually recursive,
--    only self-recursive.
-- 3. Clash.GHC.GenerateBindings.mkBindings turns groups of mutually recursive
--    bindings into self-recursive bindings which can go into the BindingsMap.
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
  -- ^ Name of annotation
  -> [CoreSyn.CoreBndr]
  -- ^ Binders searched for
  -> [[a]]
  -- ^ Parsed annotations
  -> [(CoreSyn.CoreBndr, a)]
errOnDuplicateAnnotations :: FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
errOnDuplicateAnnotations FilePath
nm [CoreBndr]
bndrs [[a]]
anns =
  [(CoreBndr, [a])] -> [(CoreBndr, a)]
forall a. [(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)]
forall a. [(CoreBndr, [a])] -> [(CoreBndr, a)]
go [(CoreBndr, [a])]
ps
  go ((CoreBndr
b, [a
p]):[(CoreBndr, [a])]
ps)  = (CoreBndr
b, a
p) (CoreBndr, a) -> [(CoreBndr, a)] -> [(CoreBndr, a)]
forall a. a -> [a] -> [a]
: ([(CoreBndr, [a])] -> [(CoreBndr, a)]
forall a. [(CoreBndr, [a])] -> [(CoreBndr, a)]
go [(CoreBndr, [a])]
ps)
  go ((CoreBndr
b, [a]
_):[(CoreBndr, [a])]
_)  =
    FilePath -> [(CoreBndr, a)]
forall a. FilePath -> a
Panic.pgmError (FilePath -> [(CoreBndr, a)]) -> FilePath -> [(CoreBndr, a)]
forall a b. (a -> b) -> a -> b
$ FilePath
"The following value has multiple "
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"'" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
nm FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"' annotations: "
                  FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ SDoc -> FilePath
Outputable.showSDocUnsafe (CoreBndr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CoreBndr
b)

-- | Find annotations by given targets
findAnnotationsByTargets
  :: GHC.GhcMonad m
  => Typeable a
  => Data a
  => [Annotations.AnnTarget Name.Name]
  -> m [[a]]
findAnnotationsByTargets :: [AnnTarget Name] -> m [[a]]
findAnnotationsByTargets [AnnTarget Name]
targets =
#if MIN_VERSION_ghc(9,0,0)
  mapM (GHC.findGlobalAnns Serialized.deserializeWithData) targets
#else
  (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)
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
GhcPlugins.deserializeWithData) [AnnTarget Name]
targets
#endif

-- | Find all annotations of a certain type in all modules seen so far.
findAllModuleAnnotations
  :: GHC.GhcMonad m
  => Data a
  => Typeable a
  => m [a]
findAllModuleAnnotations :: 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 (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 (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,0,0)
         $ (\(mEnv,nEnv) -> ModuleEnv.moduleEnvElts mEnv <> NameEnv.nameEnvElts nEnv)
#else
         ([[a]] -> [a]) -> [[a]] -> [a]
forall a b. (a -> b) -> a -> b
$ UniqFM [a] -> [[a]]
forall elt. UniqFM elt -> [elt]
UniqFM.nonDetEltsUFM
#endif
         (UniqFM [a] -> [[a]]) -> UniqFM [a] -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([Word8] -> a) -> AnnEnv -> UniqFM [a]
forall a. Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
Annotations.deserializeAnns
#if MIN_VERSION_ghc(9,0,0)
              Serialized.deserializeWithData
#else
              [Word8] -> a
forall a. Data a => [Word8] -> a
GhcPlugins.deserializeWithData
#endif
              AnnEnv
ann_env

-- | Find all annotations belonging to all binders seen so far.
findNamedAnnotations
  :: GHC.GhcMonad m
  => Data a
  => Typeable a
  => [CoreSyn.CoreBndr]
  -> m [[a]]
findNamedAnnotations :: [CoreBndr] -> m [[a]]
findNamedAnnotations [CoreBndr]
bndrs =
  [AnnTarget Name] -> m [[a]]
forall (m :: Type -> Type) a.
(GhcMonad m, Typeable a, Data 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 :: [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 = FilePath
-> [CoreBndr]
-> [[PrimitiveGuard ()]]
-> [(CoreBndr, PrimitiveGuard ())]
forall a. FilePath -> [CoreBndr] -> [[a]] -> [(CoreBndr, a)]
errOnDuplicateAnnotations FilePath
"PrimitiveGuard" [CoreBndr]
bndrs [[PrimitiveGuard ()]]
anns0
  [(Text, PrimitiveGuard ())] -> m [(Text, PrimitiveGuard ())]
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 (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)

-- | Find annotations of type @DataReprAnn@ and convert them to @DataRepr'@
findCustomReprAnnotations
  :: GHC.GhcMonad m
  => m [DataRepr']
findCustomReprAnnotations :: 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

-- | Find synthesize annotations and make sure each binder has no more than
-- a single annotation.
findSynthesizeAnnotations
  :: GHC.GhcMonad m
  => [CoreSyn.CoreBndr]
  -> m [(CoreSyn.CoreBndr, TopEntity)]
findSynthesizeAnnotations :: [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 (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

-- | Find test bench annotations and return a map tying top entities to their
-- test benches. If there is a binder called @testBench@ _without_ an annotation
-- it assumed to belong to a binder called @topEntity@. If the latter does not
-- exist, the function @testBench@ is left alone.
findTestBenches ::
  GHC.GhcMonad m =>
  -- | Root binders
  [CoreSyn.CoreBndr] ->
  -- | (design under test, associated test benches)
  m (Map.Map CoreSyn.CoreBndr [CoreSyn.CoreBndr])
findTestBenches :: [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 (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 (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)

  -- Special case magic name 'testBench'. See function documentation.
  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 + go1: map over all annotations; look for test bench annotations and
  -- tie them to top entities indicated in the annotation.
  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. 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

-- | Create a fully qualified name from a var, excluding package. Example
-- output: @Clash.Sized.Internal.BitVector.low@.
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)

-- | Find primitive annotations bound to given binders, or annotations made
-- in modules of those binders.
findPrimitiveAnnotations
  :: GHC.GhcMonad m
  => HDL
  -> [CoreSyn.CoreBndr]
  -> m [Either UnresolvedPrimitive FilePath]
findPrimitiveAnnotations :: 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 (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, Typeable a, Data 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)
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 :: ModSummary -> m ParsedModule
parseModule ModSummary
modSum = do
  (GHC.ParsedModule ModSummary
pmModSum ParsedSource
pmParsedSource [FilePath]
extraSrc ApiAnns
anns) <-
    ModSummary -> m ParsedModule
forall (m :: Type -> Type).
GhcMonad m =>
ModSummary -> m ParsedModule
GHC.parseModule ModSummary
modSum
  ParsedModule -> m ParsedModule
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModSummary -> ParsedSource -> [FilePath] -> ApiAnns -> ParsedModule
GHC.ParsedModule
            (ModSummary -> ModSummary
disableOptimizationsFlags ModSummary
pmModSum)
            ParsedSource
pmParsedSource [FilePath]
extraSrc ApiAnns
anns)

disableOptimizationsFlags :: GHC.ModSummary -> GHC.ModSummary
disableOptimizationsFlags :: ModSummary -> ModSummary
disableOptimizationsFlags ms :: ModSummary
ms@(GHC.ModSummary {FilePath
[(Maybe FastString, Located ModuleName)]
Maybe UTCTime
Maybe HsParsedModule
Maybe StringBuffer
UTCTime
HscSource
ModLocation
Module
DynFlags
ms_mod :: ModSummary -> Module
ms_hsc_src :: ModSummary -> HscSource
ms_location :: ModSummary -> ModLocation
ms_hs_date :: ModSummary -> UTCTime
ms_obj_date :: ModSummary -> Maybe UTCTime
ms_iface_date :: ModSummary -> Maybe UTCTime
ms_hie_date :: ModSummary -> Maybe UTCTime
ms_srcimps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_textual_imps :: ModSummary -> [(Maybe FastString, Located ModuleName)]
ms_parsed_mod :: ModSummary -> Maybe HsParsedModule
ms_hspp_file :: ModSummary -> FilePath
ms_hspp_buf :: ModSummary -> Maybe StringBuffer
ms_hspp_buf :: Maybe StringBuffer
ms_hspp_opts :: DynFlags
ms_hspp_file :: FilePath
ms_parsed_mod :: Maybe HsParsedModule
ms_textual_imps :: [(Maybe FastString, Located ModuleName)]
ms_srcimps :: [(Maybe FastString, Located ModuleName)]
ms_hie_date :: Maybe UTCTime
ms_iface_date :: Maybe UTCTime
ms_obj_date :: Maybe UTCTime
ms_hs_date :: UTCTime
ms_location :: ModLocation
ms_hsc_src :: HscSource
ms_mod :: Module
ms_hspp_opts :: ModSummary -> DynFlags
..})
  = ModSummary
ms {ms_hspp_opts :: DynFlags
GHC.ms_hspp_opts = DynFlags
dflags}
  where
    dflags :: DynFlags
dflags = DynFlags -> DynFlags
unwantedOptimizationFlags (DynFlags
ms_hspp_opts
              { optLevel :: Int
DynFlags.optLevel = Int
2
              , reductionDepth :: IntWithInf
DynFlags.reductionDepth = IntWithInf
1000
              })

unwantedOptimizationFlags :: GHC.DynFlags -> GHC.DynFlags
unwantedOptimizationFlags :: DynFlags -> DynFlags
unwantedOptimizationFlags DynFlags
df =
  (DynFlags -> Extension -> DynFlags)
-> DynFlags -> [Extension] -> DynFlags
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 (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 -- Perform unrolling of recursive RHS: avoid
               , GeneralFlag
Opt_SpecConstr -- Creates local-functions: avoid
               , GeneralFlag
Opt_IgnoreAsserts -- We don't care about assertions
               , GeneralFlag
Opt_DoEtaReduction -- We want eta-expansion
               , GeneralFlag
Opt_UnboxStrictFields -- Unboxed types are not handled properly: avoid
               , GeneralFlag
Opt_UnboxSmallStrictFields -- Unboxed types are not handled properly: avoid
               , GeneralFlag
Opt_RegsGraph -- Don't care
               , GeneralFlag
Opt_RegsGraph -- Don't care
               , GeneralFlag
Opt_PedanticBottoms -- Stops eta-expansion through case: avoid
               , GeneralFlag
Opt_LlvmTBAA -- Don't care
               , GeneralFlag
Opt_CmmSink -- Don't care
               , GeneralFlag
Opt_CmmElimCommonBlocks -- Don't care
               , GeneralFlag
Opt_OmitYields -- Don't care
               , GeneralFlag
Opt_IgnoreInterfacePragmas -- We need all the unfoldings we can get
               , GeneralFlag
Opt_OmitInterfacePragmas -- We need all the unfoldings we can get
               , GeneralFlag
Opt_IrrefutableTuples -- Introduce irrefutPatError: avoid
               , GeneralFlag
Opt_Loopification -- STG pass, don't care
               , GeneralFlag
Opt_CprAnal -- The worker/wrapper introduced by CPR breaks Clash, see [NOTE: CPR breaks Clash]
               , GeneralFlag
Opt_FullLaziness -- increases sharing, but seems to result in worse circuits (in both area and propagation delay)
               ]

    -- Coercions between Integer and Clash' numeric primitives cause Clash to
    -- fail. As strictness only affects simulation behavior, removing them
    -- is perfectly safe.
    unwantedLang :: [Extension]
unwantedLang = [ Extension
LangExt.Strict
                   , Extension
LangExt.StrictData
                   ]

-- [NOTE: CPR breaks Clash]
-- We used to completely disable strictness analysis because it causes GHC to
-- do the so-called "Constructed Product Result" (CPR) analysis, which in turn
-- creates an annoying worker/wrapper which does the following:
--
--   * Scrutinise a Signal, and pack the head and tail of the
--     Signal in an unboxed tuple.
--   * Scrutinise on the unboxed tuple, and recreate the Signal.
--
-- This is problematic because the 'Signal' type is essentially treated as a "transparent"
-- type by the Clash compiler, so observing its constructor leads to all kinds
-- of problems.
--
-- The current solution is to disable strictness analysis in "Clash.Signal.Internal"
-- so that functions manipulating 'Signal' constructor do not get a strictness/
-- demand/CPR annotation, which in turn ensures GHC doesn't create worker/wrappers
-- for when these functions are called in user code.
--
-- Ultimately we should stop treating Signal as a "transparent" type and deal
-- handling of the Signal type, and the involved co-recursive functions,
-- properly. At the moment, Clash cannot deal with this recursive type and the
-- recursive functions involved, and hence we need to disable this useful transformation. After
-- everything is done properly, we should enable it again.


setWantedLanguageExtensions :: GHC.DynFlags -> GHC.DynFlags
setWantedLanguageExtensions :: DynFlags -> DynFlags
setWantedLanguageExtensions DynFlags
df =
   (DynFlags -> GeneralFlag -> DynFlags)
-> DynFlags -> [GeneralFlag] -> DynFlags
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 (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 (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 -- CSE
    , GeneralFlag
Opt_Specialise -- Specialise on types, specialise type-class-overloaded function defined in this module for the types
    , GeneralFlag
Opt_DoLambdaEtaExpansion -- transform nested series of lambdas into one with multiple arguments, helps us achieve only top-level lambdas
    , GeneralFlag
Opt_CaseMerge -- We want fewer case-statements
    , GeneralFlag
Opt_DictsCheap -- Makes dictionaries seem cheap to optimizer: hopefully inline
    , GeneralFlag
Opt_ExposeAllUnfoldings -- We need all the unfoldings we can get
    , GeneralFlag
Opt_ForceRecomp -- Force recompilation: never bad
    , GeneralFlag
Opt_EnableRewriteRules -- Reduce number of functions
    , GeneralFlag
Opt_SimplPreInlining -- Inlines simple functions, we only care about the major first-order structure
    , GeneralFlag
Opt_StaticArgumentTransformation -- Turn on the static argument transformation, which turns a recursive function into a non-recursive one with a local recursive loop.
    , GeneralFlag
Opt_FloatIn -- Moves let-bindings inwards, although it defeats the normal-form with a single top-level let-binding, it helps with other transformations
    , GeneralFlag
Opt_DictsStrict -- Hopefully helps remove class method selectors
    , GeneralFlag
Opt_DmdTxDictSel -- I think demand and strictness are related, strictness helps with dead-code, enable
    , GeneralFlag
Opt_Strictness -- Strictness analysis helps with dead-code analysis. However, see [NOTE: CPR breaks Clash]
    , GeneralFlag
Opt_SpecialiseAggressively -- Needed to compile Fixed point number functions quickly
    , GeneralFlag
Opt_CrossModuleSpecialise -- Needed to compile Fixed point number functions quickly
    ]

-- | Remove all strictness annotations:
--
-- * Remove strictness annotations from data type declarations
--   (only works for data types that are currently being compiled, i.e.,
--    that are not part of a pre-compiled imported library)
--
-- We need to remove strictness annotations because GHC will introduce casts
-- between Integer and Clash' numeric primitives otherwise, where Clash will
-- error when it sees such casts. The reason it does this is because
-- Integer is a completely unconstrained integer type and is currently
-- (erroneously) translated to a 64-bit integer in the HDL; this means that
-- we could lose bits when the original numeric type had more bits than 64.
--
-- Removing these strictness annotations is perfectly safe, as they only
-- affect simulation behavior.
removeStrictnessAnnotations ::
     GHC.ParsedModule
  -> GHC.ParsedModule
removeStrictnessAnnotations :: ParsedModule -> ParsedModule
removeStrictnessAnnotations ParsedModule
pm =
    ParsedModule
pm {pm_parsed_source :: ParsedSource
GHC.pm_parsed_source = (HsModule GhcPs -> HsModule GhcPs) -> ParsedSource -> ParsedSource
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap HsModule GhcPs -> HsModule GhcPs
rmPS (ParsedModule -> ParsedSource
GHC.pm_parsed_source ParsedModule
pm)}
  where
    -- rmPS :: GHC.DataId name => GHC.HsModule name -> GHC.HsModule name
    rmPS :: HsModule GhcPs -> HsModule GhcPs
rmPS HsModule GhcPs
hsm = HsModule GhcPs
hsm {hsmodDecls :: [LHsDecl GhcPs]
GHC.hsmodDecls = ((LHsDecl GhcPs -> LHsDecl GhcPs)
-> [LHsDecl GhcPs] -> [LHsDecl GhcPs]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LHsDecl GhcPs -> LHsDecl GhcPs)
 -> [LHsDecl GhcPs] -> [LHsDecl GhcPs])
-> ((HsDecl GhcPs -> HsDecl GhcPs)
    -> LHsDecl GhcPs -> LHsDecl GhcPs)
-> (HsDecl GhcPs -> HsDecl GhcPs)
-> [LHsDecl GhcPs]
-> [LHsDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (HsDecl GhcPs -> HsDecl GhcPs) -> LHsDecl GhcPs -> LHsDecl GhcPs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap) HsDecl GhcPs -> HsDecl GhcPs
rmHSD (HsModule GhcPs -> [LHsDecl GhcPs]
forall pass. HsModule pass -> [LHsDecl pass]
GHC.hsmodDecls HsModule GhcPs
hsm)}

    -- rmHSD :: GHC.DataId name => GHC.HsDecl name -> GHC.HsDecl name
    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 :: GHC.DataId name => GHC.TyClDecl name -> GHC.TyClDecl name
    rmTyClD :: TyClDecl GhcPs -> TyClDecl GhcPs
rmTyClD dc :: TyClDecl GhcPs
dc@(GHC.DataDecl {}) = TyClDecl GhcPs
dc {tcdDataDefn :: HsDataDefn GhcPs
GHC.tcdDataDefn = HsDataDefn GhcPs -> HsDataDefn GhcPs
rmDataDefn (TyClDecl GhcPs -> HsDataDefn GhcPs
forall pass. TyClDecl pass -> HsDataDefn pass
GHC.tcdDataDefn TyClDecl GhcPs
dc)}
    rmTyClD TyClDecl GhcPs
tyClD = TyClDecl GhcPs
tyClD

    -- rmDataDefn :: GHC.DataId name => GHC.HsDataDefn name -> GHC.HsDataDefn name
    rmDataDefn :: HsDataDefn GhcPs -> HsDataDefn GhcPs
rmDataDefn HsDataDefn GhcPs
hdf = HsDataDefn GhcPs
hdf {dd_cons :: [LConDecl GhcPs]
GHC.dd_cons = ((LConDecl GhcPs -> LConDecl GhcPs)
-> [LConDecl GhcPs] -> [LConDecl GhcPs]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ((LConDecl GhcPs -> LConDecl GhcPs)
 -> [LConDecl GhcPs] -> [LConDecl GhcPs])
-> ((ConDecl GhcPs -> ConDecl GhcPs)
    -> LConDecl GhcPs -> LConDecl GhcPs)
-> (ConDecl GhcPs -> ConDecl GhcPs)
-> [LConDecl GhcPs]
-> [LConDecl GhcPs]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ConDecl GhcPs -> ConDecl GhcPs)
-> LConDecl GhcPs -> LConDecl GhcPs
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap) ConDecl GhcPs -> ConDecl GhcPs
rmCD (HsDataDefn GhcPs -> [LConDecl GhcPs]
forall pass. HsDataDefn pass -> [LConDecl pass]
GHC.dd_cons HsDataDefn GhcPs
hdf)}

    -- rmCD :: GHC.DataId name => GHC.ConDecl name -> GHC.ConDecl name
    rmCD :: ConDecl GhcPs -> ConDecl GhcPs
rmCD gadt :: ConDecl GhcPs
gadt@(GHC.ConDeclGADT {}) = ConDecl GhcPs
gadt {con_res_ty :: LHsType GhcPs
GHC.con_res_ty = LHsType GhcPs -> LHsType GhcPs
rmHsType (ConDecl GhcPs -> LHsType GhcPs
forall pass. ConDecl pass -> LHsType pass
GHC.con_res_ty ConDecl GhcPs
gadt)
                                          ,con_args :: HsConDeclDetails GhcPs
GHC.con_args   = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
forall (f :: Type -> Type) (f :: Type -> Type) (f :: Type -> Type).
(Functor f, Functor f, Functor f) =>
HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
rmConDetails (ConDecl GhcPs -> HsConDeclDetails GhcPs
forall pass. ConDecl pass -> HsConDeclDetails pass
GHC.con_args ConDecl GhcPs
gadt)
                                          }
    rmCD h98 :: ConDecl GhcPs
h98@(GHC.ConDeclH98 {})   = ConDecl GhcPs
h98  {con_args :: HsConDeclDetails GhcPs
GHC.con_args = HsConDeclDetails GhcPs -> HsConDeclDetails GhcPs
forall (f :: Type -> Type) (f :: Type -> Type) (f :: Type -> Type).
(Functor f, Functor f, Functor f) =>
HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
rmConDetails (ConDecl GhcPs -> HsConDeclDetails GhcPs
forall pass. ConDecl pass -> HsConDeclDetails pass
GHC.con_args ConDecl GhcPs
h98)}
#if !MIN_VERSION_ghc(9,0,0)
    rmCD ConDecl GhcPs
xcon                      = ConDecl GhcPs
xcon
#endif

    -- type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name])
    -- rmConDetails :: _ => GHC.HsConDeclDetails name -> GHC.HsConDeclDetails name
#if 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 :: HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
rmConDetails (GHC.PrefixCon [LHsType GhcPs]
args) = [LHsType GhcPs]
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
forall arg rec. [arg] -> HsConDetails arg rec
GHC.PrefixCon ((LHsType GhcPs -> LHsType GhcPs)
-> [LHsType GhcPs] -> [LHsType GhcPs]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap LHsType GhcPs -> LHsType GhcPs
rmHsType [LHsType GhcPs]
args)
    rmConDetails (GHC.InfixCon LHsType GhcPs
l LHsType GhcPs
r)   = LHsType GhcPs
-> LHsType GhcPs
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
forall arg rec. arg -> arg -> HsConDetails arg rec
GHC.InfixCon (LHsType GhcPs -> LHsType GhcPs
rmHsType LHsType GhcPs
l) (LHsType GhcPs -> LHsType GhcPs
rmHsType LHsType GhcPs
r)
#endif
    rmConDetails (GHC.RecCon f (f (f (ConDeclField GhcPs)))
rec)     = f (f (f (ConDeclField GhcPs)))
-> HsConDetails (LHsType GhcPs) (f (f (f (ConDeclField GhcPs))))
forall arg rec. rec -> HsConDetails arg rec
GHC.RecCon (((f (f (ConDeclField GhcPs)) -> f (f (ConDeclField GhcPs)))
-> f (f (f (ConDeclField GhcPs))) -> f (f (f (ConDeclField GhcPs)))
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 (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 (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 :: GHC.DataId name => GHC.Located (GHC.HsType name) -> GHC.Located (GHC.HsType name)
    rmHsType :: LHsType GhcPs -> LHsType GhcPs
rmHsType = (LHsType GhcPs -> LHsType GhcPs) -> LHsType GhcPs -> LHsType GhcPs
forall on. Uniplate on => (on -> on) -> on -> on
transform LHsType GhcPs -> LHsType GhcPs
forall pass. LHsType pass -> LHsType pass
go
      where
        go :: LHsType pass -> LHsType pass
go (LHsType pass -> SrcSpanLess (LHsType pass)
forall a. HasSrcSpan a => a -> SrcSpanLess a
GHC.unLoc -> GHC.HsBangTy _ _ ty) = LHsType pass
ty
        go LHsType pass
ty                               = LHsType pass
ty

#if MIN_VERSION_ghc(9,0,0)
    rmHsScaledType = transform go
      where
        go (GHC.HsScaled m (GHC.unLoc -> GHC.HsBangTy _ _ ty)) = GHC.HsScaled m ty
        go ty = ty
#endif

    -- rmConDeclF :: GHC.DataId name => GHC.ConDeclField name -> GHC.ConDeclField name
    rmConDeclF :: ConDeclField GhcPs -> ConDeclField GhcPs
rmConDeclF ConDeclField GhcPs
cdf = ConDeclField GhcPs
cdf {cd_fld_type :: LHsType GhcPs
GHC.cd_fld_type = LHsType GhcPs -> LHsType GhcPs
rmHsType (ConDeclField GhcPs -> LHsType GhcPs
forall pass. ConDeclField pass -> LBangType pass
GHC.cd_fld_type ConDeclField GhcPs
cdf)}

-- | The package id of the clash-prelude we were built with
preludePkgId :: String
preludePkgId :: FilePath
preludePkgId = $(lift $ pkgIdFromTypeable (undefined :: TopEntity))

-- | Check that we're using the same clash-prelude as we were built with
--
-- Because if they differ clash won't be able to recognize any ANNotations.
checkForInvalidPrelude :: Monad m => HscTypes.ModGuts -> m ()
checkForInvalidPrelude :: 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 (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
    pkgs :: [(InstalledUnitId, Bool)]
pkgs = Dependencies -> [(InstalledUnitId, Bool)]
HscTypes.dep_pkgs (Dependencies -> [(InstalledUnitId, Bool)])
-> (ModGuts -> Dependencies)
-> ModGuts
-> [(InstalledUnitId, Bool)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModGuts -> Dependencies
HscTypes.mg_deps (ModGuts -> [(InstalledUnitId, Bool)])
-> ModGuts -> [(InstalledUnitId, Bool)]
forall a b. (a -> b) -> a -> b
$ ModGuts
guts
#if MIN_VERSION_ghc(9,0,0)
    pkgIds = map (UnitTypes.unitIdString . fst) pkgs
#else
    pkgIds :: [FilePath]
pkgIds = ((InstalledUnitId, Bool) -> FilePath)
-> [(InstalledUnitId, Bool)] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
map (InstalledUnitId -> FilePath
GhcPlugins.installedUnitIdString (InstalledUnitId -> FilePath)
-> ((InstalledUnitId, Bool) -> InstalledUnitId)
-> (InstalledUnitId, Bool)
-> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (InstalledUnitId, Bool) -> InstalledUnitId
forall a b. (a, b) -> a
fst) [(InstalledUnitId, Bool)]
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 (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     -- check for a digit so we don't match clash-prelude-extras
      (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
                                  ]