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

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

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

-- External Modules
import           Control.Monad.IO.Class      (MonadIO (..))
import           Control.Monad               (forM_, join)
import           Control.Monad.State.Strict
  (StateT, gets, MonadState (get), MonadTrans (lift), execStateT)
import           Control.Monad.Trans.State.Strict (modify)
import           Control.Monad.Extra         (unlessM)
import qualified Data.ByteString.Lazy.UTF8   as BLU
import qualified Data.ByteString.Lazy        as BL
import qualified Data.Sequence               as Seq
import           Data.Sequence               (Seq)
import           Data.Either                 (partitionEithers)
#if !MIN_VERSION_base(4,20,0)
import           Data.Foldable               (foldl')
#endif
import           Data.List                   (elemIndex)
import qualified Data.Text                   as Text
import           Data.Maybe                  (isNothing, mapMaybe, catMaybes)
import           Data.Map.Strict             (Map)
import qualified Data.Map.Strict             as Map
import           Data.Set                    (Set)
import qualified Data.Set                    as Set
import           Data.Word                   (Word8)

-- GHC
#if MIN_VERSION_ghc(9,8,0)
import GHC.Types.Error (defaultOpts)
import GHC.Iface.Errors.Ppr (missingInterfaceErrorDiagnostic)
#endif
#if MIN_VERSION_ghc(9,4,0)
import           GHC.Driver.Env.KnotVars (emptyKnotVars)
#endif
#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 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 (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.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 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                  (text)
import qualified GhcPlugins                  (deserializeWithData, fromSerialized)
import qualified TcIface
import qualified TcRnMonad
import qualified TcRnTypes
import qualified UniqFM
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               (decodeOrErrJson, decodeOrErrYaml)
import           Clash.GHC.GHC2Core                  (qualifiedNameString')
import           Clash.Util                          (curLoc)
import qualified Clash.Util.Interpolate              as I
import           Clash.GHC.Util

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

type LoadedBinderT m a = StateT LoadedBinders m a

-- | Stores modules with easy binder lookup
type DeclCache = Map GHC.Module (Maybe (Map GHC.Name IfaceSyn.IfaceDecl))


-- | Collects free variables in an expression, and splits them into "normal"
-- free variables and class ops.
bndrsInExpr :: CoreSyn.CoreExpr -> ([CoreSyn.CoreBndr], [(CoreSyn.CoreBndr, Int)])
bndrsInExpr :: CoreExpr -> ([CoreBndr], [(CoreBndr, Int)])
bndrsInExpr CoreExpr
e = [Either CoreBndr (CoreBndr, Int)]
-> ([CoreBndr], [(CoreBndr, Int)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ((CoreBndr -> Either CoreBndr (CoreBndr, Int))
-> [CoreBndr] -> [Either CoreBndr (CoreBndr, Int)]
forall a b. (a -> b) -> [a] -> [b]
map CoreBndr -> Either CoreBndr (CoreBndr, Int)
go [CoreBndr]
freeVars)
 where
  freeVars :: [CoreBndr]
freeVars = InterestingVarFun -> CoreExpr -> [CoreBndr]
CoreFVs.exprSomeFreeVarsList InterestingVarFun
isInteresting CoreExpr
e
  isInteresting :: InterestingVarFun
isInteresting CoreBndr
v = InterestingVarFun
Var.isId CoreBndr
v Bool -> Bool -> Bool
&& Maybe DataCon -> Bool
forall a. Maybe a -> Bool
isNothing (CoreBndr -> Maybe DataCon
Id.isDataConId_maybe CoreBndr
v)

  go :: Var.Var -> Either Var.Id (CoreSyn.CoreBndr, Int)
  go :: CoreBndr -> Either CoreBndr (CoreBndr, Int)
go CoreBndr
v = case CoreBndr -> Maybe Class
Id.isClassOpId_maybe CoreBndr
v of
    Just Class
cls -> (CoreBndr, Int) -> Either CoreBndr (CoreBndr, Int)
forall a b. b -> Either a b
Right (CoreBndr
v, CoreBndr -> Class -> Int
goClsOp CoreBndr
v Class
cls)
    Maybe Class
Nothing -> CoreBndr -> Either CoreBndr (CoreBndr, Int)
forall a b. a -> Either a b
Left CoreBndr
v

  goClsOp :: Var.Var -> GHC.Class -> Int
  goClsOp :: CoreBndr -> Class -> 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 -> Int
forall a. HasCallStack => FilePath -> a
error [I.i|
        Internal error: couldn't find class method

          #{showPprUnsafe v}

        in class

          #{showPprUnsafe c}
      |]
      Just Int
n -> Int
n

-- | Add a binder to the appropriate fields of 'LoadedBinders', and recursively
-- load binders found in the optionally supplied expression.
addBndrM ::
  GHC.GhcMonad m =>
  HDL ->
  CoreSyn.CoreBndr ->
  Maybe CoreSyn.CoreExpr ->
  LoadedBinderT m ()
addBndrM :: HDL -> CoreBndr -> Maybe CoreExpr -> LoadedBinderT m ()
addBndrM HDL
hdl CoreBndr
bndr Maybe CoreExpr
exprM =
  case Maybe CoreExpr
exprM of
    Maybe CoreExpr
Nothing ->
      (LoadedBinders -> LoadedBinders) -> LoadedBinderT m ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify ((LoadedBinders -> LoadedBinders) -> LoadedBinderT m ())
-> (LoadedBinders -> LoadedBinders) -> LoadedBinderT m ()
forall a b. (a -> b) -> a -> b
$ \lb :: LoadedBinders
lb@LoadedBinders{Set CoreBndr
Map CoreBndr Int
Map CoreBndr CoreExpr
DeclCache
Seq (Either UnresolvedPrimitive FilePath)
Seq DataRepr'
lbCache :: DeclCache
lbReprs :: Seq DataRepr'
lbPrims :: Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: Set CoreBndr
lbClassOps :: Map CoreBndr Int
lbBinders :: Map CoreBndr CoreExpr
lbCache :: LoadedBinders -> DeclCache
lbReprs :: LoadedBinders -> Seq DataRepr'
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
..} ->
        LoadedBinders
lb{lbUnlocatable :: Set CoreBndr
lbUnlocatable=CoreBndr -> Set CoreBndr -> Set CoreBndr
forall a. Ord a => a -> Set a -> Set a
Set.insert CoreBndr
bndr Set CoreBndr
lbUnlocatable}
    Just CoreExpr
expr -> do
      -- Add current expression and its class ops
      let ([CoreBndr]
fvs, [(CoreBndr, Int)]
clsOps) = CoreExpr -> ([CoreBndr], [(CoreBndr, Int)])
bndrsInExpr CoreExpr
expr
      (LoadedBinders -> LoadedBinders) -> LoadedBinderT m ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify ((LoadedBinders -> LoadedBinders) -> LoadedBinderT m ())
-> (LoadedBinders -> LoadedBinders) -> LoadedBinderT m ()
forall a b. (a -> b) -> a -> b
$ \lb :: LoadedBinders
lb@LoadedBinders{Set CoreBndr
Map CoreBndr Int
Map CoreBndr CoreExpr
DeclCache
Seq (Either UnresolvedPrimitive FilePath)
Seq DataRepr'
lbCache :: DeclCache
lbReprs :: Seq DataRepr'
lbPrims :: Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: Set CoreBndr
lbClassOps :: Map CoreBndr Int
lbBinders :: Map CoreBndr CoreExpr
lbCache :: LoadedBinders -> DeclCache
lbReprs :: LoadedBinders -> Seq DataRepr'
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
..} ->
        LoadedBinders
lb { lbBinders :: Map CoreBndr CoreExpr
lbBinders=CoreBndr
-> CoreExpr -> Map CoreBndr CoreExpr -> Map CoreBndr CoreExpr
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert CoreBndr
bndr CoreExpr
expr Map CoreBndr CoreExpr
lbBinders
           , lbClassOps :: Map CoreBndr Int
lbClassOps=Map CoreBndr Int -> [(CoreBndr, Int)] -> Map CoreBndr Int
forall k a. Ord k => Map k a -> [(k, a)] -> Map k a
mapInsertAll Map CoreBndr Int
lbClassOps [(CoreBndr, Int)]
clsOps }

      -- Load all free variables - if not yet loaded
      [CoreBndr]
-> (CoreBndr -> LoadedBinderT m ()) -> LoadedBinderT m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [CoreBndr]
fvs ((CoreBndr -> LoadedBinderT m ()) -> LoadedBinderT m ())
-> (CoreBndr -> LoadedBinderT m ()) -> LoadedBinderT m ()
forall a b. (a -> b) -> a -> b
$ \CoreBndr
v ->
        StateT LoadedBinders m Bool
-> LoadedBinderT m () -> LoadedBinderT m ()
forall (m :: Type -> Type). Monad m => m Bool -> m () -> m ()
unlessM (CoreBndr -> StateT LoadedBinders m Bool
forall (m :: Type -> Type).
Monad m =>
CoreBndr -> LoadedBinderT m Bool
isLoadedBinderM CoreBndr
v) (HDL -> CoreBndr -> LoadedBinderT m ()
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> LoadedBinderT m ()
loadExprFromIface HDL
hdl CoreBndr
v)
 where
  -- Insert a list of keys and values into a 'Map'
  mapInsertAll :: Ord k => Map k a -> [(k, a)] -> Map k a
  mapInsertAll :: Map k a -> [(k, a)] -> Map k a
mapInsertAll = (Map k a -> (k, a) -> Map k a) -> Map k a -> [(k, a)] -> Map k a
forall (t :: Type -> Type) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map k a
m (k
k, a
v) -> k -> a -> Map k a -> Map k a
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert k
k a
v Map k a
m)


isLoadedBinderM :: Monad m => CoreSyn.CoreBndr -> LoadedBinderT m Bool
isLoadedBinderM :: CoreBndr -> LoadedBinderT m Bool
isLoadedBinderM CoreBndr
bndr = (LoadedBinders -> Bool) -> LoadedBinderT m Bool
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets ((LoadedBinders -> Bool) -> LoadedBinderT m Bool)
-> (LoadedBinders -> Bool) -> LoadedBinderT m Bool
forall a b. (a -> b) -> a -> b
$ \LoadedBinders{Set CoreBndr
Map CoreBndr Int
Map CoreBndr CoreExpr
DeclCache
Seq (Either UnresolvedPrimitive FilePath)
Seq DataRepr'
lbCache :: DeclCache
lbReprs :: Seq DataRepr'
lbPrims :: Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: Set CoreBndr
lbClassOps :: Map CoreBndr Int
lbBinders :: Map CoreBndr CoreExpr
lbCache :: LoadedBinders -> DeclCache
lbReprs :: LoadedBinders -> Seq DataRepr'
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
..} ->
     CoreBndr -> Map CoreBndr CoreExpr -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member CoreBndr
bndr Map CoreBndr CoreExpr
lbBinders
  Bool -> Bool -> Bool
|| CoreBndr -> Map CoreBndr Int -> Bool
forall k a. Ord k => k -> Map k a -> Bool
Map.member CoreBndr
bndr Map CoreBndr Int
lbClassOps
  Bool -> Bool -> Bool
|| CoreBndr -> Set CoreBndr -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member CoreBndr
bndr Set CoreBndr
lbUnlocatable

emptyLb :: LoadedBinders
emptyLb :: LoadedBinders
emptyLb = LoadedBinders :: Map CoreBndr CoreExpr
-> Map CoreBndr Int
-> Set CoreBndr
-> Seq (Either UnresolvedPrimitive FilePath)
-> Seq DataRepr'
-> DeclCache
-> LoadedBinders
LoadedBinders
  { lbBinders :: Map CoreBndr CoreExpr
lbBinders = Map CoreBndr CoreExpr
forall a. Monoid a => a
mempty
  , lbClassOps :: Map CoreBndr Int
lbClassOps = Map CoreBndr Int
forall a. Monoid a => a
mempty
  , lbUnlocatable :: Set CoreBndr
lbUnlocatable = Set CoreBndr
forall a. Monoid a => a
mempty
  , lbPrims :: Seq (Either UnresolvedPrimitive FilePath)
lbPrims = Seq (Either UnresolvedPrimitive FilePath)
forall a. Monoid a => a
mempty
  , lbReprs :: Seq DataRepr'
lbReprs = Seq DataRepr'
forall a. Monoid a => a
mempty
  , lbCache :: DeclCache
lbCache = DeclCache
forall a. Monoid a => a
mempty
  }

#if MIN_VERSION_ghc(9,0,0)
notBoot :: UnitTypes.IsBootInterface
notBoot = UnitTypes.NotBoot
#else
notBoot :: Bool
notBoot :: Bool
notBoot = Bool
False
#endif

runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a
runIfl :: Module -> IfL a -> m a
runIfl Module
modName IfL a
action = do
  let
    localEnv :: IfLclEnv
localEnv = IfLclEnv :: Module
-> Bool
-> SDoc
-> Maybe NameShape
-> Maybe TypeEnv
-> FastStringEnv CoreBndr
-> FastStringEnv CoreBndr
-> IfLclEnv
TcRnTypes.IfLclEnv
      { if_mod :: Module
TcRnTypes.if_mod = Module
modName
      , if_boot :: Bool
TcRnTypes.if_boot = Bool
notBoot
      , if_loc :: SDoc
TcRnTypes.if_loc = FilePath -> SDoc
text FilePath
"runIfl"
      , if_nsubst :: Maybe NameShape
TcRnTypes.if_nsubst = Maybe NameShape
forall a. Maybe a
Nothing
      , if_implicits_env :: Maybe TypeEnv
TcRnTypes.if_implicits_env = Maybe TypeEnv
forall a. Maybe a
Nothing
      , if_tv_env :: FastStringEnv CoreBndr
TcRnTypes.if_tv_env = FastStringEnv CoreBndr
forall elt. UniqFM elt
UniqFM.emptyUFM
      , if_id_env :: FastStringEnv CoreBndr
TcRnTypes.if_id_env = FastStringEnv CoreBndr
forall elt. UniqFM elt
UniqFM.emptyUFM
      }

    globalEnv :: IfGblEnv
globalEnv = IfGblEnv :: SDoc -> Maybe (Module, IfG TypeEnv) -> IfGblEnv
TcRnTypes.IfGblEnv
      { if_doc :: SDoc
TcRnTypes.if_doc = FilePath -> SDoc
text FilePath
"Clash.runIfl"
#if MIN_VERSION_ghc(9,4,0)
      , TcRnTypes.if_rec_types = emptyKnotVars
#else
      , if_rec_types :: Maybe (Module, IfG TypeEnv)
TcRnTypes.if_rec_types = Maybe (Module, IfG TypeEnv)
forall a. Maybe a
Nothing
#endif
      }

  HscEnv
hscEnv <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  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

#if MIN_VERSION_ghc(9,4,0)
loadIface :: GHC.HscEnv -> GHC.Module -> IO (Maybe GHC.ModIface)
loadIface env foundMod = do
#else
loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface)
loadIface :: Module -> IfL (Maybe ModIface)
loadIface Module
foundMod = do
#endif
#if MIN_VERSION_ghc(9,4,0)
  ifaceFailM <- LoadIface.findAndReadIface env (Outputable.text "loadIface")
                  (fst (Module.getModuleInstantiation foundMod)) foundMod UnitTypes.NotBoot
#elif MIN_VERSION_ghc(9,0,0)
  ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface")
                  (fst (Module.getModuleInstantiation foundMod)) foundMod UnitTypes.NotBoot
#else
  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")
                  ((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: "
                                           , Module -> FilePath
forall a. Outputable a => a -> FilePath
showPprUnsafe Module
foundMod
                                           , FilePath
"\nReason: "
#if MIN_VERSION_ghc(9,8,0)
                                           , showSDocUnsafe (missingInterfaceErrorDiagnostic defaultOpts msg)
#else
                                           , SDoc -> FilePath
showSDocUnsafe SDoc
msg
#endif
                                           ]
                         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)

-- | Given a list of top-level binders, recursively load all the binders,
-- primitives, and type classes it is using. (Exported function.)
loadExternalBinders :: GHC.GhcMonad m => HDL -> [CoreSyn.CoreBndr] -> m LoadedBinders
loadExternalBinders :: HDL -> [CoreBndr] -> m LoadedBinders
loadExternalBinders HDL
hdl [CoreBndr]
bndrs =
  (StateT LoadedBinders m () -> LoadedBinders -> m LoadedBinders)
-> LoadedBinders -> StateT LoadedBinders m () -> m LoadedBinders
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT LoadedBinders m () -> LoadedBinders -> m LoadedBinders
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m s
execStateT LoadedBinders
emptyLb (StateT LoadedBinders m () -> m LoadedBinders)
-> StateT LoadedBinders m () -> m LoadedBinders
forall a b. (a -> b) -> a -> b
$
    (CoreBndr -> StateT LoadedBinders m ())
-> [CoreBndr] -> StateT LoadedBinders m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (HDL -> CoreBndr -> StateT LoadedBinders m ()
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> LoadedBinderT m ()
loadExprFromIface HDL
hdl) [CoreBndr]
bndrs

-- Given a list of binds, recursively load all its binders, primitives, and
-- type classes it is using. (Exported function.)
loadExternalExprs :: GHC.GhcMonad m => HDL -> [CoreSyn.CoreBind] -> m LoadedBinders
loadExternalExprs :: HDL -> [CoreBind] -> m LoadedBinders
loadExternalExprs HDL
hdl [CoreBind]
binds0 =
  (StateT LoadedBinders m () -> LoadedBinders -> m LoadedBinders)
-> LoadedBinders -> StateT LoadedBinders m () -> m LoadedBinders
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT LoadedBinders m () -> LoadedBinders -> m LoadedBinders
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m s
execStateT LoadedBinders
initLb (StateT LoadedBinders m () -> m LoadedBinders)
-> StateT LoadedBinders m () -> m LoadedBinders
forall a b. (a -> b) -> a -> b
$
    ((CoreBndr, CoreExpr) -> StateT LoadedBinders m ())
-> [(CoreBndr, CoreExpr)] -> StateT LoadedBinders m ()
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(CoreBndr
b, CoreExpr
e) -> HDL -> CoreBndr -> Maybe CoreExpr -> StateT LoadedBinders m ()
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> Maybe CoreExpr -> LoadedBinderT m ()
addBndrM HDL
hdl CoreBndr
b (CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just CoreExpr
e)) [(CoreBndr, CoreExpr)]
binds1
 where
  -- 'lbBinders' is preinitialized with all binders in given binds, as the given
  -- binders can't be loaded from precompiled modules
  initLb :: LoadedBinders
initLb = LoadedBinders
emptyLb{lbBinders :: Map CoreBndr CoreExpr
lbBinders=[(CoreBndr, CoreExpr)] -> Map CoreBndr CoreExpr
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList [(CoreBndr, CoreExpr)]
binds1}
  binds1 :: [(CoreBndr, CoreExpr)]
binds1 = [CoreBind] -> [(CoreBndr, CoreExpr)]
forall b. [Bind b] -> [(b, Expr b)]
CoreSyn.flattenBinds [CoreBind]
binds0

-- | Try to fetch a IfaceDecl from a 'DeclCache'. If a module has not been loaded
-- before, load it using GHC. Additionally, add annotations mentioned in the
-- module to 'LoadedBinders'.
getIfaceDeclM ::
  forall m.
  GHC.GhcMonad m =>
  HDL ->
  -- | Binder to load
  CoreSyn.CoreBndr ->
  -- | Declaration, if found
  LoadedBinderT m (Maybe (GHC.Module, IfaceSyn.IfaceDecl))
getIfaceDeclM :: HDL -> CoreBndr -> LoadedBinderT m (Maybe (Module, IfaceDecl))
getIfaceDeclM HDL
hdl CoreBndr
bndr = do
  let modM :: Maybe Module
modM = Name -> Maybe Module
Name.nameModule_maybe Name
bndrName
  Maybe (Maybe (Module, IfaceDecl)) -> Maybe (Module, IfaceDecl)
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (Module, IfaceDecl)) -> Maybe (Module, IfaceDecl))
-> StateT LoadedBinders m (Maybe (Maybe (Module, IfaceDecl)))
-> LoadedBinderT m (Maybe (Module, IfaceDecl))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Module -> LoadedBinderT m (Maybe (Module, IfaceDecl)))
-> Maybe Module
-> StateT LoadedBinders m (Maybe (Maybe (Module, IfaceDecl)))
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Module -> LoadedBinderT m (Maybe (Module, IfaceDecl))
go Maybe Module
modM
 where
  bndrName :: Name
