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

{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}

module Clash.GHC.LoadInterfaceFiles
  ( loadExternalExprs
  , loadExternalBinders
  , getUnresolvedPrimitives
  , LoadedBinders(..)
  , mergeLoadedBinders
  , emptyLb
  )
where

-- External Modules
import           Control.Monad.IO.Class      (MonadIO (..))
import qualified Data.ByteString.Lazy.UTF8   as BLU
import qualified Data.ByteString.Lazy        as BL
import           Data.Either                 (partitionEithers)
import           Data.List                   (elemIndex, foldl')
import qualified Data.Text                   as Text
import           Data.Maybe                  (isNothing, mapMaybe, catMaybes)
import           Data.Word                   (Word8)

-- GHC API
#if MIN_VERSION_ghc(9,0,0)
import           GHC.Types.Annotations (Annotation(..))
import qualified GHC.Types.Annotations as Annotations
import qualified GHC.Core.Class as Class
import qualified GHC.Core.FVs as CoreFVs
import qualified GHC.Core as CoreSyn
import qualified GHC.Types.Demand as Demand
import           GHC.Driver.Session as DynFlags (unsafeGlobalDynFlags)
import qualified GHC
import qualified GHC.Types.Id as Id
import qualified GHC.Types.Id.Info as IdInfo
import qualified GHC.Iface.Syntax as IfaceSyn
import qualified GHC.Iface.Load as LoadIface
import qualified GHC.Data.Maybe as Maybes
import qualified GHC.Core.Make as MkCore
import qualified GHC.Unit.Module as Module
import qualified GHC.Unit.Module.Env as ModuleEnv
import qualified GHC.Utils.Monad as MonadUtils
import qualified GHC.Types.Name as Name
import qualified GHC.Types.Name.Env as NameEnv
import           GHC.Utils.Outputable as Outputable (showPpr, showSDoc, text)
import qualified GHC.Plugins as GhcPlugins (deserializeWithData, fromSerialized)
import qualified GHC.IfaceToCore as TcIface
import qualified GHC.Tc.Utils.Monad as TcRnMonad
import qualified GHC.Tc.Types as TcRnTypes
import qualified GHC.Types.Unique.FM as UniqFM
import qualified GHC.Types.Unique.Set as UniqSet
import qualified GHC.Types.Var as Var
import qualified GHC.Unit.Types as UnitTypes
#else
import           Annotations (Annotation(..), getAnnTargetName_maybe)
import qualified Annotations
import qualified Class
import qualified CoreFVs
import qualified CoreSyn
import qualified Demand
import           DynFlags                    (unsafeGlobalDynFlags)
import qualified GHC
import qualified Id
import qualified IdInfo
import qualified IfaceSyn
import qualified LoadIface
import qualified Maybes
import qualified MkCore
import qualified Module
import qualified MonadUtils
import qualified Name
import           Outputable                  (showPpr, showSDoc, text)
import qualified GhcPlugins                  (deserializeWithData, fromSerialized)
import qualified TcIface
import qualified TcRnMonad
import qualified TcRnTypes
import qualified UniqFM
import qualified UniqSet
import qualified Var
#endif

-- Internal Modules
import           Clash.Annotations.BitRepresentation.Internal
  (DataRepr', dataReprAnnToDataRepr')
import           Clash.Annotations.Primitive
import           Clash.Annotations.BitRepresentation (DataReprAnn)
import           Clash.Debug                         (traceIf)
import           Clash.Primitives.Types              (UnresolvedPrimitive, name)
import           Clash.Primitives.Util               (decodeOrErr)
import           Clash.GHC.GHC2Core                  (qualifiedNameString')
import           Clash.Util                          (curLoc)
import qualified Clash.Util.Interpolate              as I

-- | Data structure tracking loaded binders (and their related data)
data LoadedBinders = LoadedBinders
  { LoadedBinders -> [(CoreBndr, CoreExpr)]
lbBinders :: [(CoreSyn.CoreBndr, CoreSyn.CoreExpr)]
  -- ^ Binder + expression it's binding
  , LoadedBinders -> [(CoreBndr, Int)]
lbClassOps :: [(CoreSyn.CoreBndr, Int)]
  -- ^ Type class dict projection functions
  , LoadedBinders -> [CoreBndr]
lbUnlocatable :: [CoreSyn.CoreBndr]
  -- ^ Binders with missing unfoldings
  , LoadedBinders -> [Either UnresolvedPrimitive FilePath]
lbPrims :: [Either UnresolvedPrimitive FilePath]
  -- ^ Primitives; either an primitive data structure or a path to a directory
  -- containing json files
  , LoadedBinders -> [DataRepr']
lbReprs :: [DataRepr']
  -- ^ Custom data representations
  }

mergeLoadedBinders :: [LoadedBinders] -> LoadedBinders
mergeLoadedBinders :: [LoadedBinders] -> LoadedBinders
mergeLoadedBinders [LoadedBinders]
lbs =
  LoadedBinders :: [(CoreBndr, CoreExpr)]
-> [(CoreBndr, Int)]
-> [CoreBndr]
-> [Either UnresolvedPrimitive FilePath]
-> [DataRepr']
-> LoadedBinders
LoadedBinders {
    lbBinders :: [(CoreBndr, CoreExpr)]
lbBinders=[[(CoreBndr, CoreExpr)]] -> [(CoreBndr, CoreExpr)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ((LoadedBinders -> [(CoreBndr, CoreExpr)])
-> [LoadedBinders] -> [[(CoreBndr, CoreExpr)]]
forall a b. (a -> b) -> [a] -> [b]
map LoadedBinders -> [(CoreBndr, CoreExpr)]
lbBinders [LoadedBinders]
lbs)
  , lbClassOps :: [(CoreBndr, Int)]
lbClassOps=[[(CoreBndr, Int)]] -> [(CoreBndr, Int)]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ((LoadedBinders -> [(CoreBndr, Int)])
-> [LoadedBinders] -> [[(CoreBndr, Int)]]
forall a b. (a -> b) -> [a] -> [b]
map LoadedBinders -> [(CoreBndr, Int)]
lbClassOps [LoadedBinders]
lbs)
  , lbUnlocatable :: [CoreBndr]
lbUnlocatable=[[CoreBndr]] -> [CoreBndr]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ((LoadedBinders -> [CoreBndr]) -> [LoadedBinders] -> [[CoreBndr]]
forall a b. (a -> b) -> [a] -> [b]
map LoadedBinders -> [CoreBndr]
lbUnlocatable [LoadedBinders]
lbs)
  , lbPrims :: [Either UnresolvedPrimitive FilePath]
lbPrims=[[Either UnresolvedPrimitive FilePath]]
-> [Either UnresolvedPrimitive FilePath]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ((LoadedBinders -> [Either UnresolvedPrimitive FilePath])
-> [LoadedBinders] -> [[Either UnresolvedPrimitive FilePath]]
forall a b. (a -> b) -> [a] -> [b]
map LoadedBinders -> [Either UnresolvedPrimitive FilePath]
lbPrims [LoadedBinders]
lbs)
  , lbReprs :: [DataRepr']
lbReprs=[[DataRepr']] -> [DataRepr']
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ((LoadedBinders -> [DataRepr']) -> [LoadedBinders] -> [[DataRepr']]
forall a b. (a -> b) -> [a] -> [b]
map LoadedBinders -> [DataRepr']
lbReprs [LoadedBinders]
lbs)
  }

emptyLb :: LoadedBinders
emptyLb :: LoadedBinders
emptyLb = [(CoreBndr, CoreExpr)]
-> [(CoreBndr, Int)]
-> [CoreBndr]
-> [Either UnresolvedPrimitive FilePath]
-> [DataRepr']
-> LoadedBinders
LoadedBinders [] [] [] [] []

collectLbBinders :: LoadedBinders -> [CoreSyn.CoreBndr]
collectLbBinders :: LoadedBinders -> [CoreBndr]
collectLbBinders LoadedBinders{[(CoreBndr, CoreExpr)]
lbBinders :: [(CoreBndr, CoreExpr)]
lbBinders :: LoadedBinders -> [(CoreBndr, CoreExpr)]
lbBinders, [CoreBndr]
lbUnlocatable :: [CoreBndr]
lbUnlocatable :: LoadedBinders -> [CoreBndr]
lbUnlocatable, [(CoreBndr, Int)]
lbClassOps :: [(CoreBndr, Int)]
lbClassOps :: LoadedBinders -> [(CoreBndr, Int)]
lbClassOps} =
  [[CoreBndr]] -> [CoreBndr]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [((CoreBndr, CoreExpr) -> CoreBndr)
-> [(CoreBndr, CoreExpr)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, CoreExpr)]
lbBinders, [CoreBndr]
lbUnlocatable, ((CoreBndr, Int) -> CoreBndr) -> [(CoreBndr, Int)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Int) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Int)]
lbClassOps]

runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a
runIfl :: Module -> IfL a -> m a
runIfl Module
modName IfL a
action = do
  HscEnv
hscEnv <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  let localEnv :: IfLclEnv
localEnv = Module
-> Bool
-> SDoc
-> Maybe NameShape
-> Maybe TypeEnv
-> FastStringEnv CoreBndr
-> FastStringEnv CoreBndr
-> IfLclEnv
TcRnTypes.IfLclEnv Module
modName
#if MIN_VERSION_ghc(9,0,0)
                   UnitTypes.NotBoot
#else
                   Bool
False
#endif
                   (FilePath -> SDoc
text FilePath
"runIfl") Maybe NameShape
forall a. Maybe a
Nothing Maybe TypeEnv
forall a. Maybe a
Nothing FastStringEnv CoreBndr
forall elt. UniqFM elt
UniqFM.emptyUFM FastStringEnv CoreBndr
forall elt. UniqFM elt
UniqFM.emptyUFM
  let globalEnv :: IfGblEnv
globalEnv = SDoc -> Maybe (Module, IfG TypeEnv) -> IfGblEnv
TcRnTypes.IfGblEnv (FilePath -> SDoc
text FilePath
"Clash.runIfl") Maybe (Module, IfG TypeEnv)
forall a. Maybe a
Nothing
  IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
MonadUtils.liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Char -> HscEnv -> IfGblEnv -> IfLclEnv -> IfL a -> IO a
forall gbl lcl a.
Char -> HscEnv -> gbl -> lcl -> TcRnIf gbl lcl a -> IO a
TcRnMonad.initTcRnIf Char
'r' HscEnv
hscEnv IfGblEnv
globalEnv
                        IfLclEnv
localEnv IfL a
action

loadDecl :: IfaceSyn.IfaceDecl -> TcRnTypes.IfL GHC.TyThing
loadDecl :: IfaceDecl -> IfL TyThing
loadDecl = Bool -> IfaceDecl -> IfL TyThing
TcIface.tcIfaceDecl Bool
False

loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface)
loadIface :: Module -> IfL (Maybe ModIface)
loadIface Module
foundMod = do
  MaybeErr SDoc (ModIface, FilePath)
ifaceFailM <- SDoc
-> InstalledModule
-> Module
-> Bool
-> TcRnIf IfGblEnv IfLclEnv (MaybeErr SDoc (ModIface, FilePath))
forall gbl lcl.
SDoc
-> InstalledModule
-> Module
-> Bool
-> TcRnIf gbl lcl (MaybeErr SDoc (ModIface, FilePath))
LoadIface.findAndReadIface (FilePath -> SDoc
Outputable.text FilePath
"loadIface")
#if MIN_VERSION_ghc(9,0,0)
                  (fst (Module.getModuleInstantiation foundMod)) foundMod UnitTypes.NotBoot
#else
                  ((InstalledModule, Maybe IndefModule) -> InstalledModule
forall a b. (a, b) -> a
fst (Module -> (InstalledModule, Maybe IndefModule)
Module.splitModuleInsts Module
foundMod)) Module
foundMod Bool
False
#endif
  case MaybeErr SDoc (ModIface, FilePath)
ifaceFailM of
    Maybes.Succeeded (ModIface
modInfo,FilePath
_) -> Maybe ModIface -> IfL (Maybe ModIface)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (ModIface -> Maybe ModIface
forall a. a -> Maybe a
Just ModIface
modInfo)
    Maybes.Failed SDoc
msg -> let msg' :: FilePath
msg' = [FilePath] -> FilePath
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ $(FilePath
curLoc)
                                           , FilePath
"Failed to load interface for module: "
                                           , DynFlags -> Module -> FilePath
forall a. Outputable a => DynFlags -> a -> FilePath
showPpr DynFlags
unsafeGlobalDynFlags Module
foundMod
                                           , FilePath
"\nReason: "
                                           , DynFlags -> SDoc -> FilePath
showSDoc DynFlags
unsafeGlobalDynFlags SDoc
msg
                                           ]
                         in Bool -> FilePath -> IfL (Maybe ModIface) -> IfL (Maybe ModIface)
forall a. Bool -> FilePath -> a -> a
traceIf Bool
True FilePath
msg' (Maybe ModIface -> IfL (Maybe ModIface)
forall (m :: Type -> Type) a. Monad m => a -> m a
return Maybe ModIface
forall a. Maybe a
Nothing)

loadExternalBinders
  :: GHC.GhcMonad m
  => HDL
  -> [CoreSyn.CoreBndr]
  -> m LoadedBinders
loadExternalBinders :: HDL -> [CoreBndr] -> m LoadedBinders
loadExternalBinders HDL
hdl [CoreBndr]
bndrs = do
  LoadedBinders
loaded <- [LoadedBinders] -> LoadedBinders
mergeLoadedBinders ([LoadedBinders] -> LoadedBinders)
-> m [LoadedBinders] -> m LoadedBinders
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CoreBndr -> m LoadedBinders) -> [CoreBndr] -> m [LoadedBinders]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HDL -> CoreBndr -> m LoadedBinders
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> m LoadedBinders
loadExprFromIface HDL
hdl) [CoreBndr]
bndrs
  (LoadedBinders, UniqSet CoreBndr) -> LoadedBinders
forall a b. (a, b) -> a
fst ((LoadedBinders, UniqSet CoreBndr) -> LoadedBinders)
-> m (LoadedBinders, UniqSet CoreBndr) -> m LoadedBinders
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$>
    HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
loadExternalExprs'
      HDL
hdl
      LoadedBinders
loaded
      ([CoreBndr] -> UniqSet CoreBndr
forall a. Uniquable a => [a] -> UniqSet a
UniqSet.mkUniqSet (LoadedBinders -> [CoreBndr]
collectLbBinders LoadedBinders
loaded))
      (((CoreBndr, CoreExpr) -> CoreExpr)
-> [(CoreBndr, CoreExpr)] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd (LoadedBinders -> [(CoreBndr, CoreExpr)]
lbBinders LoadedBinders
loaded))

loadExternalExprs
  :: GHC.GhcMonad m
  => HDL
  -> UniqSet.UniqSet CoreSyn.CoreBndr
  -> [CoreSyn.CoreBind]
  -> m LoadedBinders
loadExternalExprs :: HDL -> UniqSet CoreBndr -> [CoreBind] -> m LoadedBinders
loadExternalExprs HDL
hdl = LoadedBinders -> UniqSet CoreBndr -> [CoreBind] -> m LoadedBinders
forall (m :: Type -> Type).
GhcMonad m =>
LoadedBinders -> UniqSet CoreBndr -> [CoreBind] -> m LoadedBinders
go LoadedBinders
emptyLb
  where
    go :: LoadedBinders -> UniqSet CoreBndr -> [CoreBind] -> m LoadedBinders
go LoadedBinders
loaded UniqSet CoreBndr
_ [] =
      LoadedBinders -> m LoadedBinders
forall (m :: Type -> Type) a. Monad m => a -> m a
return LoadedBinders
loaded
    go LoadedBinders
loaded0 UniqSet CoreBndr
visited0 (CoreSyn.NonRec CoreBndr
_ CoreExpr
e:[CoreBind]
bs) = do
      (LoadedBinders
loaded1, UniqSet CoreBndr
visited1) <- HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
loadExternalExprs' HDL
hdl LoadedBinders
loaded0 UniqSet CoreBndr
visited0 [CoreExpr
e]
      LoadedBinders -> UniqSet CoreBndr -> [CoreBind] -> m LoadedBinders
go LoadedBinders
loaded1 UniqSet CoreBndr
visited1 [CoreBind]
bs
    go LoadedBinders
loaded0 UniqSet CoreBndr
visited0 (CoreSyn.Rec [(CoreBndr, CoreExpr)]
bs:[CoreBind]
bs') = do
      (LoadedBinders
loaded1, UniqSet CoreBndr
visited1) <- HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
loadExternalExprs' HDL
hdl LoadedBinders
loaded0 UniqSet CoreBndr
visited0 (((CoreBndr, CoreExpr) -> CoreExpr)
-> [(CoreBndr, CoreExpr)] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd [(CoreBndr, CoreExpr)]
bs)
      LoadedBinders -> UniqSet CoreBndr -> [CoreBind] -> m LoadedBinders
go LoadedBinders
loaded1 UniqSet CoreBndr
visited1 [CoreBind]
bs'

-- | Used by entry points: 'loadExternalExprs', 'loadExternalBinders'
loadExternalExprs'
  :: GHC.GhcMonad m
  => HDL
  -> LoadedBinders
  -> UniqSet.UniqSet CoreSyn.CoreBndr
  -> [CoreSyn.CoreExpr]
  -> m ( LoadedBinders, UniqSet.UniqSet CoreSyn.CoreBndr)
loadExternalExprs' :: HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
loadExternalExprs' HDL
_hdl LoadedBinders
loaded UniqSet CoreBndr
visited [] =
  (LoadedBinders, UniqSet CoreBndr)
-> m (LoadedBinders, UniqSet CoreBndr)
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LoadedBinders
loaded, UniqSet CoreBndr
visited)
loadExternalExprs' HDL
hdl LoadedBinders
loaded0 UniqSet CoreBndr
visited0 (CoreExpr
e:[CoreExpr]
es) = do
  let
    isInteresting :: CoreBndr -> Bool
isInteresting CoreBndr
v =
         CoreBndr -> Bool
Var.isId CoreBndr
v
      Bool -> Bool -> Bool
&& Bool -> Bool
not (CoreBndr
v CoreBndr -> UniqSet CoreBndr -> Bool
forall a. Uniquable a => a -> UniqSet a -> Bool
`UniqSet.elementOfUniqSet` UniqSet CoreBndr
visited0)
      Bool -> Bool -> Bool
&& Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isNothing (CoreBndr -> Maybe DataCon
Id.isDataConId_maybe CoreBndr
v)

    fvs0 :: [CoreBndr]
fvs0 = (CoreBndr -> Bool) -> CoreExpr -> [CoreBndr]
CoreFVs.exprSomeFreeVarsList CoreBndr -> Bool
isInteresting CoreExpr
e
    fvs1 :: [Either CoreBndr (CoreBndr, Class)]
fvs1 = (CoreBndr -> Either CoreBndr (CoreBndr, Class))
-> [CoreBndr] -> [Either CoreBndr (CoreBndr, Class)]
forall a b. (a -> b) -> [a] -> [b]
map (\CoreBndr
v -> Either CoreBndr (CoreBndr, Class)
-> (Class -> Either CoreBndr (CoreBndr, Class))
-> Maybe Class
-> Either CoreBndr (CoreBndr, Class)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (CoreBndr -> Either CoreBndr (CoreBndr, Class)
forall a b. a -> Either a b
Left CoreBndr
v) ((CoreBndr, Class) -> Either CoreBndr (CoreBndr, Class)
forall a b. b -> Either a b
Right ((CoreBndr, Class) -> Either CoreBndr (CoreBndr, Class))
-> (Class -> (CoreBndr, Class))
-> Class
-> Either CoreBndr (CoreBndr, Class)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (CoreBndr
v,)) (CoreBndr -> Maybe Class
Id.isClassOpId_maybe CoreBndr
v)) [CoreBndr]
fvs0
    ([CoreBndr]
fvs2, [(CoreBndr, Class)]
clsOps0) = [Either CoreBndr (CoreBndr, Class)]
-> ([CoreBndr], [(CoreBndr, Class)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either CoreBndr (CoreBndr, Class)]
fvs1
    clsOps1 :: [(CoreBndr, Int)]
clsOps1 = ((CoreBndr, Class) -> (CoreBndr, Int))
-> [(CoreBndr, Class)] -> [(CoreBndr, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Class) -> (CoreBndr, Int)
goClsOp [(CoreBndr, Class)]
clsOps0

  LoadedBinders
loaded1 <- [LoadedBinders] -> LoadedBinders
mergeLoadedBinders ([LoadedBinders] -> LoadedBinders)
-> m [LoadedBinders] -> m LoadedBinders
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (CoreBndr -> m LoadedBinders) -> [CoreBndr] -> m [LoadedBinders]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HDL -> CoreBndr -> m LoadedBinders
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> m LoadedBinders
loadExprFromIface HDL
hdl) [CoreBndr]
fvs2

  HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> LoadedBinders
-> UniqSet CoreBndr
-> [CoreExpr]
-> m (LoadedBinders, UniqSet CoreBndr)
loadExternalExprs'
    HDL
hdl
    ([LoadedBinders] -> LoadedBinders
mergeLoadedBinders [LoadedBinders
loaded0, LoadedBinders
loaded1, LoadedBinders
emptyLb{lbClassOps :: [(CoreBndr, Int)]
lbClassOps=[(CoreBndr, Int)]
clsOps1}])
    ((UniqSet CoreBndr -> [CoreBndr] -> UniqSet CoreBndr)
-> UniqSet CoreBndr -> [[CoreBndr]] -> UniqSet CoreBndr
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' UniqSet CoreBndr -> [CoreBndr] -> UniqSet CoreBndr
forall a. Uniquable a => UniqSet a -> [a] -> UniqSet a
UniqSet.addListToUniqSet UniqSet CoreBndr
visited0 [LoadedBinders -> [CoreBndr]
collectLbBinders LoadedBinders
loaded1, ((CoreBndr, Class) -> CoreBndr)
-> [(CoreBndr, Class)] -> [CoreBndr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, Class) -> CoreBndr
forall a b. (a, b) -> a
fst [(CoreBndr, Class)]
clsOps0])
    ([CoreExpr]
es [CoreExpr] -> [CoreExpr] -> [CoreExpr]
forall a. [a] -> [a] -> [a]
++ ((CoreBndr, CoreExpr) -> CoreExpr)
-> [(CoreBndr, CoreExpr)] -> [CoreExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CoreBndr, CoreExpr) -> CoreExpr
forall a b. (a, b) -> b
snd (LoadedBinders -> [(CoreBndr, CoreExpr)]
lbBinders LoadedBinders
loaded1))
 where
  goClsOp :: (Var.Var, GHC.Class) -> (CoreSyn.CoreBndr, Int)
  goClsOp :: (CoreBndr, Class) -> (CoreBndr, Int)
goClsOp (CoreBndr
v, Class
c) =
    case CoreBndr -> [CoreBndr] -> Maybe Int
forall a. Eq a => a -> [a] -> Maybe Int
elemIndex CoreBndr
v (Class -> [CoreBndr]
Class.classAllSelIds Class
c) of
      Maybe Int
Nothing -> FilePath -> (CoreBndr, Int)
forall a. HasCallStack => FilePath -> a
error [I.i|
        Internal error: couldn't find class-method

          #{showPpr DynFlags.unsafeGlobalDynFlags v}

        in class

          #{showPpr DynFlags.unsafeGlobalDynFlags c}
      |]
      Just Int
n -> (CoreBndr
v, Int
n)

loadExprFromIface
  :: GHC.GhcMonad m
  => HDL
  -> CoreSyn.CoreBndr
  -> m LoadedBinders
loadExprFromIface :: HDL -> CoreBndr -> m LoadedBinders
loadExprFromIface HDL
hdl CoreBndr
bndr = do
  let moduleM :: Maybe Module
moduleM = Name -> Maybe Module
Name.nameModule_maybe (Name -> Maybe Module) -> Name -> Maybe Module
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Name
Var.varName CoreBndr
bndr
  case Maybe Module
moduleM of
    Just Module
nameMod -> Module -> IfL LoadedBinders -> m LoadedBinders
forall (m :: Type -> Type) a. GhcMonad m => Module -> IfL a -> m a
runIfl Module
nameMod (IfL LoadedBinders -> m LoadedBinders)
-> IfL LoadedBinders -> m LoadedBinders
forall a b. (a -> b) -> a -> b
$ do
      Maybe ModIface
ifaceM <- Module -> IfL (Maybe ModIface)
loadIface Module
nameMod
      case Maybe ModIface
ifaceM of
        Maybe ModIface
Nothing ->
          LoadedBinders -> IfL LoadedBinders
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LoadedBinders
emptyLb{lbUnlocatable :: [CoreBndr]
lbUnlocatable=[CoreBndr
bndr]})
        Just ModIface
iface -> do
          let decls :: [IfaceDecl]
decls = ((Fingerprint, IfaceDecl) -> IfaceDecl)
-> [(Fingerprint, IfaceDecl)] -> [IfaceDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Fingerprint, IfaceDecl) -> IfaceDecl
forall a b. (a, b) -> b
snd (ModIface -> [IfaceDeclExts 'ModIfaceFinal]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceDeclExts phase]
GHC.mi_decls ModIface
iface)
          let nameFun :: OccName
nameFun = Name -> OccName
forall a. NamedThing a => a -> OccName
GHC.getOccName (Name -> OccName) -> Name -> OccName
forall a b. (a -> b) -> a -> b
$ CoreBndr -> Name
Var.varName CoreBndr
bndr
          let declM :: [IfaceDecl]
declM = (IfaceDecl -> Bool) -> [IfaceDecl] -> [IfaceDecl]
forall a. (a -> Bool) -> [a] -> [a]
filter ((OccName -> OccName -> Bool
forall a. Eq a => a -> a -> Bool
== OccName
nameFun) (OccName -> Bool) -> (IfaceDecl -> OccName) -> IfaceDecl -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> OccName
Name.nameOccName (Name -> OccName) -> (IfaceDecl -> Name) -> IfaceDecl -> OccName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IfaceDecl -> Name
IfaceSyn.ifName) [IfaceDecl]
decls
          [Annotation]
anns <- [IfaceAnnotation] -> IfL [Annotation]
TcIface.tcIfaceAnnotations (ModIface -> [IfaceAnnotation]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceAnnotation]
GHC.mi_anns ModIface
iface)
          [Either UnresolvedPrimitive FilePath]
primFPs   <- HDL
-> [Annotation]
-> IOEnv
     (Env IfGblEnv IfLclEnv) [Either UnresolvedPrimitive FilePath]
forall (m :: Type -> Type).
MonadIO m =>
HDL -> [Annotation] -> m [Either UnresolvedPrimitive FilePath]
loadPrimitiveAnnotations HDL
hdl [Annotation]
anns
          let reprs :: [DataRepr']
reprs  = [Annotation] -> [DataRepr']
loadCustomReprAnnotations [Annotation]
anns
              lb :: LoadedBinders
lb     = LoadedBinders
emptyLb{lbPrims :: [Either UnresolvedPrimitive FilePath]
lbPrims=[Either UnresolvedPrimitive FilePath]
primFPs, lbReprs :: [DataRepr']
lbReprs=[DataRepr']
reprs}
          case [IfaceDecl]
declM of
            [IfaceDecl
namedDecl] -> do
              TyThing
tyThing <- IfaceDecl -> IfL TyThing
loadDecl IfaceDecl
namedDecl
              case CoreBndr -> TyThing -> Either (CoreBndr, CoreExpr) CoreBndr
loadExprFromTyThing CoreBndr
bndr TyThing
tyThing of
                Left (CoreBndr, CoreExpr)
bndr1 -> LoadedBinders -> IfL LoadedBinders
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LoadedBinders
lb{lbBinders :: [(CoreBndr, CoreExpr)]
lbBinders=[(CoreBndr, CoreExpr)
bndr1]})
                Right CoreBndr
unloc -> LoadedBinders -> IfL LoadedBinders
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LoadedBinders
lb{lbUnlocatable :: [CoreBndr]
lbUnlocatable=[CoreBndr
unloc]})
            [IfaceDecl]
_ -> LoadedBinders -> IfL LoadedBinders
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LoadedBinders
lb{lbUnlocatable :: [CoreBndr]
lbUnlocatable=[CoreBndr
bndr]})
    Maybe Module
Nothing ->
      LoadedBinders -> m LoadedBinders
forall (m :: Type -> Type) a. Monad m => a -> m a
return (LoadedBinders
emptyLb{lbUnlocatable :: [CoreBndr]
lbUnlocatable=[CoreBndr
bndr]})


loadCustomReprAnnotations
  :: [Annotations.Annotation]
  -> [DataRepr']
loadCustomReprAnnotations :: [Annotation] -> [DataRepr']
loadCustomReprAnnotations [Annotation]
anns =
  [Maybe DataRepr'] -> [DataRepr']
forall a. [Maybe a] -> [a]
catMaybes ([Maybe DataRepr'] -> [DataRepr'])
-> [Maybe DataRepr'] -> [DataRepr']
forall a b. (a -> b) -> a -> b
$ ((Name, [DataReprAnn]) -> Maybe DataRepr')
-> [(Name, [DataReprAnn])] -> [Maybe DataRepr']
forall a b. (a -> b) -> [a] -> [b]
map (Name, [DataReprAnn]) -> Maybe DataRepr'
go ([(Name, [DataReprAnn])] -> [Maybe DataRepr'])
-> [(Name, [DataReprAnn])] -> [Maybe DataRepr']
forall a b. (a -> b) -> a -> b
$ [Maybe (Name, [DataReprAnn])] -> [(Name, [DataReprAnn])]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Name, [DataReprAnn])] -> [(Name, [DataReprAnn])])
-> [Maybe (Name, [DataReprAnn])] -> [(Name, [DataReprAnn])]
forall a b. (a -> b) -> a -> b
$ (Annotation -> [DataReprAnn] -> Maybe (Name, [DataReprAnn]))
-> [Annotation] -> [[DataReprAnn]] -> [Maybe (Name, [DataReprAnn])]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Annotation -> [DataReprAnn] -> Maybe (Name, [DataReprAnn])
filterNameless [Annotation]
anns [[DataReprAnn]]
reprs
    where
        env :: AnnEnv
env         = [Annotation] -> AnnEnv
Annotations.mkAnnEnv [Annotation]
anns
        deserialize :: [Word8] -> DataReprAnn
deserialize = [Word8] -> DataReprAnn
forall a. Data a => [Word8] -> a
GhcPlugins.deserializeWithData :: [Word8] -> DataReprAnn
#if MIN_VERSION_ghc(9,0,0)
        reprs       = let (mEnv,nEnv) = Annotations.deserializeAnns deserialize env
                       in ModuleEnv.moduleEnvElts mEnv <> NameEnv.nameEnvElts nEnv
#else
        reprs :: [[DataReprAnn]]
reprs       = UniqFM [DataReprAnn] -> [[DataReprAnn]]
forall elt. UniqFM elt -> [elt]
UniqFM.eltsUFM (([Word8] -> DataReprAnn) -> AnnEnv -> UniqFM [DataReprAnn]
forall a. Typeable a => ([Word8] -> a) -> AnnEnv -> UniqFM [a]
Annotations.deserializeAnns [Word8] -> DataReprAnn
deserialize AnnEnv
env)
#endif

        filterNameless
          :: Annotation
          -> [DataReprAnn]
          -> Maybe (Name.Name, [DataReprAnn])
        filterNameless :: Annotation -> [DataReprAnn] -> Maybe (Name, [DataReprAnn])
filterNameless (Annotation CoreAnnTarget
ann_target AnnPayload
_) [DataReprAnn]
reprs' =
          (,[DataReprAnn]
reprs') (Name -> (Name, [DataReprAnn]))
-> Maybe Name -> Maybe (Name, [DataReprAnn])
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> CoreAnnTarget -> Maybe Name
forall name. AnnTarget name -> Maybe name
getAnnTargetName_maybe CoreAnnTarget
ann_target

        go
          :: (Name.Name, [DataReprAnn])
          -> Maybe DataRepr'
        go :: (Name, [DataReprAnn]) -> Maybe DataRepr'
go (Name
_name, [])      = Maybe DataRepr'
forall a. Maybe a
Nothing
        go (Name
_name,  [DataReprAnn
repr]) = DataRepr' -> Maybe DataRepr'
forall a. a -> Maybe a
Just (DataRepr' -> Maybe DataRepr') -> DataRepr' -> Maybe DataRepr'
forall a b. (a -> b) -> a -> b
$ DataReprAnn -> DataRepr'
dataReprAnnToDataRepr' DataReprAnn
repr
        go (Name
name, [DataReprAnn]
reprs')   =
          FilePath -> Maybe DataRepr'
forall a. HasCallStack => FilePath -> a
error (FilePath -> Maybe DataRepr') -> FilePath -> Maybe DataRepr'
forall a b. (a -> b) -> a -> b
$ $(FilePath
curLoc) FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Multiple DataReprAnn annotations for same type: \n\n"
                            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ (DynFlags -> Name -> FilePath
forall a. Outputable a => DynFlags -> a -> FilePath
Outputable.showPpr DynFlags
DynFlags.unsafeGlobalDynFlags Name
name)
                            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"\n\nReprs:\n\n"
                            FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ [DataReprAnn] -> FilePath
forall a. Show a => a -> FilePath
show [DataReprAnn]
reprs'

loadPrimitiveAnnotations ::
  MonadIO m
  => HDL
  -> [Annotations.Annotation]
  -> m [Either UnresolvedPrimitive FilePath]
loadPrimitiveAnnotations :: HDL -> [Annotation] -> m [Either UnresolvedPrimitive FilePath]
loadPrimitiveAnnotations HDL
hdl [Annotation]
anns =
  [[Either UnresolvedPrimitive FilePath]]
-> [Either UnresolvedPrimitive FilePath]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Either UnresolvedPrimitive FilePath]]
 -> [Either UnresolvedPrimitive FilePath])
-> m [[Either UnresolvedPrimitive FilePath]]
-> m [Either UnresolvedPrimitive FilePath]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoreAnnTarget, Primitive)
 -> m [Either UnresolvedPrimitive FilePath])
-> [(CoreAnnTarget, Primitive)]
-> m [[Either UnresolvedPrimitive FilePath]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive FilePath]
forall (m :: Type -> Type).
MonadIO m =>
HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive FilePath]
getUnresolvedPrimitives HDL
hdl) [(CoreAnnTarget, Primitive)]
prims
  where
    prims :: [(CoreAnnTarget, Primitive)]
prims = (Annotation -> Maybe (CoreAnnTarget, Primitive))
-> [Annotation] -> [(CoreAnnTarget, Primitive)]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Annotation -> Maybe (CoreAnnTarget, Primitive)
filterPrim [Annotation]
anns
    filterPrim :: Annotation -> Maybe (CoreAnnTarget, Primitive)
filterPrim (Annotations.Annotation CoreAnnTarget
target AnnPayload
value) =
      (CoreAnnTarget
target,) (Primitive -> (CoreAnnTarget, Primitive))
-> Maybe Primitive -> Maybe (CoreAnnTarget, Primitive)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> AnnPayload -> Maybe Primitive
deserialize AnnPayload
value
    deserialize :: AnnPayload -> Maybe Primitive
deserialize =
      ([Word8] -> Primitive) -> AnnPayload -> Maybe Primitive
forall a. Typeable a => ([Word8] -> a) -> AnnPayload -> Maybe a
GhcPlugins.fromSerialized
        ([Word8] -> Primitive
forall a. Data a => [Word8] -> a
GhcPlugins.deserializeWithData :: [Word8] -> Primitive)

getUnresolvedPrimitives
  :: MonadIO m
  => HDL
  -> (Annotations.CoreAnnTarget, Primitive)
  -> m ([Either UnresolvedPrimitive FilePath])
getUnresolvedPrimitives :: HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive FilePath]
getUnresolvedPrimitives HDL
hdl (CoreAnnTarget, Primitive)
targetPrim =
  case (CoreAnnTarget, Primitive)
targetPrim of
    (CoreAnnTarget
_, Primitive [HDL]
hdls FilePath
fp) | HDL
hdl HDL -> [HDL] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [HDL]
hdls -> [Either UnresolvedPrimitive FilePath]
-> m [Either UnresolvedPrimitive FilePath]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [FilePath -> Either UnresolvedPrimitive FilePath
forall a b. b -> Either a b
Right FilePath
fp]

    (CoreAnnTarget
target, InlinePrimitive [HDL]
hdls FilePath
contentOrFp) | HDL
hdl HDL -> [HDL] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` [HDL]
hdls ->
      case CoreAnnTarget
target of
        -- Module annotation, can house many primitives
        Annotations.ModuleTarget Module
_ ->
          IO [Either UnresolvedPrimitive FilePath]
-> m [Either UnresolvedPrimitive FilePath]
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (FilePath -> ByteString -> [Either UnresolvedPrimitive FilePath]
forall a. (HasCallStack, FromJSON a) => FilePath -> ByteString -> a
decodeOrErr FilePath
contentOrFp (ByteString -> [Either UnresolvedPrimitive FilePath])
-> IO ByteString -> IO [Either UnresolvedPrimitive FilePath]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> FilePath -> IO ByteString
BL.readFile FilePath
contentOrFp)
        Annotations.NamedTarget Name
targetName0 ->
          let targetName1 :: FilePath
targetName1 = Text -> FilePath
Text.unpack (Name -> Text
qualifiedNameString' Name
targetName0)
              prim :: UnresolvedPrimitive
prim =
                case FilePath -> ByteString -> [UnresolvedPrimitive]
forall a. (HasCallStack, FromJSON a) => FilePath -> ByteString -> a
decodeOrErr FilePath
targetName1 (FilePath -> ByteString
BLU.fromString FilePath
contentOrFp) of
                  [] -> FilePath -> UnresolvedPrimitive
forall a. HasCallStack => FilePath -> a
error (FilePath -> UnresolvedPrimitive)
-> FilePath -> UnresolvedPrimitive
forall a b. (a -> b) -> a -> b
$ FilePath
"No annotations found for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
targetName1
                     FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" even though it had an InlinePrimitive annotation."
                  [UnresolvedPrimitive
p] -> UnresolvedPrimitive
p
                  [UnresolvedPrimitive]
_ -> FilePath -> UnresolvedPrimitive
forall a. HasCallStack => FilePath -> a
error (FilePath -> UnresolvedPrimitive)
-> FilePath -> UnresolvedPrimitive
forall a b. (a -> b) -> a -> b
$ FilePath
"Multiple primitive definitions found in "
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"InlinePrimitive annotation for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
targetName1 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". "
                    FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
"Expected a single one."

              primName :: FilePath
primName = Text -> FilePath
Text.unpack (UnresolvedPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name UnresolvedPrimitive
prim) in

          if FilePath
primName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
targetName1 then
            FilePath -> m [Either UnresolvedPrimitive FilePath]
forall a. HasCallStack => FilePath -> a
error (FilePath -> m [Either UnresolvedPrimitive FilePath])
-> FilePath -> m [Either UnresolvedPrimitive FilePath]
forall a b. (a -> b) -> a -> b
$ [FilePath] -> FilePath
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
              [ FilePath
"Function " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
targetName1 FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
" was annotated with an inline "
              , FilePath
"primitive for " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
primName FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ FilePath
". These names "
              , FilePath
"should be the same." ]
          else
            [Either UnresolvedPrimitive FilePath]
-> m [Either UnresolvedPrimitive FilePath]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [UnresolvedPrimitive -> Either UnresolvedPrimitive FilePath
forall a b. a -> Either a b
Left UnresolvedPrimitive
prim]
    (CoreAnnTarget, Primitive)
_ ->
      -- Only consider the HDL (Verilog/SystemVerilog/VHDL) annotation we're
      -- currently targeting.
      [Either UnresolvedPrimitive FilePath]
-> m [Either UnresolvedPrimitive FilePath]
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure []

loadExprFromTyThing
  :: CoreSyn.CoreBndr
  -> GHC.TyThing
  -> Either
       (CoreSyn.CoreBndr,CoreSyn.CoreExpr)  -- Located Binder
       CoreSyn.CoreBndr                     -- unlocatable Var
loadExprFromTyThing :: CoreBndr -> TyThing -> Either (CoreBndr, CoreExpr) CoreBndr
loadExprFromTyThing CoreBndr
bndr TyThing
tyThing = case TyThing
tyThing of
  GHC.AnId CoreBndr
_id | CoreBndr -> Bool
Var.isId CoreBndr
_id ->
    let _idInfo :: IdInfo
_idInfo    = HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
Var.idInfo CoreBndr
_id
        unfolding :: Unfolding
unfolding  = IdInfo -> Unfolding
IdInfo.unfoldingInfo IdInfo
_idInfo
    in case Unfolding
unfolding of
      CoreSyn.CoreUnfolding {} ->
        (CoreBndr, CoreExpr) -> Either (CoreBndr, CoreExpr) CoreBndr
forall a b. a -> Either a b
Left (CoreBndr
bndr, Unfolding -> CoreExpr
CoreSyn.unfoldingTemplate Unfolding
unfolding)
      (CoreSyn.DFunUnfolding [CoreBndr]
dfbndrs DataCon
dc [CoreExpr]
es) ->
        let dcApp :: CoreExpr
dcApp  = DataCon -> [CoreExpr] -> CoreExpr
MkCore.mkCoreConApps DataCon
dc [CoreExpr]
es
            dfExpr :: CoreExpr
dfExpr = [CoreBndr] -> CoreExpr -> CoreExpr
MkCore.mkCoreLams [CoreBndr]
dfbndrs CoreExpr
dcApp
        in (CoreBndr, CoreExpr) -> Either (CoreBndr, CoreExpr) CoreBndr
forall a b. a -> Either a b
Left (CoreBndr
bndr,CoreExpr
dfExpr)
      Unfolding
CoreSyn.NoUnfolding
#if MIN_VERSION_ghc(9,0,0)
        | Demand.isDeadEndSig $ IdInfo.strictnessInfo _idInfo
#else
        | StrictSig -> Bool
Demand.isBottomingSig (StrictSig -> Bool) -> StrictSig -> Bool
forall a b. (a -> b) -> a -> b
$ IdInfo -> StrictSig
IdInfo.strictnessInfo IdInfo
_idInfo
#endif
        -> (CoreBndr, CoreExpr) -> Either (CoreBndr, CoreExpr) CoreBndr
forall a b. a -> Either a b
Left
            ( CoreBndr
bndr
#if MIN_VERSION_ghc(8,2,2)
            , Type -> FilePath -> CoreExpr
MkCore.mkAbsentErrorApp
#else
            , MkCore.mkRuntimeErrorApp
                MkCore.aBSENT_ERROR_ID
#endif
                (CoreBndr -> Type
Var.varType CoreBndr
_id)
                (FilePath
"no_unfolding " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ DynFlags -> CoreBndr -> FilePath
forall a. Outputable a => DynFlags -> a -> FilePath
showPpr DynFlags
unsafeGlobalDynFlags CoreBndr
bndr)
            )
      Unfolding
_ -> CoreBndr -> Either (CoreBndr, CoreExpr) CoreBndr
forall a b. b -> Either a b
Right CoreBndr
bndr
  TyThing
_ -> CoreBndr -> Either (CoreBndr, CoreExpr) CoreBndr
forall a b. b -> Either a b
Right CoreBndr
bndr

#if MIN_VERSION_ghc(9,0,0)
-- | Get the 'name' of an annotation target if it exists.
getAnnTargetName_maybe :: Annotations.AnnTarget name -> Maybe name
getAnnTargetName_maybe (Annotations.NamedTarget nm) = Just nm
getAnnTargetName_maybe _                            = Nothing
#endif