{-|
  Copyright   :  (C) 2013-2016, University of Twente,
                     2016-2017, Myrtle Software Ltd
                     2022,      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)
import           Data.Foldable               (foldl')
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 String)
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 -> String -> Int
forall a. HasCallStack => String -> 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 :: forall (m :: Type -> Type).
GhcMonad m =>
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
DeclCache
Map CoreBndr Int
Map CoreBndr CoreExpr
Seq (Either UnresolvedPrimitive String)
Seq DataRepr'
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive String)
lbReprs :: LoadedBinders -> Seq DataRepr'
lbCache :: LoadedBinders -> DeclCache
lbBinders :: Map CoreBndr CoreExpr
lbClassOps :: Map CoreBndr Int
lbUnlocatable :: Set CoreBndr
lbPrims :: Seq (Either UnresolvedPrimitive String)
lbReprs :: Seq DataRepr'
lbCache :: DeclCache
..} ->
        LoadedBinders
lb{lbUnlocatable=Set.insert bndr 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
DeclCache
Map CoreBndr Int
Map CoreBndr CoreExpr
Seq (Either UnresolvedPrimitive String)
Seq DataRepr'
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive String)
lbReprs :: LoadedBinders -> Seq DataRepr'
lbCache :: LoadedBinders -> DeclCache
lbBinders :: Map CoreBndr CoreExpr
lbClassOps :: Map CoreBndr Int
lbUnlocatable :: Set CoreBndr
lbPrims :: Seq (Either UnresolvedPrimitive String)
lbReprs :: Seq DataRepr'
lbCache :: DeclCache
..} ->
        LoadedBinders
lb { lbBinders=Map.insert bndr expr lbBinders
           , lbClassOps=mapInsertAll lbClassOps 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 :: forall k a. Ord k => 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 b a. (b -> a -> b) -> b -> [a] -> b
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 :: forall (m :: Type -> Type).
Monad m =>
CoreBndr -> LoadedBinderT m Bool
isLoadedBinderM CoreBndr
bndr = (LoadedBinders -> Bool) -> StateT LoadedBinders m Bool
forall s (m :: Type -> Type) a. MonadState s m => (s -> a) -> m a
gets ((LoadedBinders -> Bool) -> StateT LoadedBinders m Bool)
-> (LoadedBinders -> Bool) -> StateT LoadedBinders m Bool
forall a b. (a -> b) -> a -> b
$ \LoadedBinders{Set CoreBndr
DeclCache
Map CoreBndr Int
Map CoreBndr CoreExpr
Seq (Either UnresolvedPrimitive String)
Seq DataRepr'
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive String)
lbReprs :: LoadedBinders -> Seq DataRepr'
lbCache :: LoadedBinders -> DeclCache
lbBinders :: Map CoreBndr CoreExpr
lbClassOps :: Map CoreBndr Int
lbUnlocatable :: Set CoreBndr
lbPrims :: Seq (Either UnresolvedPrimitive String)
lbReprs :: Seq DataRepr'
lbCache :: DeclCache
..} ->
     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
  { 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 String)
lbPrims = Seq (Either UnresolvedPrimitive String)
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 :: IsBootInterface
notBoot = IsBootInterface
UnitTypes.NotBoot
#else
notBoot :: Bool
notBoot = False
#endif

runIfl :: GHC.GhcMonad m => GHC.Module -> TcRnTypes.IfL a -> m a
runIfl :: forall (m :: Type -> Type) a.
GhcMonad m =>
GenModule Unit -> IfL a -> m a
runIfl GenModule Unit
modName IfL a
action = do
  let
    localEnv :: IfLclEnv
localEnv = TcRnTypes.IfLclEnv
      { if_mod :: GenModule Unit
TcRnTypes.if_mod = GenModule Unit
modName
      , if_boot :: IsBootInterface
TcRnTypes.if_boot = IsBootInterface
notBoot
      , if_loc :: SDoc
TcRnTypes.if_loc = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"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 key elt. UniqFM key elt
UniqFM.emptyUFM
      , if_id_env :: FastStringEnv CoreBndr
TcRnTypes.if_id_env = FastStringEnv CoreBndr
forall key elt. UniqFM key elt
UniqFM.emptyUFM
      }

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

  HscEnv
hscEnv <- m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
  IO a -> m a