bndrName = CoreBndr -> Name
Var.varName CoreBndr
bndr

  go :: GHC.Module -> LoadedBinderT m (Maybe (GHC.Module, IfaceSyn.IfaceDecl))
  go :: Module -> LoadedBinderT m (Maybe (Module, IfaceDecl))
go Module
nameMod = do
    LoadedBinders{DeclCache
lbCache :: DeclCache
lbCache :: LoadedBinders -> DeclCache
lbCache} <- StateT LoadedBinders m LoadedBinders
forall s (m :: Type -> Type). MonadState s m => m s
get
    case Module -> DeclCache -> Maybe (Maybe (Map Name IfaceDecl))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Module
nameMod DeclCache
lbCache of
      Maybe (Maybe (Map Name IfaceDecl))
Nothing -> do
        -- Not loaded before
#if MIN_VERSION_ghc(9,4,0)
        env <- lift GHC.getSession
        ifaceM <- lift (liftIO (loadIface env nameMod))
#else
        Maybe ModIface
ifaceM <- m (Maybe ModIface) -> StateT LoadedBinders m (Maybe ModIface)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Module -> IfL (Maybe ModIface) -> m (Maybe ModIface)
forall (m :: Type -> Type) a. GhcMonad m => Module -> IfL a -> m a
runIfl Module
nameMod (Module -> IfL (Maybe ModIface)
loadIface Module
nameMod))
#endif
        case Maybe ModIface
