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

    {-# LANGUAGE CPP #-}
    {-# LANGUAGE LambdaCase #-}
    {-# LANGUAGE NamedFieldPuns #-}
    {-# LANGUAGE OverloadedStrings #-}
    {-# LANGUAGE QuasiQuotes #-}

    module Clash.GHC.GenerateBindings
      (generateBindings)
    where

    import           Control.Arrow           ((***))
    import           Control.DeepSeq         (deepseq)
    import           Control.Lens            ((%~),(&),(.~))
    import           Control.Monad           (unless)
    import qualified Control.Monad.State     as State
    import qualified Control.Monad.RWS.Strict as RWS
    import           Data.Coerce             (coerce)
    import           Data.Either             (partitionEithers, lefts ,rights)
    import           Data.IntMap.Strict      (IntMap)
    import qualified Data.IntMap.Strict      as IMS
    import qualified Data.HashMap.Strict     as HashMap
    import           Data.List               (isPrefixOf)
    import           Data.Maybe              (listToMaybe)
    import qualified Data.Text               as Text
    import qualified Data.Time.Clock         as Clock

    import qualified GHC                     as GHC (Ghc)
    #if MIN_VERSION_ghc(9,0,0)
    #if MIN_VERSION_ghc(9,4,0)
    import qualified GHC.Types.SourceText    as GHC
    #endif
    #if MIN_VERSION_ghc(9,2,0)
    import qualified GHC.Utils.Panic         as GHC
    #endif
    import qualified GHC.Types.Basic         as GHC
    import qualified GHC.Core                as GHC
    import qualified GHC.Types.Demand        as GHC
    import qualified GHC.Driver.Session      as GHC
    import qualified GHC.Types.Id.Info       as GHC
    import qualified GHC.Utils.Outputable    as GHC
    import qualified GHC.Types.Name          as GHC hiding (varName)
    import qualified GHC.Core.FamInstEnv     as GHC
    import qualified GHC.Core.TyCon          as GHC
    import qualified GHC.Core.Type           as GHC
    import qualified GHC.Builtin.Types       as GHC
    import qualified GHC.Settings.Constants  as GHC
    import qualified GHC.Types.Var           as GHC
    import qualified GHC.Types.SrcLoc        as GHC
    #else
    import qualified BasicTypes              as GHC
    import qualified Constants               as GHC
    import qualified CoreSyn                 as GHC
    import qualified Demand                  as GHC
    import qualified DynFlags                as GHC
    import qualified FamInstEnv              as GHC
    import qualified IdInfo                  as GHC
    import qualified Outputable              as GHC
    import qualified Name                    as GHC hiding (varName)
    import qualified TyCon                   as GHC
    import qualified Type                    as GHC
    import qualified TysWiredIn              as GHC
    import qualified Var                     as GHC
    import qualified SrcLoc                  as GHC
    #endif
    import           GHC.BasicTypes.Extra (isOpaque)

    import           Clash.Annotations.BitRepresentation.Internal (buildCustomReprs)
    import           Clash.Annotations.Primitive (HDL, extractPrim)

    import           Clash.Core.Subst        (extendGblSubstList, mkSubst, substTm)
    import           Clash.Core.Term         (Term (..), mkLams, mkTyLams)
    import           Clash.Core.Type         (Type (..), TypeView (..), mkFunTy, splitFunForallTy, tyView)
    import           Clash.Core.TyCon        (TyConMap, TyConName, isNewTypeTc)
    import           Clash.Core.TysPrim      (tysPrimMap)
    import           Clash.Core.Util         (mkInternalVar, mkSelectorCase)
    import           Clash.Core.Var          (Var (..), Id, IdScope (..), setIdScope)
    import           Clash.Core.VarEnv
      (InScopeSet, VarEnv, emptyInScopeSet, extendInScopeSet, mkInScopeSet
      ,mkVarEnv, unionVarEnv, elemVarSet, mkVarSet)
    import qualified Clash.Data.UniqMap as UniqMap
    import           Clash.Debug             (traceIf)
    import           Clash.Driver            (compilePrimitive)
    import           Clash.Driver.Types      (BindingMap, Binding(..), IsPrim(..), ClashEnv(..), ClashDesign(..), ClashOpts(..))
    import           Clash.GHC.GHC2Core
      (C2C, GHC2CoreState, GHC2CoreEnv (..), tyConMap, coreToId, coreToName, coreToTerm,
       makeAllTyCons, qualifiedNameString, emptyGHC2CoreState, srcSpan)
    import           Clash.GHC.LoadModules   (ghcLibDir, loadModules)
    import           Clash.Netlist.BlackBox.Util (getUsedArguments)
    import           Clash.Netlist.Types     (TopEntityT(..))
    import           Clash.Primitives.Types
      (Primitive (..), CompiledPrimMap)
    import           Clash.Primitives.Util   (generatePrimMap)
    import           Clash.Util              (reportTimeDiff)
    import qualified Clash.Util.Interpolate as I

    -- | Safe indexing, returns a 'Nothing' if the index does not exist
    indexMaybe :: [a] -> Int -> Maybe a
    indexMaybe :: forall a. [a] -> Int -> Maybe a
    indexMaybe [] Int
    _     = Maybe a
    forall a. Maybe a
    Nothing
    indexMaybe (a
    x:[a]
    _)  Int
    0 = a -> Maybe a
    forall a. a -> Maybe a
    Just a
    x
    indexMaybe (a
    _:[a]
    xs) Int
    n = [a] -> Int -> Maybe a
    forall a. [a] -> Int -> Maybe a
    indexMaybe [a]
    xs (Int
    nInt -> Int -> Int
    forall a. Num a => a -> a -> a
    -Int
    1)

    generateBindings
      :: ClashOpts
      -> 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
      -> [FilePath]
      -- ^ primitives (blackbox) directories
      -> [FilePath]
      -- ^ import directories (-i flag)
      -> [FilePath]
      -- ^ Package database
      -> HDL
      -- ^ HDL target
      -> String
      -> Maybe GHC.DynFlags
      -> IO (ClashEnv, ClashDesign)
    generateBindings :: ClashOpts
    -> Ghc ()
    -> [String]
    -> [String]
    -> [String]
    -> HDL
    -> String
    -> Maybe DynFlags
    -> IO (ClashEnv, ClashDesign)
    generateBindings ClashOpts
    opts Ghc ()
    startAction [String]
    primDirs [String]
    importDirs [String]
    dbs HDL
    hdl String
    modName Maybe DynFlags
    dflagsM = do
      (  [CoreBind]
    bindings
       , [(CoreBndr, Int)]
    clsOps
       , [CoreBndr]
    unlocatable
       , FamInstEnvs
    fiEnvs
       , [(CoreBndr, Maybe TopEntity, Bool)]
    topEntities
       , [Either UnresolvedPrimitive String]
    -> ([UnresolvedPrimitive], [String])
    forall a b. [Either a b] -> ([a], [b])
    partitionEithers -> ([UnresolvedPrimitive]
    unresolvedPrims, [String]
    pFP)
       , [DataRepr']
    customBitRepresentations
       , [(Text, PrimitiveGuard ())]
    primGuards
       , HashMap Text VDomainConfiguration
    domainConfs ) <- Ghc ()
    -> OverridingBool
    -> HDL
    -> String
    -> Maybe DynFlags
    -> [String]
    -> IO
         ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
          [(CoreBndr, Maybe TopEntity, Bool)],
          [Either UnresolvedPrimitive String], [DataRepr'],
          [(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
    loadModules Ghc ()
    startAction (ClashOpts -> OverridingBool
    opt_color ClashOpts
    opts) HDL
    hdl String
    modName Maybe DynFlags
    dflagsM [String]
    importDirs
      UTCTime
    startTime <- IO UTCTime
    Clock.getCurrentTime
      ResolvedPrimMap
    primMapR <- HasCallStack =>
    [UnresolvedPrimitive]
    -> [(Text, PrimitiveGuard ())] -> [String] -> IO ResolvedPrimMap
    [UnresolvedPrimitive]
    -> [(Text, PrimitiveGuard ())] -> [String] -> IO ResolvedPrimMap
    generatePrimMap [UnresolvedPrimitive]
    unresolvedPrims [(Text, PrimitiveGuard ())]
    primGuards ([[String]] -> [String]
    forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
    concat [[String]
    pFP, [String]
    primDirs, [String]
    importDirs])
      String
    tdir <- IO String -> (DynFlags -> IO String) -> Maybe DynFlags -> IO String
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe IO String
    ghcLibDir (String -> IO String
    forall a. a -> IO a
    forall (f :: Type -> Type) a. Applicative f => a -> f a
    pure (String -> IO String)
    -> (DynFlags -> String) -> DynFlags -> IO String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . DynFlags -> String
    GHC.topDir) Maybe DynFlags
    dflagsM
      HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMapC <-
        HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
    -> IO (HashMap Text (PrimitiveGuard CompiledPrimitive))
    forall (t :: Type -> Type) (m :: Type -> Type) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: Type -> Type) a.
    Monad m =>
    HashMap Text (m a) -> m (HashMap Text a)
    sequence (HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
     -> IO (HashMap Text (PrimitiveGuard CompiledPrimitive)))
    -> HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
    -> IO (HashMap Text (PrimitiveGuard CompiledPrimitive))
    forall a b. (a -> b) -> a -> b
    $ (PrimitiveGuard ResolvedPrimitive
     -> IO (PrimitiveGuard CompiledPrimitive))
    -> ResolvedPrimMap
    -> HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
    forall v1 v2 k. (v1 -> v2) -> HashMap k v1 -> HashMap k v2
    HashMap.map
                     (PrimitiveGuard (IO CompiledPrimitive)
    -> IO (PrimitiveGuard CompiledPrimitive)
    forall (t :: Type -> Type) (m :: Type -> Type) a.
    (Traversable t, Monad m) =>
    t (m a) -> m (t a)
    forall (m :: Type -> Type) a.
    Monad m =>
    PrimitiveGuard (m a) -> m (PrimitiveGuard a)
    sequence (PrimitiveGuard (IO CompiledPrimitive)
     -> IO (PrimitiveGuard CompiledPrimitive))
    -> (PrimitiveGuard ResolvedPrimitive
        -> PrimitiveGuard (IO CompiledPrimitive))
    -> PrimitiveGuard ResolvedPrimitive
    -> IO (PrimitiveGuard CompiledPrimitive)
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (ResolvedPrimitive -> IO CompiledPrimitive)
    -> PrimitiveGuard ResolvedPrimitive
    -> PrimitiveGuard (IO CompiledPrimitive)
    forall a b. (a -> b) -> PrimitiveGuard a -> PrimitiveGuard b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap ([String]
    -> [String] -> String -> ResolvedPrimitive -> IO CompiledPrimitive
    compilePrimitive [String]
    importDirs [String]
    dbs String
    tdir))
                     ResolvedPrimMap
    primMapR
      let ((BindingMap
    bindingsMap,VarEnv (Id, Int)
    clsVMap),GHC2CoreState
    tcMap,SrcSpanRB
    _) =
            RWS
      GHC2CoreEnv SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
    -> GHC2CoreEnv
    -> GHC2CoreState
    -> ((BindingMap, VarEnv (Id, Int)), GHC2CoreState, SrcSpanRB)
    forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
    RWS.runRWS (HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> [CoreBind]
    -> [(CoreBndr, Int)]
    -> [CoreBndr]
    -> RWS
         GHC2CoreEnv SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
    mkBindings HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMapC [CoreBind]
    bindings [(CoreBndr, Int)]
    clsOps [CoreBndr]
    unlocatable)
                       (SrcSpan -> FamInstEnvs -> GHC2CoreEnv
    GHC2CoreEnv SrcSpan
    GHC.noSrcSpan FamInstEnvs
    fiEnvs)
                       GHC2CoreState
    emptyGHC2CoreState
          (GHC2CoreState
    tcMap',IntMap TyConName
    tupTcCache)           = GHC2CoreState -> (GHC2CoreState, IntMap TyConName)
    mkTupTyCons GHC2CoreState
    tcMap
          tcCache :: UniqMap TyCon
    tcCache                       = GHC2CoreState -> FamInstEnvs -> UniqMap TyCon
    makeAllTyCons GHC2CoreState
    tcMap' FamInstEnvs
    fiEnvs
          allTcCache :: UniqMap TyCon
    allTcCache                    = UniqMap TyCon
    tysPrimMap UniqMap TyCon -> UniqMap TyCon -> UniqMap TyCon
    forall a. Semigroup a => a -> a -> a
    <> UniqMap TyCon
    tcCache
          inScope0 :: InScopeSet
    inScope0 = UniqMap (Var Any) -> InScopeSet
    mkInScopeSet (
                          ((Binding Term -> Var Any) -> BindingMap -> UniqMap (Var Any)
    forall a b. (a -> b) -> UniqMap a -> UniqMap b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Id -> Var Any
    forall a b. Coercible a b => a -> b
    coerce (Id -> Var Any) -> (Binding Term -> Id) -> Binding Term -> Var Any
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Binding Term -> Id
    forall a. Binding a -> Id
    bindingId) BindingMap
    bindingsMap) UniqMap (Var Any) -> UniqMap (Var Any) -> UniqMap (Var Any)
    forall a. Semigroup a => a -> a -> a
    <>
                          ((Binding Term -> Var Any) -> BindingMap -> UniqMap (Var Any)
    forall a b. (a -> b) -> UniqMap a -> UniqMap b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (Id -> Var Any
    forall a b. Coercible a b => a -> b
    coerce (Id -> Var Any) -> (Binding Term -> Id) -> Binding Term -> Var Any
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Binding Term -> Id
    forall a. Binding a -> Id
    bindingId) BindingMap
    clsMap))
                                        -- Recursion info is always False for class
                                        -- selectors, no need to check free vars.
          clsMap :: BindingMap
    clsMap =
            ((Id, Int) -> Binding Term) -> VarEnv (Id, Int) -> BindingMap
    forall a b. (a -> b) -> UniqMap a -> UniqMap b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap (\(Id
    v,Int
    i) ->
    #if MIN_VERSION_ghc(9,4,0)
                   (Id
    -> SrcSpan -> InlineSpec -> IsPrim -> Term -> Bool -> Binding Term
    forall a.
    Id -> SrcSpan -> InlineSpec -> IsPrim -> a -> Bool -> Binding a
    Binding Id
    v SrcSpan
    GHC.noSrcSpan (SourceText -> InlineSpec
    GHC.Inline SourceText
    GHC.NoSourceText) IsPrim
    IsFun
    #else
                   (Binding v GHC.noSrcSpan GHC.Inline IsFun
    #endif
                      (InScopeSet -> UniqMap TyCon -> Type -> Int -> Term
    mkClassSelector InScopeSet
    inScope0 UniqMap TyCon
    allTcCache (Id -> Type
    forall a. Var a -> Type
    varType Id
    v) Int
    i) Bool
    False))
                 VarEnv (Id, Int)
    clsVMap
          allBindings :: BindingMap
    allBindings                   = BindingMap
    bindingsMap BindingMap -> BindingMap -> BindingMap
    forall a. VarEnv a -> VarEnv a -> VarEnv a
    `unionVarEnv` BindingMap
    clsMap
          topEntities' :: [(Name a, Maybe TopEntity, Bool)]
    topEntities'                  =
            (\RWS
      GHC2CoreEnv
      SrcSpanRB
      GHC2CoreState
      [(Name a, Maybe TopEntity, Bool)]
    m -> ([(Name a, Maybe TopEntity, Bool)], SrcSpanRB)
    -> [(Name a, Maybe TopEntity, Bool)]
    forall a b. (a, b) -> a
    fst (RWS
      GHC2CoreEnv
      SrcSpanRB
      GHC2CoreState
      [(Name a, Maybe TopEntity, Bool)]
    -> GHC2CoreEnv
    -> GHC2CoreState
    -> ([(Name a, Maybe TopEntity, Bool)], SrcSpanRB)
    forall r w s a. RWS r w s a -> r -> s -> (a, w)
    RWS.evalRWS RWS
      GHC2CoreEnv
      SrcSpanRB
      GHC2CoreState
      [(Name a, Maybe TopEntity, Bool)]
    m (SrcSpan -> FamInstEnvs -> GHC2CoreEnv
    GHC2CoreEnv SrcSpan
    GHC.noSrcSpan FamInstEnvs
    fiEnvs) GHC2CoreState
    tcMap')) (RWS
       GHC2CoreEnv
       SrcSpanRB
       GHC2CoreState
       [(Name a, Maybe TopEntity, Bool)]
     -> [(Name a, Maybe TopEntity, Bool)])
    -> RWS
         GHC2CoreEnv
         SrcSpanRB
         GHC2CoreState
         [(Name a, Maybe TopEntity, Bool)]
    -> [(Name a, Maybe TopEntity, Bool)]
    forall a b. (a -> b) -> a -> b
    $
              ((CoreBndr, Maybe TopEntity, Bool)
     -> RWST
          GHC2CoreEnv
          SrcSpanRB
          GHC2CoreState
          Identity
          (Name a, Maybe TopEntity, Bool))
    -> [(CoreBndr, Maybe TopEntity, Bool)]
    -> RWS
         GHC2CoreEnv
         SrcSpanRB
         GHC2CoreState
         [(Name a, Maybe TopEntity, Bool)]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM (\(CoreBndr
    topEnt,Maybe TopEntity
    annM,Bool
    isTb) -> do
                Name a
    topEnt' <- (CoreBndr -> Name)
    -> (CoreBndr -> Unique)
    -> (Name -> C2C Text)
    -> CoreBndr
    -> C2C (Name a)
    forall b a.
    (b -> Name)
    -> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
    coreToName CoreBndr -> Name
    GHC.varName CoreBndr -> Unique
    GHC.varUnique Name -> C2C Text
    qualifiedNameString CoreBndr
    topEnt
                (Name a, Maybe TopEntity, Bool)
    -> RWST
         GHC2CoreEnv
         SrcSpanRB
         GHC2CoreState
         Identity
         (Name a, Maybe TopEntity, Bool)
    forall a. a -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Name a
    topEnt', Maybe TopEntity
    annM, Bool
    isTb)) [(CoreBndr, Maybe TopEntity, Bool)]
    topEntities
          topEntities'' :: [TopEntityT]
    topEntities'' =
            ((Name Any, Maybe TopEntity, Bool) -> TopEntityT)
    -> [(Name Any, Maybe TopEntity, Bool)] -> [TopEntityT]
    forall a b. (a -> b) -> [a] -> [b]
    map (\(Name Any
    topEnt, Maybe TopEntity
    annM, Bool
    isTb) ->
                    case Name Any -> BindingMap -> Maybe (Binding Term)
    forall a b. Uniquable a => a -> UniqMap b -> Maybe b
    UniqMap.lookup Name Any
    topEnt BindingMap
    allBindings of
                      Just Binding Term
    b -> Id -> Maybe TopEntity -> Bool -> TopEntityT
    TopEntityT (Binding Term -> Id
    forall a. Binding a -> Id
    bindingId Binding Term
    b) Maybe TopEntity
    annM Bool
    isTb
                      Maybe (Binding Term)
    Nothing -> String -> TopEntityT
    forall a. String -> a
    GHC.pgmError [I.i|
                        No top entity called '#{topEnt}' found. Make sure you are
                        compiling with the '-fexpose-all-unfoldings' flag.
                      |]
                ) [(Name Any, Maybe TopEntity, Bool)]
    forall {a}. [(Name a, Maybe TopEntity, Bool)]
    topEntities'
      -- Parsing / compiling primitives:
      UTCTime
    prepTime  <- UTCTime
    startTime UTCTime -> IO UTCTime -> IO UTCTime
    forall a b. NFData a => a -> b -> b
    `deepseq` HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMapC HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> IO UTCTime -> IO UTCTime
    forall a b. a -> b -> b
    `seq` IO UTCTime
    Clock.getCurrentTime
      let prepStartDiff :: String
    prepStartDiff = UTCTime -> UTCTime -> String
    reportTimeDiff UTCTime
    prepTime UTCTime
    startTime
      String -> IO ()
    putStrLn (String -> IO ()) -> String -> IO ()
    forall a b. (a -> b) -> a -> b
    $ String
    "Clash: Parsing and compiling primitives took " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    prepStartDiff

      let allBindings' :: BindingMap
    allBindings' = BindingMap -> [TopEntityT] -> BindingMap
    setNoInlineTopEntities BindingMap
    allBindings [TopEntityT]
    topEntities''

      (ClashEnv, ClashDesign) -> IO (ClashEnv, ClashDesign)
    forall a. a -> IO a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return
        ( ClashEnv
            { envOpts :: ClashOpts
    envOpts = ClashOpts
    opts
            , envTyConMap :: UniqMap TyCon
    envTyConMap = UniqMap TyCon
    allTcCache
            , envTupleTyCons :: IntMap TyConName
    envTupleTyCons = IntMap TyConName
    tupTcCache
            , envPrimitives :: HashMap Text (PrimitiveGuard CompiledPrimitive)
    envPrimitives = HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMapC
            , envCustomReprs :: CustomReprs
    envCustomReprs = [DataRepr'] -> CustomReprs
    buildCustomReprs [DataRepr']
    customBitRepresentations
            , envDomains :: HashMap Text VDomainConfiguration
    envDomains = HashMap Text VDomainConfiguration
    domainConfs
            }
        , ClashDesign
            { designEntities :: [TopEntityT]
    designEntities = [TopEntityT]
    topEntities''
            , designBindings :: BindingMap
    designBindings = BindingMap
    allBindings'
            }
        )

    setNoInlineTopEntities
      :: BindingMap
      -> [TopEntityT]
      -> BindingMap
    setNoInlineTopEntities :: BindingMap -> [TopEntityT] -> BindingMap
    setNoInlineTopEntities BindingMap
    bm [TopEntityT]
    tes =
      (Binding Term -> Binding Term) -> BindingMap -> BindingMap
    forall a b. (a -> b) -> UniqMap a -> UniqMap b
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap Binding Term -> Binding Term
    forall {a}. Binding a -> Binding a
    go BindingMap
    bm
     where
      ids :: UniqMap (Var Any)
    ids = [Id] -> UniqMap (Var Any)
    forall a. [Var a] -> UniqMap (Var Any)
    mkVarSet ((TopEntityT -> Id) -> [TopEntityT] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    fmap TopEntityT -> Id
    topId [TopEntityT]
    tes)

      go :: Binding a -> Binding a
    go b :: Binding a
    b@Binding{Id
    bindingId :: forall a. Binding a -> Id
    bindingId :: Id
    bindingId}
        | Id
    bindingId Id -> UniqMap (Var Any) -> Bool
    forall a. Var a -> UniqMap (Var Any) -> Bool
    `elemVarSet` UniqMap (Var Any)
    ids
    #if MIN_VERSION_ghc(9,4,0)
        = Binding a
    b { bindingSpec :: InlineSpec
    bindingSpec = SourceText -> InlineSpec
    GHC.Opaque SourceText
    GHC.NoSourceText }
    #else
        = b { bindingSpec = GHC.NoInline }
    #endif
        | Bool
    otherwise = Binding a
    b

    -- TODO This function should be changed to provide the information that
    -- Clash.Core.Termination.mkRecInfo provides. To achieve this, it should also
    -- be changed to no longer flatten recursive groups (see the documentation for
    -- mkRecInfo for an explanation of these).
    --
    mkBindings
      :: CompiledPrimMap
      -> [GHC.CoreBind]
      -- Binders
      -> [(GHC.CoreBndr,Int)]
      -- Class operations
      -> [GHC.CoreBndr]
      -- Unlocatable Expressions
      -> C2C ( BindingMap
             , VarEnv (Id,Int)
             )
    mkBindings :: HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> [CoreBind]
    -> [(CoreBndr, Int)]
    -> [CoreBndr]
    -> RWS
         GHC2CoreEnv SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
    mkBindings HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap [CoreBind]
    bindings [(CoreBndr, Int)]
    clsOps [CoreBndr]
    unlocatable = do
      [[(Id, Binding Term)]]
    bindingsList <- (CoreBind
     -> RWST
          GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, Binding Term)])
    -> [CoreBind]
    -> RWST
         GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [[(Id, Binding Term)]]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM (\case
        GHC.NonRec CoreBndr
    v Expr CoreBndr
    e -> do
          let sp :: SrcSpan
    sp = CoreBndr -> SrcSpan
    forall a. NamedThing a => a -> SrcSpan
    GHC.getSrcSpan CoreBndr
    v
              inl :: InlineSpec
    inl = InlinePragma -> InlineSpec
    GHC.inlinePragmaSpec (InlinePragma -> InlineSpec)
    -> (IdInfo -> InlinePragma) -> IdInfo -> InlineSpec
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IdInfo -> InlinePragma
    GHC.inlinePragInfo (IdInfo -> InlineSpec) -> IdInfo -> InlineSpec
    forall a b. (a -> b) -> a -> b
    $ (() :: Constraint) => CoreBndr -> IdInfo
    CoreBndr -> IdInfo
    GHC.idInfo CoreBndr
    v
          Term
    tm <- (GHC2CoreEnv -> GHC2CoreEnv)
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
    forall a.
    (GHC2CoreEnv -> GHC2CoreEnv)
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall r (m :: Type -> Type) a.
    MonadReader r m =>
    (r -> r) -> m a -> m a
    RWS.local ((SrcSpan -> Identity SrcSpan)
    -> GHC2CoreEnv -> Identity GHC2CoreEnv
    Lens' GHC2CoreEnv SrcSpan
    srcSpan ((SrcSpan -> Identity SrcSpan)
     -> GHC2CoreEnv -> Identity GHC2CoreEnv)
    -> SrcSpan -> GHC2CoreEnv -> GHC2CoreEnv
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ SrcSpan
    sp) (HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> [CoreBndr]
    -> Expr CoreBndr
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
    coreToTerm HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap [CoreBndr]
    unlocatable Expr CoreBndr
    e)
          Id
    v' <- CoreBndr -> C2C Id
    coreToId CoreBndr
    v
          Text
    nm <- Name -> C2C Text
    qualifiedNameString (CoreBndr -> Name
    GHC.varName CoreBndr
    v)
          let pr :: IsPrim
    pr = if Text -> HashMap Text (PrimitiveGuard CompiledPrimitive) -> Bool
    forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
    HashMap.member Text
    nm HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap then IsPrim
    IsPrim else IsPrim
    IsFun
          HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> CoreBndr -> C2C ()
    checkPrimitive HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap CoreBndr
    v
          [(Id, Binding Term)]
    -> RWST
         GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, Binding Term)]
    forall a. a -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return [(Id
    v', (Id
    -> SrcSpan -> InlineSpec -> IsPrim -> Term -> Bool -> Binding Term
    forall a.
    Id -> SrcSpan -> InlineSpec -> IsPrim -> a -> Bool -> Binding a
    Binding Id
    v' SrcSpan
    sp InlineSpec
    inl IsPrim
    pr Term
    tm Bool
    False))]
        GHC.Rec [(CoreBndr, Expr CoreBndr)]
    bs -> do
          [Binding Term]
    tms <- ((CoreBndr, Expr CoreBndr)
     -> RWST
          GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Binding Term))
    -> [(CoreBndr, Expr CoreBndr)]
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [Binding Term]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM (\(CoreBndr
    v,Expr CoreBndr
    e) -> do
                        let sp :: SrcSpan
    sp  = CoreBndr -> SrcSpan
    forall a. NamedThing a => a -> SrcSpan
    GHC.getSrcSpan CoreBndr
    v
                            inl :: InlineSpec
    inl = InlinePragma -> InlineSpec
    GHC.inlinePragmaSpec (InlinePragma -> InlineSpec)
    -> (IdInfo -> InlinePragma) -> IdInfo -> InlineSpec
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . IdInfo -> InlinePragma
    GHC.inlinePragInfo (IdInfo -> InlineSpec) -> IdInfo -> InlineSpec
    forall a b. (a -> b) -> a -> b
    $ (() :: Constraint) => CoreBndr -> IdInfo
    CoreBndr -> IdInfo
    GHC.idInfo CoreBndr
    v
                        Term
    tm <- (GHC2CoreEnv -> GHC2CoreEnv)
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
    forall a.
    (GHC2CoreEnv -> GHC2CoreEnv)
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall r (m :: Type -> Type) a.
    MonadReader r m =>
    (r -> r) -> m a -> m a
    RWS.local ((SrcSpan -> Identity SrcSpan)
    -> GHC2CoreEnv -> Identity GHC2CoreEnv
    Lens' GHC2CoreEnv SrcSpan
    srcSpan ((SrcSpan -> Identity SrcSpan)
     -> GHC2CoreEnv -> Identity GHC2CoreEnv)
    -> SrcSpan -> GHC2CoreEnv -> GHC2CoreEnv
    forall s t a b. ASetter s t a b -> b -> s -> t
    .~ SrcSpan
    sp) (HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> [CoreBndr]
    -> Expr CoreBndr
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
    coreToTerm HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap [CoreBndr]
    unlocatable Expr CoreBndr
    e)
                        Id
    v' <- CoreBndr -> C2C Id
    coreToId CoreBndr
    v
                        Text
    nm <- Name -> C2C Text
    qualifiedNameString (CoreBndr -> Name
    GHC.varName CoreBndr
    v)
                        let pr :: IsPrim
    pr = if Text -> HashMap Text (PrimitiveGuard CompiledPrimitive) -> Bool
    forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
    HashMap.member Text
    nm HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap then IsPrim
    IsPrim else IsPrim
    IsFun
                        HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> CoreBndr -> C2C ()
    checkPrimitive HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap CoreBndr
    v
                        Binding Term
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Binding Term)
    forall a. a -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Id
    -> SrcSpan -> InlineSpec -> IsPrim -> Term -> Bool -> Binding Term
    forall a.
    Id -> SrcSpan -> InlineSpec -> IsPrim -> a -> Bool -> Binding a
    Binding Id
    v' SrcSpan
    sp InlineSpec
    inl IsPrim
    pr Term
    tm Bool
    True)
                      ) [(CoreBndr, Expr CoreBndr)]
    bs
          case [Binding Term]
    tms of
            [Binding Id
    v SrcSpan
    sp InlineSpec
    inl IsPrim
    pr Term
    tm Bool
    r] -> [(Id, Binding Term)]
    -> RWST
         GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, Binding Term)]
    forall a. a -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return [(Id
    v, Id
    -> SrcSpan -> InlineSpec -> IsPrim -> Term -> Bool -> Binding Term
    forall a.
    Id -> SrcSpan -> InlineSpec -> IsPrim -> a -> Bool -> Binding a
    Binding Id
    v SrcSpan
    sp InlineSpec
    inl IsPrim
    pr Term
    tm Bool
    r)]

            -- Rewrite the bindings to avoid triggering the recursion check.
            -- See NOTE [bindings in recursive groups]
            [Binding Term]
    _ -> let vsL :: [Id]
    vsL   = (Binding Term -> Id) -> [Binding Term] -> [Id]
    forall a b. (a -> b) -> [a] -> [b]
    map (IdScope -> Id -> Id
    forall a. IdScope -> Var a -> Var a
    setIdScope IdScope
    LocalId (Id -> Id) -> (Binding Term -> Id) -> Binding Term -> Id
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . Binding Term -> Id
    forall a. Binding a -> Id
    bindingId) [Binding Term]
    tms
                     vsV :: [Term]
    vsV   = (Id -> Term) -> [Id] -> [Term]
    forall a b. (a -> b) -> [a] -> [b]
    map Id -> Term
    Var [Id]
    vsL
                     subst :: Subst
    subst = Subst -> [(Id, Term)] -> Subst
    extendGblSubstList (InScopeSet -> Subst
    mkSubst InScopeSet
    emptyInScopeSet) ([Id] -> [Term] -> [(Id, Term)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Id]
    vsL [Term]
    vsV)
                     lbs :: [(Id, Term)]
    lbs   = (Binding Term -> Id -> (Id, Term))
    -> [Binding Term] -> [Id] -> [(Id, Term)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Binding Term
    b Id
    vL -> (Id
    vL,HasCallStack => Doc () -> Subst -> Term -> Term
    Doc () -> Subst -> Term -> Term
    substTm Doc ()
    "mkBindings" Subst
    subst (Binding Term -> Term
    forall a. Binding a -> a
    bindingTerm Binding Term
    b))) [Binding Term]
    tms [Id]
    vsL
                     tms1 :: [(Id, Binding Term)]
    tms1  = (Binding Term -> (Id, Term) -> (Id, Binding Term))
    -> [Binding Term] -> [(Id, Term)] -> [(Id, Binding Term)]
    forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
    zipWith (\Binding Term
    b (Id
    i, Term
    _) -> (Binding Term -> Id
    forall a. Binding a -> Id
    bindingId Binding Term
    b, Binding Term
    b { bindingTerm :: Term
    bindingTerm = [(Id, Term)] -> Term -> Term
    Letrec [(Id, Term)]
    lbs (Id -> Term
    Var Id
    i), bindingRecursive :: Bool
    bindingRecursive = Bool
    False })) [Binding Term]
    tms [(Id, Term)]
    lbs
                 in  [(Id, Binding Term)]
    -> RWST
         GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, Binding Term)]
    forall a. a -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return [(Id, Binding Term)]
    tms1
        ) [CoreBind]
    bindings
      [(Id, (Id, Int))]
    clsOpList    <- ((CoreBndr, Int)
     -> RWST
          GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Id, (Id, Int)))
    -> [(CoreBndr, Int)]
    -> RWST
         GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, (Id, Int))]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM (\(CoreBndr
    v,Int
    i) -> do
                              Id
    v' <- CoreBndr -> C2C Id
    coreToId CoreBndr
    v
                              (Id, (Id, Int))
    -> RWST
         GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Id, (Id, Int))
    forall a. a -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Id
    v', (Id
    v',Int
    i))
                           ) [(CoreBndr, Int)]
    clsOps

      (BindingMap, VarEnv (Id, Int))
    -> RWS
         GHC2CoreEnv SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
    forall a. a -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ([(Id, Binding Term)] -> BindingMap
    forall a b. [(Var a, b)] -> VarEnv b
    mkVarEnv ([[(Id, Binding Term)]] -> [(Id, Binding Term)]
    forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
    concat [[(Id, Binding Term)]]
    bindingsList), [(Id, (Id, Int))] -> VarEnv (Id, Int)
    forall a b. [(Var a, b)] -> VarEnv b
    mkVarEnv [(Id, (Id, Int))]
    clsOpList)

    {-
    NOTE [bindings in recursive groups]
    ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
    After normalization, Clash currently checks that all normalized entities are
    not recursive and errors if any are. However, this check only applies to
    recursion on global identifiers. Since GHC may present recursive groups of
    global binders, these are rewritten to only be locally recursive, i.e.

      f[GlobalId] = g[GlobalId] ...
      g[GlobalId] = f[GlobalId] ...

    will be rewritten (and inserted into the map of global bindings) as

      f[GlobalId] = let f[LocalId] = g[LocalId] ...
                        g[LocalId] = f[LocalId] ...
                     in f[LocalId]

      g[GlobalId] = let f[LocalId] = g[LocalId] ...
                        g[LocalId] = f[LocalId] ...
                     in g[LocalId]

    Recursive groups with only a single binding (i.e. global self-recursive
    definitions do not need this rewriting. This is because normalization can
    trivially spot these self-recursive bindings and where necessary lift them to
    global bindings when they appear in a term.
    -}

    -- | If this CoreBndr is a primitive, check it's Haskell definition
    --   for potential problems.
    --
    -- Warns when a primitive:
    --   * isn't marked NOINLINE
    --   * produces an error when evaluating its result to WHNF
    --   * isn't using all its arguments
    checkPrimitive :: CompiledPrimMap -> GHC.CoreBndr -> C2C ()
    checkPrimitive :: HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> CoreBndr -> C2C ()
    checkPrimitive HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap CoreBndr
    v = do
      Text
    nm <- Name -> C2C Text
    qualifiedNameString (CoreBndr -> Name
    GHC.varName CoreBndr
    v)
      case Text
    -> HashMap Text (PrimitiveGuard CompiledPrimitive)
    -> Maybe (PrimitiveGuard CompiledPrimitive)
    forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
    HashMap.lookup Text
    nm HashMap Text (PrimitiveGuard CompiledPrimitive)
    primMap Maybe (PrimitiveGuard CompiledPrimitive)
    -> (PrimitiveGuard CompiledPrimitive -> Maybe CompiledPrimitive)
    -> Maybe CompiledPrimitive
    forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
    forall (m :: Type -> Type) a b. Monad m => m a -> (a -> m b) -> m b
    >>= PrimitiveGuard CompiledPrimitive -> Maybe CompiledPrimitive
    forall a. PrimitiveGuard a -> Maybe a
    extractPrim of
        Just (BlackBox{[BlackBox]
    resultNames :: [BlackBox]
    resultNames :: forall a b c d. Primitive a b c d -> [b]
    resultNames, [BlackBox]
    resultInits :: [BlackBox]
    resultInits :: forall a b c d. Primitive a b c d -> [b]
    resultInits, BlackBox
    template :: BlackBox
    template :: forall a b c d. Primitive a b c d -> b
    template, [((Text, Text), BlackBox)]
    includes :: [((Text, Text), BlackBox)]
    includes :: forall a b c d. Primitive a b c d -> [((Text, Text), b)]
    includes}) -> do
          let
            info :: IdInfo
    info = (() :: Constraint) => CoreBndr -> IdInfo
    CoreBndr -> IdInfo
    GHC.idInfo CoreBndr
    v
            inline :: InlineSpec
    inline = InlinePragma -> InlineSpec
    GHC.inlinePragmaSpec (InlinePragma -> InlineSpec) -> InlinePragma -> InlineSpec
    forall a b. (a -> b) -> a -> b
    $ IdInfo -> InlinePragma
    GHC.inlinePragInfo IdInfo
    info
    #if MIN_VERSION_ghc(9,4,0)
            strictness :: DmdSig
    strictness = IdInfo -> DmdSig
    GHC.dmdSigInfo IdInfo
    info
    #else
            strictness = GHC.strictnessInfo info
    #endif
            ty :: Kind
    ty = CoreBndr -> Kind
    GHC.varType CoreBndr
    v
    #if MIN_VERSION_ghc(9,2,0)
            ([Scaled Kind]
    argTys,Kind
    _resTy) = Kind -> ([Scaled Kind], Kind)
    GHC.splitFunTys (([CoreBndr], Kind) -> Kind
    forall a b. (a, b) -> b
    snd (Kind -> ([CoreBndr], Kind)
    GHC.splitForAllTyCoVars Kind
    ty))
    #else
            (argTys,_resTy) = GHC.splitFunTys . snd . GHC.splitForAllTys $ ty
    #endif
    #if MIN_VERSION_ghc(9,4,0)
            ([Demand]
    dmdArgs,Divergence
    _dmdRes) = DmdSig -> ([Demand], Divergence)
    GHC.splitDmdSig DmdSig
    strictness
    #else
            (dmdArgs,_dmdRes) = GHC.splitStrictSig strictness
    #endif
            nrOfArgs :: Int
    nrOfArgs = [Scaled Kind] -> Int
    forall a. [a] -> Int
    forall (t :: Type -> Type) a. Foldable t => t a -> Int
    length [Scaled Kind]
    argTys
            loc :: String
    loc = case CoreBndr -> SrcLoc
    forall a. NamedThing a => a -> SrcLoc
    GHC.getSrcLoc CoreBndr
    v of
                    GHC.UnhelpfulLoc FastString
    _ -> String
    ""
    #if MIN_VERSION_ghc(9,0,0)
                    GHC.RealSrcLoc RealSrcLoc
    l Maybe BufPos
    _ -> RealSrcLoc -> String
    forall a. Outputable a => a -> String
    showPpr RealSrcLoc
    l String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ": "
    #else
                    GHC.RealSrcLoc l   -> showPpr l ++ ": "
    #endif
            warnIf :: Bool -> String -> m ()
    warnIf Bool
    cond String
    msg = Bool -> String -> (() -> m ()) -> () -> m ()
    forall a. Bool -> String -> a -> a
    traceIf Bool
    cond (String
    "\n"String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    locString -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    "Warning: "String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++String
    msg) () -> m ()
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()
          String
    qName <- Text -> String
    Text.unpack (Text -> String)
    -> C2C Text
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity String
    forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
    <$> Name -> C2C Text
    qualifiedNameString (CoreBndr -> Name
    GHC.varName CoreBndr
    v)
          let primStr :: String
    primStr = String
    "primitive " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    qName String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    " "
          let usedArgs :: [Int]
    usedArgs = [[Int]] -> [Int]
    forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
    concat [ (BlackBox -> [Int]) -> [BlackBox] -> [Int]
    forall (t :: Type -> Type) a b.
    Foldable t =>
    (a -> [b]) -> t a -> [b]
    concatMap BlackBox -> [Int]
    getUsedArguments [BlackBox]
    resultNames
                                , (BlackBox -> [Int]) -> [BlackBox] -> [Int]
    forall (t :: Type -> Type) a b.
    Foldable t =>
    (a -> [b]) -> t a -> [b]
    concatMap BlackBox -> [Int]
    getUsedArguments [BlackBox]
    resultInits
                                , BlackBox -> [Int]
    getUsedArguments BlackBox
    template
                                , (((Text, Text), BlackBox) -> [Int])
    -> [((Text, Text), BlackBox)] -> [Int]
    forall (t :: Type -> Type) a b.
    Foldable t =>
    (a -> [b]) -> t a -> [b]
    concatMap (BlackBox -> [Int]
    getUsedArguments (BlackBox -> [Int])
    -> (((Text, Text), BlackBox) -> BlackBox)
    -> ((Text, Text), BlackBox)
    -> [Int]
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . ((Text, Text), BlackBox) -> BlackBox
    forall a b. (a, b) -> b
    snd) [((Text, Text), BlackBox)]
    includes
                                ]

          let warnArgs :: [Int] -> m ()
    warnArgs [] = () -> m ()
    forall a. a -> m a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()
              warnArgs (Int
    x:[Int]
    xs) = do
                Bool -> String -> m ()
    forall {m :: Type -> Type}. Monad m => Bool -> String -> m ()
    warnIf (Bool -> (Demand -> Bool) -> Maybe Demand -> Bool
    forall b a. b -> (a -> b) -> Maybe a -> b
    maybe Bool
    False Demand -> Bool
    GHC.isAbsDmd ([Demand] -> Int -> Maybe Demand
    forall a. [a] -> Int -> Maybe a
    indexMaybe [Demand]
    dmdArgs Int
    x))
                  (String
    "The Haskell implementation of " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    primStr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "isn't using argument #" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                   Int -> String
    forall a. Show a => a -> String
    show Int
    x String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    ", but the corresponding primitive blackbox does.\n" String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                   String
    "This can lead to incorrect HDL output because GHC can replace these " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++
                   String
    "arguments by an undefined value.")
                [Int] -> m ()
    warnArgs [Int]
    xs

          Bool -> C2C () -> C2C ()
    forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
    unless (String
    qName String -> String -> Bool
    forall a. Eq a => a -> a -> Bool
    == String
    "Clash.XException.errorX" Bool -> Bool -> Bool
    || String
    "GHC." String -> String -> Bool
    forall a. Eq a => [a] -> [a] -> Bool
    `isPrefixOf` String
    qName) (C2C () -> C2C ()) -> C2C () -> C2C ()
    forall a b. (a -> b) -> a -> b
    $ do
            Bool -> String -> C2C ()
    forall {m :: Type -> Type}. Monad m => Bool -> String -> m ()
    warnIf (Bool -> Bool
    not (InlineSpec -> Bool
    isOpaque InlineSpec
    inline))
    #if MIN_VERSION_ghc(9,4,0)
              (String
    primStr String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "isn't marked OPAQUE."
    #else
              (primStr ++ "isn't marked NOINLINE."
    #endif
              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "\nThis might make Clash ignore this primitive.")
    #if MIN_VERSION_ghc(9,2,0)
            Bool -> String -> C2C ()
    forall {m :: Type -> Type}. Monad m => Bool -> String -> m ()
    warnIf (DmdSig -> Int -> Bool
    GHC.isDeadEndAppSig DmdSig
    strictness Int
    nrOfArgs)
    #elif MIN_VERSION_ghc(9,0,0)
            warnIf (GHC.appIsDeadEnd strictness nrOfArgs)
    #else
            warnIf (GHC.appIsBottom strictness nrOfArgs)
    #endif
              (String
    "The Haskell implementation of " String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    primStr
              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "produces a result that always results in an error.\n"
              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "This can lead to compile failures because GHC can replace entire "
              String -> String -> String
    forall a. [a] -> [a] -> [a]
    ++ String
    "calls to this primitive by an undefined value.")
            [Int] -> C2C ()
    forall {m :: Type -> Type}. Monad m => [Int] -> m ()
    warnArgs [Int]
    usedArgs
        Maybe CompiledPrimitive
    _ -> () -> C2C ()
    forall a. a -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return ()
      where
        showPpr :: GHC.Outputable a => a -> String
        showPpr :: forall a. Outputable a => a -> String
    showPpr = SDoc -> String
    GHC.showSDocUnsafe (SDoc -> String) -> (a -> SDoc) -> a -> String
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . a -> SDoc
    forall a. Outputable a => a -> SDoc
    GHC.ppr

    mkClassSelector
      :: InScopeSet
      -> TyConMap
      -> Type
      -> Int
      -> Term
    mkClassSelector :: InScopeSet -> UniqMap TyCon -> Type -> Int -> Term
    mkClassSelector InScopeSet
    inScope0 UniqMap TyCon
    tcm Type
    ty Int
    sel = Term
    newExpr
      where
        -- TODO: why can't we just use partitionEithers here?
        ([TyVar]
    tvs,[Type]
    dicts) = ([Either TyVar Type] -> [TyVar]
    forall a b. [Either a b] -> [a]
    lefts ([Either TyVar Type] -> [TyVar])
    -> ([Either TyVar Type] -> [Type])
    -> ([Either TyVar Type], [Either TyVar Type])
    -> ([TyVar], [Type])
    forall b c b' c'. (b -> c) -> (b' -> c') -> (b, b') -> (c, c')
    forall (a :: Type -> Type -> Type) b c b' c'.
    Arrow a =>
    a b c -> a b' c' -> a (b, b') (c, c')
    *** [Either TyVar Type] -> [Type]
    forall a b. [Either a b] -> [b]
    rights)
                    (([Either TyVar Type], [Either TyVar Type]) -> ([TyVar], [Type]))
    -> ([Either TyVar Type]
        -> ([Either TyVar Type], [Either TyVar Type]))
    -> [Either TyVar Type]
    -> ([TyVar], [Type])
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . (Either TyVar Type -> Bool)
    -> [Either TyVar Type]
    -> ([Either TyVar Type], [Either TyVar Type])
    forall a. (a -> Bool) -> [a] -> ([a], [a])
    span (\Either TyVar Type
    l -> case Either TyVar Type
    l of {Left TyVar
    _ -> Bool
    True; Either TyVar Type
    _ -> Bool
    False})
                    ([Either TyVar Type] -> ([TyVar], [Type]))
    -> [Either TyVar Type] -> ([TyVar], [Type])
    forall a b. (a -> b) -> a -> b
    $ ([Either TyVar Type], Type) -> [Either TyVar Type]
    forall a b. (a, b) -> a
    fst (Type -> ([Either TyVar Type], Type)
    splitFunForallTy Type
    ty)
        newExpr :: Term
    newExpr = case [Type] -> Maybe Type
    forall a. [a] -> Maybe a
    listToMaybe [Type]
    dicts of
          Just dictTy :: Type
    dictTy@(Type -> TypeView
    tyView -> TyConApp TyConName
    tcNm [Type]
    _)
            | Just TyCon
    tc <- TyConName -> UniqMap TyCon -> Maybe TyCon
    forall a b. Uniquable a => a -> UniqMap b -> Maybe b
    UniqMap.lookup TyConName
    tcNm UniqMap TyCon
    tcm
            , Bool -> Bool
    not (TyCon -> Bool
    isNewTypeTc TyCon
    tc)
            -> (State Int Term -> Int -> Term) -> Int -> State Int Term -> Term
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip State Int Term -> Int -> Term
    forall s a. State s a -> s -> a
    State.evalState (Int
    0 :: Int) (State Int Term -> Term) -> State Int Term -> Term
    forall a b. (a -> b) -> a -> b
    $ do
                  Id
    dcId <- InScopeSet -> Text -> Type -> StateT Int Identity Id
    forall (m :: Type -> Type).
    MonadUnique m =>
    InScopeSet -> Text -> Type -> m Id
    mkInternalVar InScopeSet
    inScope0 Text
    "dict" Type
    dictTy
                  let inScope1 :: InScopeSet
    inScope1 = InScopeSet -> Id -> InScopeSet
    forall a. InScopeSet -> Var a -> InScopeSet
    extendInScopeSet InScopeSet
    inScope0 Id
    dcId
                  Term
    selE <- String
    -> InScopeSet
    -> UniqMap TyCon
    -> Term
    -> Int
    -> Int
    -> State Int Term
    forall (m :: Type -> Type).
    (HasCallStack, MonadUnique m) =>
    String
    -> InScopeSet -> UniqMap TyCon -> Term -> Int -> Int -> m Term
    mkSelectorCase String
    "mkClassSelector" InScopeSet
    inScope1 UniqMap TyCon
    tcm (Id -> Term
    Var Id
    dcId) Int
    1 Int
    sel
                  Term -> State Int Term
    forall a. a -> StateT Int Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Term -> [TyVar] -> Term
    mkTyLams (Term -> [Id] -> Term
    mkLams Term
    selE [Id
    dcId]) [TyVar]
    tvs)
          Just (Type -> TypeView
    tyView -> FunTy Type
    arg Type
    res) -> (State Int Term -> Int -> Term) -> Int -> State Int Term -> Term
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip State Int Term -> Int -> Term
    forall s a. State s a -> s -> a
    State.evalState (Int
    0 :: Int) (State Int Term -> Term) -> State Int Term -> Term
    forall a b. (a -> b) -> a -> b
    $ do
                  Id
    dcId <- InScopeSet -> Text -> Type -> StateT Int Identity Id
    forall (m :: Type -> Type).
    MonadUnique m =>
    InScopeSet -> Text -> Type -> m Id
    mkInternalVar InScopeSet
    inScope0 Text
    "dict" (Type -> Type -> Type
    mkFunTy Type
    arg Type
    res)
                  Term -> State Int Term
    forall a. a -> StateT Int Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Term -> [TyVar] -> Term
    mkTyLams (Term -> [Id] -> Term
    mkLams (Id -> Term
    Var Id
    dcId) [Id
    dcId]) [TyVar]
    tvs)
          Just Type
    dictTy -> (State Int Term -> Int -> Term) -> Int -> State Int Term -> Term
    forall a b c. (a -> b -> c) -> b -> a -> c
    flip State Int Term -> Int -> Term
    forall s a. State s a -> s -> a
    State.evalState (Int
    0 :: Int) (State Int Term -> Term) -> State Int Term -> Term
    forall a b. (a -> b) -> a -> b
    $ do
                  Id
    dcId <- InScopeSet -> Text -> Type -> StateT Int Identity Id
    forall (m :: Type -> Type).
    MonadUnique m =>
    InScopeSet -> Text -> Type -> m Id
    mkInternalVar InScopeSet
    inScope0 Text
    "dict" Type
    dictTy
                  Term -> State Int Term
    forall a. a -> StateT Int Identity a
    forall (m :: Type -> Type) a. Monad m => a -> m a
    return (Term -> [TyVar] -> Term
    mkTyLams (Term -> [Id] -> Term
    mkLams (Id -> Term
    Var Id
    dcId) [Id
    dcId]) [TyVar]
    tvs)
          Maybe Type
    Nothing -> String -> Term
    forall a. HasCallStack => String -> a
    error String
    "mkClassSelector: expected at least one dictionary argument"

    mkTupTyCons :: GHC2CoreState -> (GHC2CoreState,IntMap TyConName)
    mkTupTyCons :: GHC2CoreState -> (GHC2CoreState, IntMap TyConName)
    mkTupTyCons GHC2CoreState
    tcMap = (GHC2CoreState
    tcMap'',IntMap TyConName
    forall {a}. IntMap (Name a)
    tupTcCache)
      where
        tupTyCons :: [TyCon]
    tupTyCons        = TyCon
    GHC.boolTyCon TyCon -> [TyCon] -> [TyCon]
    forall a. a -> [a] -> [a]
    : TyCon
    GHC.promotedTrueDataCon TyCon -> [TyCon] -> [TyCon]
    forall a. a -> [a] -> [a]
    : TyCon
    GHC.promotedFalseDataCon
                         TyCon -> [TyCon] -> [TyCon]
    forall a. a -> [a] -> [a]
    : (Int -> TyCon) -> [Int] -> [TyCon]
    forall a b. (a -> b) -> [a] -> [b]
    map (Boxity -> Int -> TyCon
    GHC.tupleTyCon Boxity
    GHC.Boxed) [Int
    2..Int
    GHC.mAX_TUPLE_SIZE]
        ([Name a]
    tcNames,GHC2CoreState
    tcMap',SrcSpanRB
    _) =
          RWS GHC2CoreEnv SrcSpanRB GHC2CoreState [Name a]
    -> GHC2CoreEnv
    -> GHC2CoreState
    -> ([Name a], GHC2CoreState, SrcSpanRB)
    forall r w s a. RWS r w s a -> r -> s -> (a, s, w)
    RWS.runRWS ((TyCon
     -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Name a))
    -> [TyCon] -> RWS GHC2CoreEnv SrcSpanRB GHC2CoreState [Name a]
    forall (t :: Type -> Type) (m :: Type -> Type) a b.
    (Traversable t, Monad m) =>
    (a -> m b) -> t a -> m (t b)
    forall (m :: Type -> Type) a b.
    Monad m =>
    (a -> m b) -> [a] -> m [b]
    mapM (\TyCon
    tc -> (TyCon -> Name)
    -> (TyCon -> Unique)
    -> (Name -> C2C Text)
    -> TyCon
    -> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Name a)
    forall b a.
    (b -> Name)
    -> (b -> Unique) -> (Name -> C2C Text) -> b -> C2C (Name a)
    coreToName TyCon -> Name
    GHC.tyConName TyCon -> Unique
    GHC.tyConUnique
                                              Name -> C2C Text
    qualifiedNameString TyCon
    tc) [TyCon]
    tupTyCons)
                     (SrcSpan -> FamInstEnvs -> GHC2CoreEnv
    GHC2CoreEnv SrcSpan
    GHC.noSrcSpan FamInstEnvs
    GHC.emptyFamInstEnvs)
                     GHC2CoreState
    tcMap
        tupTcCache :: IntMap (Name a)
    tupTcCache       = [(Int, Name a)] -> IntMap (Name a)
    forall a. [(Int, a)] -> IntMap a
    IMS.fromList ([Int] -> [Name a] -> [(Int, Name a)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Int
    2..Int
    GHC.mAX_TUPLE_SIZE] (Int -> [Name a] -> [Name a]
    forall a. Int -> [a] -> [a]
    drop Int
    3 [Name a]
    forall {a}. [Name a]
    tcNames))
        tupHM :: UniqMap TyCon
    tupHM            = [(Name Any, TyCon)] -> UniqMap TyCon
    forall a b. Uniquable a => [(a, b)] -> UniqMap b
    UniqMap.fromList ([Name Any] -> [TyCon] -> [(Name Any, TyCon)]
    forall a b. [a] -> [b] -> [(a, b)]
    zip [Name Any]
    forall {a}. [Name a]
    tcNames [TyCon]
    tupTyCons)
        tcMap'' :: GHC2CoreState
    tcMap''          = GHC2CoreState
    tcMap' GHC2CoreState -> (GHC2CoreState -> GHC2CoreState) -> GHC2CoreState
    forall a b. a -> (a -> b) -> b
    & (UniqMap TyCon -> Identity (UniqMap TyCon))
    -> GHC2CoreState -> Identity GHC2CoreState
    Lens' GHC2CoreState (UniqMap TyCon)
    tyConMap ((UniqMap TyCon -> Identity (UniqMap TyCon))
     -> GHC2CoreState -> Identity GHC2CoreState)
    -> (UniqMap TyCon -> UniqMap TyCon)
    -> GHC2CoreState
    -> GHC2CoreState
    forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
    %~ (UniqMap TyCon -> UniqMap TyCon -> UniqMap TyCon
    forall a. Semigroup a => a -> a -> a
    <> UniqMap TyCon
    tupHM)