forall a. 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 :: HscEnv -> GenModule Unit -> IO (Maybe ModIface)
loadIface HscEnv
env GenModule Unit
foundMod = do
#else
loadIface :: GHC.Module -> TcRnTypes.IfL (Maybe GHC.ModIface)
loadIface foundMod = do
#endif
#if MIN_VERSION_ghc(9,4,0)
  MaybeErr SDoc (ModIface, String)
ifaceFailM <- HscEnv
-> SDoc
-> InstalledModule
-> GenModule Unit
-> IsBootInterface
-> IO (MaybeErr SDoc (ModIface, String))
LoadIface.findAndReadIface HscEnv
env (String -> SDoc
forall doc. IsLine doc => String -> doc
Outputable.text String
"loadIface")
                  ((InstalledModule, Maybe InstantiatedModule) -> InstalledModule
forall a b. (a, b) -> a
fst (GenModule Unit -> (InstalledModule, Maybe InstantiatedModule)
Module.getModuleInstantiation GenModule Unit
foundMod)) GenModule Unit
foundMod IsBootInterface
UnitTypes.NotBoot
#elif MIN_VERSION_ghc(9,0,0)
  ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface")
                  (fst (Module.getModuleInstantiation foundMod)) foundMod UnitTypes.NotBoot
#else
  ifaceFailM <- LoadIface.findAndReadIface (Outputable.text "loadIface")
                  (fst (Module.splitModuleInsts foundMod)) foundMod False
#endif
  case MaybeErr SDoc (ModIface, String)
ifaceFailM of
    Maybes.Succeeded (ModIface
modInfo,String
_) -> Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
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' :: String
msg' = [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat [ $(curLoc)
                                           , String
"Failed to load interface for module: "
                                           , GenModule Unit -> String
forall a. Outputable a => a -> String
showPprUnsafe GenModule Unit
foundMod
                                           , String
"\nReason: "
#if MIN_VERSION_ghc(9,8,0)
                                           , showSDocUnsafe (missingInterfaceErrorDiagnostic defaultOpts msg)
#else
                                           , SDoc -> String
showSDocUnsafe SDoc
msg
#endif
                                           ]
                         in Bool -> String -> IO (Maybe ModIface) -> IO (Maybe ModIface)
forall a. Bool -> String -> a -> a
traceIf Bool
True String
msg' (Maybe ModIface -> IO (Maybe ModIface)
forall a. a -> IO a
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 :: forall (m :: Type -> Type).
GhcMonad m =>
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 :: forall (m :: Type -> Type).
GhcMonad m =>
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.fromList 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 :: forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> CoreBndr -> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
getIfaceDeclM HDL
hdl CoreBndr
bndr = do
  let modM :: Maybe (GenModule Unit)
modM = Name -> Maybe (GenModule Unit)
Name.nameModule_maybe Name
bndrName
  Maybe (Maybe (GenModule Unit, IfaceDecl))
-> Maybe (GenModule Unit, IfaceDecl)
forall (m :: Type -> Type) a. Monad m => m (m a) -> m a
join (Maybe (Maybe (GenModule Unit, IfaceDecl))
 -> Maybe (GenModule Unit, IfaceDecl))
-> StateT
     LoadedBinders m (Maybe (Maybe (GenModule Unit, IfaceDecl)))
-> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (GenModule Unit
 -> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl)))
-> Maybe (GenModule Unit)
-> StateT
     LoadedBinders m (Maybe (Maybe (GenModule Unit, IfaceDecl)))
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> Maybe a -> m (Maybe b)
mapM GenModule Unit
-> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
go Maybe (GenModule Unit)
modM
 where
  bndrName :: Name
bndrName = CoreBndr -> Name
Var.varName CoreBndr
bndr

  go :: GHC.Module -> LoadedBinderT m (Maybe (GHC.Module, IfaceSyn.IfaceDecl))
  go :: GenModule Unit
-> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
go GenModule Unit
nameMod = do
    LoadedBinders{DeclCache
lbCache :: LoadedBinders -> DeclCache
lbCache :: DeclCache
lbCache} <- StateT LoadedBinders m LoadedBinders
forall s (m :: Type -> Type). MonadState s m => m s
get
    case GenModule Unit -> DeclCache -> Maybe (Maybe (Map Name IfaceDecl))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup GenModule Unit
nameMod DeclCache
lbCache of
      Maybe (Maybe (Map Name IfaceDecl))
Nothing -> do
        -- Not loaded before