ifaceM of
          Just ModIface
iface -> do
            -- Add binder : decl map to cache
            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)
              names :: [Name]
names = (IfaceDecl -> Name) -> [IfaceDecl] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map IfaceDecl -> Name
IfaceSyn.ifName [IfaceDecl]
decls
            let declMap :: Maybe (Map Name IfaceDecl)
declMap = Map Name IfaceDecl -> Maybe (Map Name IfaceDecl)
forall a. a -> Maybe a
Just ([(Name, IfaceDecl)] -> Map Name IfaceDecl
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([Name] -> [IfaceDecl] -> [(Name, IfaceDecl)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Name]
names [IfaceDecl]
decls))
            (LoadedBinders -> LoadedBinders) -> StateT LoadedBinders m ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify (\LoadedBinders
lb -> LoadedBinders
lb{lbCache :: DeclCache
lbCache=Module -> Maybe (Map Name IfaceDecl) -> DeclCache -> DeclCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Module
nameMod Maybe (Map Name IfaceDecl)
declMap DeclCache
lbCache})

            -- Load annotations and add them to state
            HDL -> Module -> ModIface -> StateT LoadedBinders m ()
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> Module -> ModIface -> StateT LoadedBinders m ()
loadAnnotationsM HDL
hdl Module
nameMod ModIface
iface
          Maybe ModIface
