{-|
  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.Bool       (toGhcOverridingBool)
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.Unique            (Unique)
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
  (  bindings
   , clsOps
   , unlocatable
   , fiEnvs
   , topEntities
   , partitionEithers -> (unresolvedPrims, pFP)
   , customBitRepresentations
   , primGuards
   , 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 (OverridingBool -> OverridingBool
toGhcOverridingBool (ClashOpts -> OverridingBool
opt_color ClashOpts
opts)) HDL
hdl String
modName Maybe DynFlags
dflagsM [String]
importDirs
  startTime <- Clock.getCurrentTime
  primMapR <- generatePrimMap unresolvedPrims primGuards (concat [pFP, primDirs, importDirs])
  tdir <- maybe ghcLibDir (pure . GHC.topDir) dflagsM
  primMapC <-
    sequence $ HashMap.map
                 (sequence . fmap (compilePrimitive importDirs dbs tdir))
                 primMapR
  let ((bindingsMap,clsVMap),tcMap,_) =
        RWS.runRWS (mkBindings primMapC bindings clsOps unlocatable)
                   (GHC2CoreEnv GHC.noSrcSpan fiEnvs)
                   emptyGHC2CoreState
      (tcMap',tupTcCache)           = mkTupTyCons tcMap
      tcCache                       = GHC2CoreState -> FamInstEnvs -> UniqMap TyCon
makeAllTyCons GHC2CoreState
tcMap' FamInstEnvs
fiEnvs
      allTcCache                    = UniqMap TyCon
tysPrimMap UniqMap TyCon -> UniqMap TyCon -> UniqMap TyCon
forall a. Semigroup a => a -> a -> a
<> UniqMap TyCon
tcCache
      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 =
        ((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
bindingsMap BindingMap -> BindingMap -> BindingMap
forall a. VarEnv a -> VarEnv a -> VarEnv a
`unionVarEnv` BindingMap
clsMap
      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
            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
            return (topEnt', annM, isTb)) [(CoreBndr, Maybe TopEntity, Bool)]
topEntities
      topEntities'' =
        ((Name (ZonkAny 2), Maybe TopEntity, Bool) -> TopEntityT)
-> [(Name (ZonkAny 2), Maybe TopEntity, Bool)] -> [TopEntityT]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name (ZonkAny 2)
topEnt, Maybe TopEntity
annM, Bool
isTb) ->
                case Name (ZonkAny 2) -> BindingMap -> Maybe (Binding Term)
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
UniqMap.lookup Name (ZonkAny 2)
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. HasCallStack => String -> a
GHC.pgmError [I.i|
                    No top entity called '#{topEnt}' found. Make sure you are
                    compiling with the '-fexpose-all-unfoldings' flag.
                  |]
            ) [(Name (ZonkAny 2), Maybe TopEntity, Bool)]
forall {a}. [(Name a, Maybe TopEntity, Bool)]
topEntities'
  -- Parsing / compiling primitives:
  prepTime  <- startTime `deepseq` primMapC `seq` Clock.getCurrentTime
  let prepStartDiff = UTCTime -> UTCTime -> String
reportTimeDiff UTCTime
prepTime UTCTime
startTime
  putStrLn $ "Clash: Parsing and compiling primitives took " ++ prepStartDiff

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

  return
    ( ClashEnv
        { envOpts = opts
        , envTyConMap = allTcCache
        , envTupleTyCons = tupTcCache
        , envPrimitives = primMapC
        , envCustomReprs = buildCustomReprs customBitRepresentations
        , envDomains = domainConfs
        }
    , ClashDesign
        { designEntities = topEntities''
        , designBindings = 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 = GHC.Opaque 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
  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
$ HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
GHC.idInfo CoreBndr
v
      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)
      v' <- coreToId v
      nm <- qualifiedNameString (GHC.varName v)
      let 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
      checkPrimitive primMap v
      return [(v', (Binding v' sp inl pr tm False))]
    GHC.Rec [(CoreBndr, Expr CoreBndr)]
bs -> do
      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
$ HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
GHC.idInfo CoreBndr
v
                    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)
                    v' <- coreToId v
                    nm <- qualifiedNameString (GHC.varName v)
                    let 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
                    checkPrimitive primMap v
                    return (Binding v' sp inl pr tm True)
                  ) [(CoreBndr, Expr CoreBndr)]
bs
      case 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 = Letrec lbs (Var i), bindingRecursive = 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
  clsOpList    <- mapM (\(CoreBndr
v,Int
i) -> do
                          v' <- CoreBndr -> C2C Id
coreToId CoreBndr
v
                          return (v', (v',i))
                       ) clsOps

  return (mkVarEnv (concat bindingsList), mkVarEnv 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
  nm <- Name -> C2C Text
qualifiedNameString (CoreBndr -> Name
GHC.varName CoreBndr
v)
  case HashMap.lookup nm primMap >>= 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 = HasDebugCallStack => 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 ()
      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
"primitive " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
qName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" "
      let 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 [] = () -> 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

      unless (qName == "Clash.XException.errorX" || "GHC." `isPrefixOf` qName) $ do
        warnIf (not (isOpaque inline))
#if MIN_VERSION_ghc(9,4,0)
          (primStr ++ "isn't marked OPAQUE."
#else
          (primStr ++ "isn't marked NOINLINE."
#endif
          ++ "\nThis might make Clash ignore this primitive.")
#if MIN_VERSION_ghc(9,2,0)
        warnIf (GHC.isDeadEndAppSig strictness nrOfArgs)
#elif MIN_VERSION_ghc(9,0,0)
        warnIf (GHC.appIsDeadEnd strictness nrOfArgs)
#else
        warnIf (GHC.appIsBottom strictness nrOfArgs)
#endif
          ("The Haskell implementation of " ++ primStr
          ++ "produces a result that always results in an error.\n"
          ++ "This can lead to compile failures because GHC can replace entire "
          ++ "calls to this primitive by an undefined value.")
        warnArgs 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 Unique Term -> Unique -> Term)
-> Unique -> State Unique Term -> Term
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Unique Term -> Unique -> Term
forall s a. State s a -> s -> a
State.evalState (Unique
0 :: Unique) (State Unique Term -> Term) -> State Unique Term -> Term
forall a b. (a -> b) -> a -> b
$ do
              dcId <- InScopeSet -> Text -> Type -> StateT Unique Identity Id
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Type -> m Id
mkInternalVar InScopeSet
inScope0 Text
"dict" Type
dictTy
              let inScope1 = InScopeSet -> Id -> InScopeSet
forall a. InScopeSet -> Var a -> InScopeSet
extendInScopeSet InScopeSet
inScope0 Id
dcId
              selE <- mkSelectorCase "mkClassSelector" inScope1 tcm (Var dcId) 1 sel
              return (mkTyLams (mkLams selE [dcId]) tvs)
      Just (Type -> TypeView
tyView -> FunTy Type
arg Type
res) -> (State Unique Term -> Unique -> Term)
-> Unique -> State Unique Term -> Term
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Unique Term -> Unique -> Term
forall s a. State s a -> s -> a
State.evalState (Unique
0 :: Unique) (State Unique Term -> Term) -> State Unique Term -> Term
forall a b. (a -> b) -> a -> b
$ do
              dcId <- InScopeSet -> Text -> Type -> StateT Unique 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)
              return (mkTyLams (mkLams (Var dcId) [dcId]) tvs)
      Just Type
dictTy -> (State Unique Term -> Unique -> Term)
-> Unique -> State Unique Term -> Term
forall a b c. (a -> b -> c) -> b -> a -> c
flip State Unique Term -> Unique -> Term
forall s a. State s a -> s -> a
State.evalState (Unique
0 :: Unique) (State Unique Term -> Term) -> State Unique Term -> Term
forall a b. (a -> b) -> a -> b
$ do
              dcId <- InScopeSet -> Text -> Type -> StateT Unique Identity Id
forall (m :: Type -> Type).
MonadUnique m =>
InScopeSet -> Text -> Type -> m Id
mkInternalVar InScopeSet
inScope0 Text
"dict" Type
dictTy
              return (mkTyLams (mkLams (Var dcId) [dcId]) 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 (ZonkAny 1), TyCon)] -> UniqMap TyCon
forall a b. Uniquable a => [(a, b)] -> UniqMap b
UniqMap.fromList ([Name (ZonkAny 1)] -> [TyCon] -> [(Name (ZonkAny 1), TyCon)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name (ZonkAny 1)]
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)