#if MIN_VERSION_ghc(9,4,0)
        HscEnv
env <- m HscEnv -> StateT LoadedBinders m HscEnv
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT LoadedBinders m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m HscEnv
forall (m :: Type -> Type). GhcMonad m => m HscEnv
GHC.getSession
        Maybe ModIface
ifaceM <- m (Maybe ModIface) -> StateT LoadedBinders m (Maybe ModIface)
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT LoadedBinders m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Maybe ModIface) -> m (Maybe ModIface)
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (HscEnv -> GenModule Unit -> IO (Maybe ModIface)
loadIface HscEnv
env GenModule Unit
nameMod))
#else
        ifaceM <- lift (runIfl nameMod (loadIface 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=Map.insert nameMod declMap lbCache})

            -- Load annotations and add them to state
            HDL -> GenModule Unit -> ModIface -> StateT LoadedBinders m ()
forall (m :: Type -> Type).
GhcMonad m =>
HDL -> GenModule Unit -> ModIface -> StateT LoadedBinders m ()
loadAnnotationsM HDL
hdl GenModule Unit
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=Map.insert nameMod Nothing lbCache})

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

      Just Maybe (Map Name IfaceDecl)
Nothing ->
        -- Loaded before, but couldn't find decl
        Maybe (GenModule Unit, IfaceDecl)
-> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
forall a. a -> StateT LoadedBinders m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Maybe (GenModule Unit, IfaceDecl)
forall a. Maybe a
Nothing
      Just (Just Map Name IfaceDecl
declMap) ->
        -- Loaded before, decl found
        Maybe (GenModule Unit, IfaceDecl)
-> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
forall a. a -> StateT LoadedBinders m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure ((GenModule Unit
nameMod,) (IfaceDecl -> (GenModule Unit, IfaceDecl))
-> Maybe IfaceDecl -> Maybe (GenModule Unit, 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 :: forall (m :: Type -> Type).
GhcMonad m =>
HDL -> GenModule Unit -> ModIface -> StateT LoadedBinders m ()
loadAnnotationsM HDL
hdl GenModule Unit
modName ModIface
iface = do
  [Annotation]
anns <- m [Annotation] -> StateT LoadedBinders m [Annotation]
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT LoadedBinders m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GenModule Unit -> IfL [Annotation] -> m [Annotation]
forall (m :: Type -> Type) a.
GhcMonad m =>
GenModule Unit -> IfL a -> m a
runIfl GenModule Unit
modName ([IfaceAnnotation] -> IfL [Annotation]
TcIface.tcIfaceAnnotations (ModIface -> [IfaceAnnotation]
forall (phase :: ModIfacePhase).
ModIface_ phase -> [IfaceAnnotation]
GHC.mi_anns ModIface
iface)))
  [Either UnresolvedPrimitive String]
primFPs <- HDL
-> [Annotation]
-> StateT LoadedBinders m [Either UnresolvedPrimitive String]
forall (m :: Type -> Type).
MonadIO m =>
HDL -> [Annotation] -> m [Either UnresolvedPrimitive String]
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
DeclCache
Map CoreBndr Int
Map CoreBndr CoreExpr
Seq (Either UnresolvedPrimitive String)
Seq DataRepr'
lbBinders :: LoadedBinders -> Map CoreBndr CoreExpr
lbClassOps :: LoadedBinders -> Map CoreBndr Int
lbUnlocatable :: LoadedBinders -> Set CoreBndr
lbPrims :: LoadedBinders -> Seq (Either UnresolvedPrimitive String)
lbReprs :: LoadedBinders -> Seq DataRepr'
lbCache :: LoadedBinders -> DeclCache
lbBinders :: Map CoreBndr CoreExpr
lbClassOps :: Map CoreBndr Int
lbUnlocatable :: Set CoreBndr
lbPrims :: Seq (Either UnresolvedPrimitive String)
lbReprs :: Seq DataRepr'
lbCache :: DeclCache
..} -> LoadedBinders
lb
    { lbPrims = lbPrims <> Seq.fromList primFPs
    , lbReprs = lbReprs <> Seq.fromList reprs
    }

loadExprFromIface ::
  GHC.GhcMonad m =>
  HDL ->
  CoreSyn.CoreBndr ->
  LoadedBinderT m ()