Nothing ->
            -- XXX: 'runIfl' should probably error hard if this happens?
            (LoadedBinders -> LoadedBinders) -> StateT LoadedBinders m ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify (\LoadedBinders
lb -> LoadedBinders
lb{lbCache :: DeclCache
lbCache=Module -> Maybe (Map Name IfaceDecl) -> DeclCache -> DeclCache
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert Module
nameMod Maybe (Map Name IfaceDecl)
forall a. Maybe a
Nothing DeclCache
lbCache})

        -- Update cache and try again
        Module -> LoadedBinderT m (Maybe (Module, IfaceDecl))
go Module
nameMod

      Just Maybe (Map Name IfaceDecl)
Nothing ->
        -- Loaded before, but couldn't find decl
        Maybe (Module, IfaceDecl)
-> LoadedBinderT m (Maybe (Module, IfaceDecl))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (Module, IfaceDecl)
forall a. Maybe a
Nothing
      Just (Just Map Name IfaceDecl
declMap) ->
        -- Loaded before, decl found
        Maybe (Module, IfaceDecl)
-> LoadedBinderT m (Maybe (Module, IfaceDecl))
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((Module
nameMod,) (IfaceDecl -> (Module, IfaceDecl))
-> Maybe IfaceDecl -> Maybe (Module, IfaceDecl)
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> Map Name IfaceDecl -> Maybe IfaceDecl
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Name
bndrName Map Name IfaceDecl
declMap)

