{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                          2017, QBayLogic, Google Inc.
  License     :  BSD2 (see the file LICENSE)
  Maintainer  :  Christiaan Baaij <christiaan.baaij@gmail.com>
-}

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

module Clash.GHC.GenerateBindings
  (generateBindings)
where

import           Control.Arrow           ((***), first)
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 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)
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.Utils.Misc          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 Util                    as GHC
import qualified Var                     as GHC
import qualified SrcLoc                  as GHC
#endif

import           Clash.Annotations.BitRepresentation.Internal (DataRepr')
import           Clash.Annotations.Primitive (HDL, extractPrim)
import           Clash.Signal.Internal

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           Clash.Debug             (traceIf)
import           Clash.Driver            (compilePrimitive)
import           Clash.Driver.Types      (BindingMap, Binding(..), IsPrim(..))
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
  (listToUniqMap, lookupUniqMap, mapUniqMap, unionUniqMap, uniqMapToUniqSet)
import           Clash.Util              (reportTimeDiff)

-- | Safe indexing, returns a 'Nothing' if the index does not exist
indexMaybe :: [a] -> Int -> Maybe a
indexMaybe :: [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
  :: 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
  -> GHC.OverridingBool
  -- ^ Use color
  -> [FilePath]
  -- ^ primitives (blackbox) directories
  -> [FilePath]
  -- ^ import directories (-i flag)
  -> [FilePath]
  -- ^ Package database
  -> HDL
  -- ^ HDL target
  -> String
  -> Maybe GHC.DynFlags
  -> IO ( BindingMap
        , TyConMap
        , IntMap TyConName
        , [TopEntityT]
        , CompiledPrimMap  -- The primitives found in '.' and 'primDir'
        , [DataRepr']
        , HashMap.HashMap Text.Text VDomainConfiguration
        )
generateBindings :: Ghc ()
-> OverridingBool
-> [FilePath]
-> [FilePath]
-> [FilePath]
-> HDL
-> FilePath
-> Maybe DynFlags
-> IO
     (BindingMap, TyConMap, IntMap TyConName, [TopEntityT],
      CompiledPrimMap, [DataRepr'], HashMap Text VDomainConfiguration)
generateBindings Ghc ()
startAction OverridingBool
useColor [FilePath]
primDirs [FilePath]
importDirs [FilePath]
dbs HDL
hdl FilePath
modName Maybe DynFlags
dflagsM = do
  (  [CoreBind]
bindings
   , [(CoreBndr, Int)]
clsOps
   , [CoreBndr]
unlocatable
   , FamInstEnvs
fiEnvs
   , [(CoreBndr, Maybe TopEntity, Bool)]
topEntities
   , [Either UnresolvedPrimitive FilePath]
-> ([UnresolvedPrimitive], [FilePath])
forall a b. [Either a b] -> ([a], [b])
partitionEithers -> ([UnresolvedPrimitive]
unresolvedPrims, [FilePath]
pFP)
   , [DataRepr']
customBitRepresentations
   , [(Text, PrimitiveGuard ())]
primGuards
   , HashMap Text VDomainConfiguration
domainConfs ) <- Ghc ()
-> OverridingBool
-> HDL
-> FilePath
-> Maybe DynFlags
-> [FilePath]
-> IO
     ([CoreBind], [(CoreBndr, Int)], [CoreBndr], FamInstEnvs,
      [(CoreBndr, Maybe TopEntity, Bool)],
      [Either UnresolvedPrimitive FilePath], [DataRepr'],
      [(Text, PrimitiveGuard ())], HashMap Text VDomainConfiguration)
loadModules Ghc ()
startAction OverridingBool
useColor HDL
hdl FilePath
modName Maybe DynFlags
dflagsM [FilePath]
importDirs
  ResolvedPrimMap
primMapR <- HasCallStack =>
[UnresolvedPrimitive]
-> [(Text, PrimitiveGuard ())] -> [FilePath] -> IO ResolvedPrimMap
[UnresolvedPrimitive]
-> [(Text, PrimitiveGuard ())] -> [FilePath] -> IO ResolvedPrimMap
generatePrimMap [UnresolvedPrimitive]
unresolvedPrims [(Text, PrimitiveGuard ())]
primGuards ([[FilePath]] -> [FilePath]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [[FilePath]
pFP, [FilePath]
primDirs, [FilePath]
importDirs])
  FilePath
tdir <- IO FilePath
-> (DynFlags -> IO FilePath) -> Maybe DynFlags -> IO FilePath
forall b a. b -> (a -> b) -> Maybe a -> b
maybe IO FilePath
ghcLibDir (FilePath -> IO FilePath
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure (FilePath -> IO FilePath)
-> (DynFlags -> FilePath) -> DynFlags -> IO FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DynFlags -> FilePath
GHC.topDir) Maybe DynFlags
dflagsM
  UTCTime
startTime <- IO UTCTime
Clock.getCurrentTime
  CompiledPrimMap
primMapC <-
    HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
-> IO CompiledPrimMap
forall (t :: Type -> Type) (m :: Type -> Type) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
 -> IO CompiledPrimMap)
-> HashMap Text (IO (PrimitiveGuard CompiledPrimitive))
-> IO CompiledPrimMap
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)
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 (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
fmap ([FilePath]
-> [FilePath]
-> FilePath
-> ResolvedPrimitive
-> IO CompiledPrimitive
compilePrimitive [FilePath]
importDirs [FilePath]
dbs FilePath
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 (CompiledPrimMap
-> [CoreBind]
-> [(CoreBndr, Int)]
-> [CoreBndr]
-> RWS
     GHC2CoreEnv SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
mkBindings CompiledPrimMap
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 :: TyConMap
tcCache                       = GHC2CoreState -> FamInstEnvs -> TyConMap
makeAllTyCons GHC2CoreState
tcMap' FamInstEnvs
fiEnvs
      allTcCache :: TyConMap
allTcCache                    = TyConMap
tysPrimMap TyConMap -> TyConMap -> TyConMap
forall a. UniqMap a -> UniqMap a -> UniqMap a
`unionUniqMap` TyConMap
tcCache
      inScope0 :: InScopeSet
inScope0 = VarSet -> InScopeSet
mkInScopeSet (UniqMap (Var Any) -> VarSet
forall a. UniqMap a -> UniqSet a
uniqMapToUniqSet
                      (((Binding Term -> Var Any) -> BindingMap -> UniqMap (Var Any)
forall a b. (a -> b) -> UniqMap a -> UniqMap b
mapUniqMap (Id -> Var Any
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. UniqMap a -> UniqMap a -> UniqMap a
`unionUniqMap`
                       ((Binding Term -> Var Any) -> BindingMap -> UniqMap (Var Any)
forall a b. (a -> b) -> UniqMap a -> UniqMap b
mapUniqMap (Id -> Var Any
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)))
      clsMap :: BindingMap
clsMap                        = ((Id, Int) -> Binding Term) -> VarEnv (Id, Int) -> BindingMap
forall a b. (a -> b) -> UniqMap a -> UniqMap b
mapUniqMap (\(Id
v,Int
i) -> (Id -> SrcSpan -> InlineSpec -> IsPrim -> Term -> Binding Term
forall a. Id -> SrcSpan -> InlineSpec -> IsPrim -> a -> Binding a
Binding Id
v SrcSpan
GHC.noSrcSpan InlineSpec
GHC.Inline IsPrim
IsFun (InScopeSet -> TyConMap -> Type -> Int -> Term
mkClassSelector InScopeSet
inScope0 TyConMap
allTcCache (Id -> Type
forall a. Var a -> Type
varType Id
v) Int
i))) VarEnv (Id, Int)
clsVMap
      allBindings :: BindingMap
allBindings                   = BindingMap
bindingsMap BindingMap -> BindingMap -> BindingMap
forall a. UniqMap a -> UniqMap a -> UniqMap 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)
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 (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
lookupUniqMap 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 -> FilePath -> TopEntityT
forall a. HasCallStack => FilePath -> a
error FilePath
"This shouldn't happen"
            ) [(Name Any, Maybe TopEntity, Bool)]
forall a. [(Name a, Maybe TopEntity, Bool)]
topEntities'
  -- Parsing / compiling primitives:
  UTCTime
prepTime  <- UTCTime
startTime UTCTime -> CompiledPrimMap -> CompiledPrimMap
forall a b. NFData a => a -> b -> b
`deepseq` CompiledPrimMap
primMapC CompiledPrimMap -> IO UTCTime -> IO UTCTime
`seq` IO UTCTime
Clock.getCurrentTime
  let prepStartDiff :: FilePath
prepStartDiff = UTCTime -> UTCTime -> FilePath
reportTimeDiff UTCTime
prepTime UTCTime
startTime
  FilePath -> IO ()
putStrLn (FilePath -> IO ()) -> FilePath -> IO ()
forall a b. (a -> b) -> a -> b
$ FilePath
"Clash: Parsing and compiling primitives took " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
prepStartDiff

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

  (BindingMap, TyConMap, IntMap TyConName, [TopEntityT],
 CompiledPrimMap, [DataRepr'], HashMap Text VDomainConfiguration)
-> IO
     (BindingMap, TyConMap, IntMap TyConName, [TopEntityT],
      CompiledPrimMap, [DataRepr'], HashMap Text VDomainConfiguration)
forall (m :: Type -> Type) a. Monad m => a -> m a
return ( BindingMap
allBindings'
         , TyConMap
allTcCache
         , IntMap TyConName
tupTcCache
         , [TopEntityT]
topEntities''
         , CompiledPrimMap
primMapC
         , [DataRepr']
customBitRepresentations
         , HashMap Text VDomainConfiguration
domainConfs
         )

setNoInlineTopEntities
  :: BindingMap
  -> [TopEntityT]
  -> BindingMap
setNoInlineTopEntities :: BindingMap -> [TopEntityT] -> BindingMap
setNoInlineTopEntities BindingMap
bm [TopEntityT]
tes =
  (Binding Term -> Binding Term) -> BindingMap -> BindingMap
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 :: VarSet
ids = [Id] -> VarSet
forall a. [Var a] -> VarSet
mkVarSet ((TopEntityT -> Id) -> [TopEntityT] -> [Id]
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 :: Id
bindingId :: forall a. Binding a -> Id
bindingId}
    | Id
bindingId Id -> VarSet -> Bool
forall a. Var a -> VarSet -> Bool
`elemVarSet` VarSet
ids = Binding a
b { bindingSpec :: InlineSpec
bindingSpec = InlineSpec
GHC.NoInline }
    | 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 :: CompiledPrimMap
-> [CoreBind]
-> [(CoreBndr, Int)]
-> [CoreBndr]
-> RWS
     GHC2CoreEnv SrcSpanRB GHC2CoreState (BindingMap, VarEnv (Id, Int))
mkBindings CompiledPrimMap
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)
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
      Term
tm <- (GHC2CoreEnv -> GHC2CoreEnv)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
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) (CompiledPrimMap
-> [CoreBndr]
-> Expr CoreBndr
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
coreToTerm CompiledPrimMap
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 -> CompiledPrimMap -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Text
nm CompiledPrimMap
primMap then IsPrim
IsPrim else IsPrim
IsFun
      CompiledPrimMap -> CoreBndr -> C2C ()
checkPrimitive CompiledPrimMap
primMap CoreBndr
v
      [(Id, Binding Term)]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, Binding Term)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [(Id
v', (Id -> SrcSpan -> InlineSpec -> IsPrim -> Term -> Binding Term
forall a. Id -> SrcSpan -> InlineSpec -> IsPrim -> a -> Binding a
Binding Id
v' SrcSpan
sp InlineSpec
inl IsPrim
pr Term
tm))]
    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)
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
                    Term
tm <- (GHC2CoreEnv -> GHC2CoreEnv)
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
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) (CompiledPrimMap
-> [CoreBndr]
-> Expr CoreBndr
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity Term
coreToTerm CompiledPrimMap
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 -> CompiledPrimMap -> Bool
forall k a. (Eq k, Hashable k) => k -> HashMap k a -> Bool
HashMap.member Text
nm CompiledPrimMap
primMap then IsPrim
IsPrim else IsPrim
IsFun
                    CompiledPrimMap -> CoreBndr -> C2C ()
checkPrimitive CompiledPrimMap
primMap CoreBndr
v
                    Binding Term
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity (Binding Term)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (Id -> SrcSpan -> InlineSpec -> IsPrim -> Term -> Binding Term
forall a. Id -> SrcSpan -> InlineSpec -> IsPrim -> a -> Binding a
Binding Id
v' SrcSpan
sp InlineSpec
inl IsPrim
pr Term
tm)
                  ) [(CoreBndr, Expr CoreBndr)]
bs
      case [Binding Term]
tms of
        [Binding Id
v SrcSpan
sp InlineSpec
inl IsPrim
pr Term
tm] -> [(Id, Binding Term)]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, Binding Term)]
forall (m :: Type -> Type) a. Monad m => a -> m a
return [(Id
v, Id -> SrcSpan -> InlineSpec -> IsPrim -> Term -> Binding Term
forall a. Id -> SrcSpan -> InlineSpec -> IsPrim -> a -> Binding a
Binding Id
v SrcSpan
sp InlineSpec
inl IsPrim
pr Term
tm)]

        -- 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) })) [Binding Term]
tms [(Id, Term)]
lbs
             in  [(Id, Binding Term)]
-> RWST
     GHC2CoreEnv SrcSpanRB GHC2CoreState Identity [(Id, Binding Term)]
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)
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 (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 (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 :: CompiledPrimMap -> CoreBndr -> C2C ()
checkPrimitive CompiledPrimMap
primMap CoreBndr
v = do
  Text
nm <- Name -> C2C Text
qualifiedNameString (CoreBndr -> Name
GHC.varName CoreBndr
v)
  case Text -> CompiledPrimMap -> Maybe (PrimitiveGuard CompiledPrimitive)
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
HashMap.lookup Text
nm CompiledPrimMap
primMap Maybe (PrimitiveGuard CompiledPrimitive)
-> (PrimitiveGuard CompiledPrimitive -> Maybe CompiledPrimitive)
-> Maybe CompiledPrimitive
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 :: forall a b c d. Primitive a b c d -> [b]
resultNames :: [BlackBox]
resultNames, [BlackBox]
resultInits :: forall a b c d. Primitive a b c d -> [b]
resultInits :: [BlackBox]
resultInits, BlackBox
template :: forall a b c d. Primitive a b c d -> b
template :: BlackBox
template, [((Text, Text), BlackBox)]
includes :: forall a b c d. Primitive a b c d -> [((Text, Text), b)]
includes :: [((Text, Text), BlackBox)]
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
        strictness :: StrictSig
strictness = IdInfo -> StrictSig
GHC.strictnessInfo IdInfo
info
        ty :: Kind
ty = CoreBndr -> Kind
GHC.varType CoreBndr
v
        ([Kind]
argTys,Kind
_resTy) = Kind -> ([Kind], Kind)
GHC.splitFunTys (Kind -> ([Kind], Kind))
-> (Kind -> Kind) -> Kind -> ([Kind], Kind)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([CoreBndr], Kind) -> Kind
forall a b. (a, b) -> b
snd (([CoreBndr], Kind) -> Kind)
-> (Kind -> ([CoreBndr], Kind)) -> Kind -> Kind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Kind -> ([CoreBndr], Kind)
GHC.splitForAllTys (Kind -> ([Kind], Kind)) -> Kind -> ([Kind], Kind)
forall a b. (a -> b) -> a -> b
$ Kind
ty
        ([Demand]
dmdArgs,DmdResult
_dmdRes) = StrictSig -> ([Demand], DmdResult)
GHC.splitStrictSig StrictSig
strictness
        nrOfArgs :: Int
nrOfArgs = [Kind] -> Int
forall (t :: Type -> Type) a. Foldable t => t a -> Int
length [Kind]
argTys
        loc :: FilePath
loc = case CoreBndr -> SrcLoc
forall a. NamedThing a => a -> SrcLoc
GHC.getSrcLoc CoreBndr
v of
                GHC.UnhelpfulLoc FastString
_ -> FilePath
""
#if MIN_VERSION_ghc(9,0,0)
                GHC.RealSrcLoc l _ -> showPpr l ++ ": "
#else
                GHC.RealSrcLoc RealSrcLoc
l   -> RealSrcLoc -> FilePath
forall a. Outputable a => a -> FilePath
showPpr RealSrcLoc
l FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
": "
#endif
        warnIf :: Bool -> FilePath -> m ()
warnIf Bool
cond FilePath
msg = Bool -> FilePath -> (() -> m ()) -> () -> m ()
forall a. Bool -> FilePath -> a -> a
traceIf Bool
cond (FilePath
"\n"FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
locFilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
"Warning: "FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++FilePath
msg) () -> m ()
forall (m :: Type -> Type) a. Monad m => a -> m a
return ()
      FilePath
qName <- Text -> FilePath
Text.unpack (Text -> FilePath)
-> C2C Text
-> RWST GHC2CoreEnv SrcSpanRB GHC2CoreState Identity FilePath
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 :: FilePath
primStr = FilePath
"primitive " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
qName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" "
      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 (m :: Type -> Type) a. Monad m => a -> m a
return ()
          warnArgs (Int
x:[Int]
xs) = do
            Bool -> FilePath -> m ()
forall (m :: Type -> Type). Monad m => Bool -> FilePath -> m ()
warnIf (Bool -> (Demand -> Bool) -> Maybe Demand -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Demand -> Bool
forall s u. JointDmd (Str s) (Use u) -> Bool
GHC.isAbsDmd ([Demand] -> Int -> Maybe Demand
forall a. [a] -> Int -> Maybe a
indexMaybe [Demand]
dmdArgs Int
x))
              (FilePath
"The Haskell implementation of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
primStr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"isn't using argument #" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
               Int -> FilePath
forall a. Show a => a -> FilePath
show Int
x FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
", but the corresponding primitive blackbox does.\n" FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
               FilePath
"This can lead to incorrect HDL output because GHC can replace these " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++
               FilePath
"arguments by an undefined value.")
            [Int] -> m ()
warnArgs [Int]
xs

      Bool -> C2C () -> C2C ()
forall (f :: Type -> Type). Applicative f => Bool -> f () -> f ()
unless (FilePath
qName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
== FilePath
"Clash.XException.errorX" Bool -> Bool -> Bool
|| FilePath
"GHC." FilePath -> FilePath -> Bool
forall a. Eq a => [a] -> [a] -> Bool
`isPrefixOf` FilePath
qName) (C2C () -> C2C ()) -> C2C () -> C2C ()
forall a b. (a -> b) -> a -> b
$ do
        Bool -> FilePath -> C2C ()
forall (m :: Type -> Type). Monad m => Bool -> FilePath -> m ()
warnIf (InlineSpec
inline InlineSpec -> InlineSpec -> Bool
forall a. Eq a => a -> a -> Bool
/= InlineSpec
GHC.NoInline)
          (FilePath
primStr FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"isn't marked NOINLINE."
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\nThis might make Clash ignore this primitive.")
#if MIN_VERSION_ghc(9,0,0)
        warnIf (GHC.appIsDeadEnd strictness nrOfArgs)
#else
        Bool -> FilePath -> C2C ()
forall (m :: Type -> Type). Monad m => Bool -> FilePath -> m ()
warnIf (StrictSig -> Int -> Bool
GHC.appIsBottom StrictSig
strictness Int
nrOfArgs)
#endif
          (FilePath
"The Haskell implementation of " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
primStr
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"produces a result that always results in an error.\n"
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"This can lead to compile failures because GHC can replace entire "
          FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"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 (m :: Type -> Type) a. Monad m => a -> m a
return ()
  where
    showPpr :: GHC.Outputable a => a -> String
    showPpr :: a -> FilePath
showPpr = SDoc -> FilePath
GHC.showSDocUnsafe (SDoc -> FilePath) -> (a -> SDoc) -> a -> FilePath
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 -> TyConMap -> Type -> Int -> Term
mkClassSelector InScopeSet
inScope0 TyConMap
tcm Type
ty Int
sel = Term
newExpr
  where
    (([TyVar]
tvs,Type
dictTy:[Type]
_),Type
_) = (([Either TyVar Type], [Either TyVar Type]) -> ([TyVar], [Type]))
-> (([Either TyVar Type], [Either TyVar Type]), Type)
-> (([TyVar], [Type]), Type)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ([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 (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]), Type)
 -> (([TyVar], [Type]), Type))
-> (([Either TyVar Type], [Either TyVar Type]), Type)
-> (([TyVar], [Type]), Type)
forall a b. (a -> b) -> a -> b
$ ([Either TyVar Type] -> ([Either TyVar Type], [Either TyVar Type]))
-> ([Either TyVar Type], Type)
-> (([Either TyVar Type], [Either TyVar Type]), Type)
forall (a :: Type -> Type -> Type) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first ((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], Type)
 -> (([Either TyVar Type], [Either TyVar Type]), Type))
-> ([Either TyVar Type], Type)
-> (([Either TyVar Type], [Either TyVar Type]), Type)
forall a b. (a -> b) -> a -> b
$ Type -> ([Either TyVar Type], Type)
splitFunForallTy Type
ty
    newExpr :: Term
newExpr = case Type -> TypeView
tyView Type
dictTy of
      (TyConApp TyConName
tcNm [Type]
_)
        | Just TyCon
tc <- TyConName -> TyConMap -> Maybe TyCon
forall a b. Uniquable a => a -> UniqMap b -> Maybe b
lookupUniqMap TyConName
tcNm TyConMap
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 <- FilePath
-> InScopeSet -> TyConMap -> Term -> Int -> Int -> State Int Term
forall (m :: Type -> Type).
(HasCallStack, MonadUnique m) =>
FilePath -> InScopeSet -> TyConMap -> Term -> Int -> Int -> m Term
mkSelectorCase FilePath
"mkClassSelector" InScopeSet
inScope1 TyConMap
tcm (Id -> Term
Var Id
dcId) Int
1 Int
sel
                          Term -> State Int Term
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)
      (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 (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)
      TypeView
_ -> (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 (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)

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)
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
listToUniqMap ([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. UniqMap a -> UniqMap a -> UniqMap a
`unionUniqMap` UniqMap TyCon
tupHM)