loadExprFromIface :: forall (m :: Type -> Type).
GhcMonad m =>
HDL -> CoreBndr -> LoadedBinderT m ()
loadExprFromIface HDL
hdl CoreBndr
bndr = do
  Maybe (GenModule Unit, IfaceDecl)
namedDeclM <- HDL
-> CoreBndr -> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
forall (m :: Type -> Type).
GhcMonad m =>
HDL
-> CoreBndr -> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
getIfaceDeclM HDL
hdl CoreBndr
bndr
  case Maybe (GenModule Unit, IfaceDecl)
namedDeclM of
    Maybe (GenModule Unit, 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 (GenModule Unit
nameMod, IfaceDecl
namedDecl) -> do
      TyThing
tyThing <- m TyThing -> StateT LoadedBinders m TyThing
forall (m :: Type -> Type) a.
Monad m =>
m a -> StateT LoadedBinders m a
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (GenModule Unit -> IfL TyThing -> m TyThing
forall (m :: Type -> Type) a.
GhcMonad m =>
GenModule Unit -> IfL a -> m a
runIfl GenModule Unit
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)
  (ModuleEnv [DataReprAnn]
mEnv, NameEnv [DataReprAnn]
nEnv) = ([Word8] -> DataReprAnn)
-> AnnEnv -> (ModuleEnv [DataReprAnn], NameEnv [DataReprAnn])
forall a.
Typeable a =>
([Word8] -> a) -> AnnEnv -> (ModuleEnv [a], NameEnv [a])
Annotations.deserializeAnns [Word8] -> DataReprAnn
deserialize AnnEnv
env
  reprs :: [[DataReprAnn]]
reprs = ModuleEnv [DataReprAnn] -> [[DataReprAnn]]
forall a. ModuleEnv a -> [a]
ModuleEnv.moduleEnvElts ModuleEnv [DataReprAnn]
mEnv [[DataReprAnn]] -> [[DataReprAnn]] -> [[DataReprAnn]]
forall a. Semigroup a => a -> a -> a
<> NameEnv [DataReprAnn] -> [[DataReprAnn]]
forall a. NameEnv a -> [a]
NameEnv.nonDetNameEnvElts NameEnv [DataReprAnn]
nEnv
#elif MIN_VERSION_ghc(9,0,0)
  (mEnv, nEnv) = Annotations.deserializeAnns deserialize env
  reprs = ModuleEnv.moduleEnvElts mEnv <> NameEnv.nameEnvElts nEnv
#else
  reprs = UniqFM.eltsUFM (Annotations.deserializeAnns deserialize 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')   =
    String -> Maybe DataRepr'
forall a. HasCallStack => String -> 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 :: forall (m :: Type -> Type).
MonadIO m =>
HDL -> [Annotation] -> m [Either UnresolvedPrimitive String]
loadPrimitiveAnnotations HDL
hdl [Annotation]
anns =
  [[Either UnresolvedPrimitive String]]
-> [Either UnresolvedPrimitive String]
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat ([[Either UnresolvedPrimitive String]]
 -> [Either UnresolvedPrimitive String])
-> m [[Either UnresolvedPrimitive String]]
-> m [Either UnresolvedPrimitive String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> ((CoreAnnTarget, Primitive)
 -> m [Either UnresolvedPrimitive String])
-> [(CoreAnnTarget, Primitive)]
-> m [[Either UnresolvedPrimitive String]]
forall (t :: Type -> Type) (m :: Type -> Type) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: Type -> Type) a b.
Monad m =>
(a -> m b) -> [a] -> m [b]
mapM (HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive String]
forall (m :: Type -> Type).
MonadIO m =>
HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive String]
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 :: forall (m :: Type -> Type).
MonadIO m =>
HDL
-> (CoreAnnTarget, Primitive)
-> m [Either UnresolvedPrimitive String]
getUnresolvedPrimitives HDL
hdl (CoreAnnTarget
target, Primitive
prim) | HDL
hdl HDL -> [HDL] -> Bool
forall a. Eq a => a -> [a] -> 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]
_ String
fp -> [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [String -> Either UnresolvedPrimitive String
forall a b. b -> Either a b
Right String
fp]

    InlineYamlPrimitive [HDL]
_ String
contentOrFp ->
      case CoreAnnTarget
target of
        -- Module annotation, can house many primitives
        Annotations.ModuleTarget GenModule Unit
_ ->
          IO [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall a. IO a -> m a
forall (m :: Type -> Type) a. MonadIO m => IO a -> m a
liftIO (String -> ByteString -> [Either UnresolvedPrimitive String]
forall a. (HasCallStack, FromJSON a) => String -> ByteString -> a
decodeOrErrYaml String
contentOrFp (ByteString -> [Either UnresolvedPrimitive String])
-> IO ByteString -> IO [Either UnresolvedPrimitive String]
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> String -> IO ByteString
BL.readFile String
contentOrFp)
        Annotations.NamedTarget Name
targetName0 ->
          let targetName1 :: String
targetName1 = Text -> String
Text.unpack (Name -> Text
qualifiedNameString' Name
targetName0)
              primOrErr :: UnresolvedPrimitive
primOrErr = String -> ByteString -> UnresolvedPrimitive
forall a. (HasCallStack, FromJSON a) => String -> ByteString -> a
decodeOrErrYaml String
targetName1 (String -> ByteString
BLU.fromString String
contentOrFp)
              primName :: String
primName = Text -> String
Text.unpack (UnresolvedPrimitive -> Text
forall a b c d. Primitive a b c d -> Text
name UnresolvedPrimitive
primOrErr) in

          if String
primName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
targetName1
          then String -> String -> m [Either UnresolvedPrimitive String]
forall {a}. String -> String -> a
inlineNameError String
targetName1 String
primName
          else [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [UnresolvedPrimitive -> Either UnresolvedPrimitive String
forall a b. a -> Either a b
Left UnresolvedPrimitive
primOrErr]

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

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

          if String
primName String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
targetName1
          then String -> String -> m [Either UnresolvedPrimitive String]
forall {a}. String -> String -> a
inlineNameError String
targetName1 String
primName
          else [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall a. a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure [UnresolvedPrimitive -> Either UnresolvedPrimitive String
forall a b. a -> Either a b
Left UnresolvedPrimitive
primOrErr]
 where
  inlineNameError :: String -> String -> a
inlineNameError String
targetName String
primName =
    String -> a
forall a. HasCallStack => String -> a
error (String -> a) -> String -> a
forall a b. (a -> b) -> a -> b
$ [String] -> String
forall (t :: Type -> Type) a. Foldable t => t [a] -> [a]
concat
      [ String
"Function " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
targetName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" was annotated with an inline "
      , String
"primitive for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
primName String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
". These names "
      , String
"should be the same." ]

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

getUnresolvedPrimitives HDL
_ (CoreAnnTarget, Primitive)
_  = [Either UnresolvedPrimitive String]
-> m [Either UnresolvedPrimitive String]
forall a. a -> m a
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    = (() :: Constraint) => CoreBndr -> IdInfo
CoreBndr -> IdInfo
Var.idInfo CoreBndr
_id
#if MIN_VERSION_ghc(9,4,0)
        unfolding :: Unfolding
unfolding  = IdInfo -> Unfolding
IdInfo.realUnfoldingInfo IdInfo
_idInfo
#else
        unfolding  = IdInfo.unfoldingInfo _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)
        | DmdSig -> Bool
Demand.isDeadEndSig (DmdSig -> Bool) -> DmdSig -> Bool
forall a b. (a -> b) -> a -> b
$ IdInfo -> DmdSig
IdInfo.dmdSigInfo IdInfo
_idInfo
#elif MIN_VERSION_ghc(9,0,0)
        | Demand.isDeadEndSig $ IdInfo.strictnessInfo _idInfo
#else
        | Demand.isBottomingSig $ IdInfo.strictnessInfo _idInfo
#endif
        -> do
          let noUnfoldingErr :: String
noUnfoldingErr = String
"no_unfolding " String -> String -> String
forall a. [a] -> [a] -> [a]
++ CoreBndr -> String
forall a. Outputable a => a -> String
showPprUnsafe CoreBndr
bndr
          CoreExpr -> Maybe CoreExpr
forall a. a -> Maybe a
Just (Type -> String -> CoreExpr
MkCore.mkAbsentErrorApp (CoreBndr -> Type
Var.varType CoreBndr
_id) String
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 :: forall name. AnnTarget name -> Maybe name
getAnnTargetName_maybe (Annotations.NamedTarget name
nm) = name -> Maybe name
forall a. a -> Maybe a
Just name
nm
getAnnTargetName_maybe AnnTarget name
_                            = Maybe name
forall a. Maybe a
Nothing
#endif