loadAnnotationsM ::
  GHC.GhcMonad m =>
  HDL ->
  GHC.Module ->
  GHC.ModIface ->
  StateT LoadedBinders m ()
loadAnnotationsM :: HDL -> Module -> ModIface -> StateT LoadedBinders m ()
loadAnnotationsM HDL
hdl Module
modName ModIface
iface = do
  [Annotation]
anns <- m [Annotation] -> StateT LoadedBinders m [Annotation]
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Module -> IfL [Annotation] -> m [Annotation]
forall (m :: Type -> Type) a. GhcMonad m => Module -> IfL a -> m a
runIfl Module
modName ([IfaceAnnotation] -> IfL [Annotation]
TcIface.tcIfaceAnnotations (ModIface -> [IfaceAnnotation]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceAnnotation]
GHC.mi_anns ModIface
iface)))
  [Either UnresolvedPrimitive FilePath]
primFPs <- HDL
-> [Annotation]
-> StateT LoadedBinders m [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
  (LoadedBinders -> LoadedBinders) -> StateT LoadedBinders m ()
forall (m :: Type -> Type) s. Monad m => (s -> s) -> StateT s m ()
modify ((LoadedBinders -> LoadedBinders) -> StateT LoadedBinders m ())
-> (LoadedBinders -> LoadedBinders) -> StateT LoadedBinders m ()
forall a b. (a -> b) -> a -> b
$ \lb :: LoadedBinders
lb@LoadedBinders{Set CoreBndr
Map CoreBndr Int
Map CoreBndr CoreExpr
DeclCache
Seq (Either UnresolvedPrimitive FilePath)
Seq DataRepr'
lbCache :: DeclCache
lbReprs :: Seq DataRepr'
lbPrims :: Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: Set CoreBndr
lbClassOps :: Map CoreBndr Int
lbBinders :: Map CoreBndr CoreExpr
lbCache :: LoadedBinders -> DeclCache
lbReprs :: LoadedBinders -> Seq DataRepr'
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive FilePath)
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
..} -> LoadedBinders
lb
    { lbPrims :: Seq (Either UnresolvedPrimitive FilePath)
lbPrims = Seq (Either UnresolvedPrimitive FilePath)
lbPrims Seq (Either UnresolvedPrimitive FilePath)
-> Seq (Either UnresolvedPrimitive FilePath)
-> Seq (Either UnresolvedPrimitive FilePath)
forall a. Semigroup a => a -> a -> a
<> [Either UnresolvedPrimitive FilePath]
-> Seq (Either UnresolvedPrimitive FilePath)
forall a. [a] -> Seq a
Seq.fromList [Either UnresolvedPrimitive FilePath]
primFPs
    , lbReprs :: Seq DataRepr'
lbReprs = Seq DataRepr'
lbReprs Seq DataRepr' -> Seq DataRepr' -> Seq DataRepr'
forall a. Semigroup a => a -> a -> a
<> [DataRepr'] -> Seq DataRepr'
forall a. [a] -> Seq a
Seq.fromList [DataRepr']
reprs
    }

loadExprFromIface ::
  GHC.GhcMonad m =>
  HDL ->
  CoreSyn.CoreBndr ->
  LoadedBinderT m ()
loadExprFromIface :: HDL -> CoreBndr -> LoadedBinderT m ()
loadExprFromIface HDL
hdl CoreBndr
bndr = do
  Maybe (Module, IfaceDecl)
namedDeclM <- HDL -> CoreBndr -> LoadedBinderT m (Maybe (Module, IfaceDecl))
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> LoadedBinderT m (Maybe (Module, IfaceDecl))
getIfaceDeclM HDL
hdl CoreBndr
bndr
  case Maybe (Module, IfaceDecl)
namedDeclM of
    Maybe (Module, IfaceDecl)
Nothing -> HDL -> CoreBndr -> Maybe CoreExpr -> LoadedBinderT m ()
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> Maybe CoreExpr -> LoadedBinderT m ()
addBndrM HDL
hdl CoreBndr
bndr Maybe CoreExpr
forall a. Maybe a
Nothing
    Just (Module
nameMod, IfaceDecl
namedDecl) -> do
      TyThing
tyThing <- m TyThing -> StateT LoadedBinders m TyThing
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Module -> IfL TyThing -> m TyThing
forall (m :: Type -> Type) a. GhcMonad m => Module -> IfL a -> m a
runIfl Module
nameMod (IfaceDecl -> IfL TyThing
loadDecl IfaceDecl
namedDecl))
      HDL -> CoreBndr -> Maybe CoreExpr -> LoadedBinderT m ()
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> Maybe CoreExpr -> LoadedBinderT m ()
addBndrM HDL
hdl CoreBndr
bndr (CoreBndr -> TyThing -> Maybe CoreExpr
loadExprFromTyThing CoreBndr
bndr TyThing
tyThing)


loadCustomReprAnnotations :: [Annotations.Annotation] -> [DataRepr']
loadCustomReprAnnotations :: [Annotation] -> [DataRepr']
loadCustomReprAnnotations [Annotation]
anns =
  ((Name, [DataReprAnn]) -> Maybe DataRepr')
-> [(Name, [DataReprAnn])] -> [DataRepr']
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (Name, [DataReprAnn]) -> Maybe DataRepr'
go ([(Name, [DataReprAnn])] -> [DataRepr'])
-> [(Name, [DataReprAnn])] -> [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,4,0)
  (mEnv, nEnv) = Annotations.deserializeAnns deserialize env
  reprs = ModuleEnv.moduleEnvElts mEnv <> NameEnv.nonDetNameEnvElts nEnv
#elif MIN_VERSION_ghc(9,0,0)
  (mEnv, nEnv) = Annotations.deserializeAnns deserialize env
  reprs = 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 [I.i|
      Multiple DataReprAnn annotations for same type:

        #{showPprUnsafe name}

      Reprs:

        #{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
target, Primitive
prim) | HDL
hdl HDL -> [HDL] -> Bool
forall (t :: Type -> Type) a.
(Foldable t, Eq a) =>
a -> t a -> Bool
`elem` Primitive -> [HDL]
primHdls Primitive
prim =
  case Primitive
prim of
    Primitive [HDL]
_ FilePath
fp -> [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]

    InlineYamlPrimitive [HDL]
_ FilePath
contentOrFp ->
      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
decodeOrErrYaml 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)
              primOrErr :: UnresolvedPrimitive
primOrErr = FilePath -> ByteString -> UnresolvedPrimitive
forall a. (HasCallStack, FromJSON a) => FilePath -> ByteString -> a
decodeOrErrYaml FilePath
targetName1 (FilePath -> ByteString
BLU.fromString FilePath
contentOrFp)
              primName :: FilePath
primName = Text -> FilePath
Text.unpack (UnresolvedPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name UnresolvedPrimitive
primOrErr) in

          if FilePath
primName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
targetName1
          then FilePath -> FilePath -> m [Either UnresolvedPrimitive FilePath]
forall a. FilePath -> FilePath -> a
inlineNameError FilePath
targetName1 FilePath
primName
          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
primOrErr]

    InlinePrimitive [HDL]
_ FilePath
contentOrFp ->
      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
decodeOrErrJson 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)
              primOrErr :: UnresolvedPrimitive
primOrErr =
                case FilePath -> ByteString -> [UnresolvedPrimitive]
forall a. (HasCallStack, FromJSON a) => FilePath -> ByteString -> a
decodeOrErrJson 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
primOrErr) in

          if FilePath
primName FilePath -> FilePath -> Bool
forall a. Eq a => a -> a -> Bool
/= FilePath
targetName1
          then FilePath -> FilePath -> m [Either UnresolvedPrimitive FilePath]
forall a. FilePath -> FilePath -> a
inlineNameError FilePath
targetName1 FilePath
primName
          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
primOrErr]
 where
  inlineNameError :: FilePath -> FilePath -> a
inlineNameError FilePath
targetName FilePath
primName =
    FilePath -> a
forall a. HasCallStack => FilePath -> a
error (FilePath -> a) -> FilePath -> a
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
targetName 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." ]

  primHdls :: Primitive -> [HDL]
primHdls = \case
    Primitive [HDL]
hdls FilePath
_ -> [HDL]
hdls
    InlinePrimitive [HDL]
hdls FilePath
_ -> [HDL]
hdls
    InlineYamlPrimitive [HDL]
hdls FilePath
_ -> [HDL]
hdls

getUnresolvedPrimitives HDL
_ (CoreAnnTarget, Primitive)
_  = [Either UnresolvedPrimitive FilePath]
-> m [Either UnresolvedPrimitive FilePath]
forall (m :: Type -> Type) a. Monad m => a -> m a
return []

loadExprFromTyThing :: CoreSyn.CoreBndr -> GHC.TyThing -> Maybe CoreSyn.CoreExpr
loadExprFromTyThing :: CoreBndr -> TyThing -> Maybe CoreExpr
loadExprFromTyThing CoreBndr
bndr TyThing
tyThing = case TyThing
tyThing of
  GHC.AnId CoreBndr
_id | InterestingVarFun
Var.isId CoreBndr
_id ->
    let _idInfo :: IdInfo
_idInfo    = HasDebugCallStack => CoreBndr -> IdInfo
CoreBndr -> IdInfo
Var.idInfo CoreBndr
_id
#if MIN_VERSION_ghc(9,4,0)
        unfolding  = IdInfo.realUnfoldingInfo _idInfo
#else
        unfolding :: Unfolding
unfolding  = IdInfo -> Unfolding
IdInfo.unfoldingInfo IdInfo
_idInfo
#endif
    in case Unfolding
unfolding of
      CoreSyn.CoreUnfolding {} ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Unfolding -> CoreExpr
CoreSyn.unfoldingTemplate Unfolding
unfolding)
      CoreSyn.DFunUnfolding [CoreBndr]
dfbndrs DataCon
dc [CoreExpr]
es ->
        CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just ([CoreBndr] -> CoreExpr -> CoreExpr
MkCore.mkCoreLams [CoreBndr]
dfbndrs (DataCon -> [CoreExpr] -> CoreExpr
MkCore.mkCoreConApps DataCon
dc [CoreExpr]
es))
      Unfolding
CoreSyn.NoUnfolding
#if MIN_VERSION_ghc(9,4,0)
        | Demand.isDeadEndSig $ IdInfo.dmdSigInfo _idInfo
#elif 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
        -> do
          let noUnfoldingErr :: FilePath
noUnfoldingErr = FilePath
"no_unfolding " FilePath -> FilePath -> FilePath
forall a. [a] -> [a] -> [a]
++ CoreBndr -> FilePath
forall a. Outputable a => a -> FilePath
showPprUnsafe CoreBndr
bndr
          CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Type -> FilePath -> CoreExpr
MkCore.mkAbsentErrorApp (CoreBndr -> Type
Var.varType CoreBndr
_id) FilePath
noUnfoldingErr)
      Unfolding
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing
  TyThing
_ -> Maybe CoreExpr
forall a. Maybe a
Nothing

#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