{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TupleSections #-}
module Clash.GHC.LoadInterfaceFiles
( loadExternalExprs
, loadExternalBinders
, getUnresolvedPrimitives
, LoadedBinders(..)
)
where
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)
#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
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 LoadedBinders = LoadedBinders
{ LoadedBinders -> Map CoreBndr CoreExpr
lbBinders :: !(Map CoreSyn.CoreBndr CoreSyn.CoreExpr)
, LoadedBinders -> Map CoreBndr Int
lbClassOps :: !(Map CoreSyn.CoreBndr Int)
, LoadedBinders -> Set CoreBndr
lbUnlocatable :: !(Set CoreSyn.CoreBndr)
, LoadedBinders -> Seq (Either UnresolvedPrimitive String)
lbPrims :: !(Seq (Either UnresolvedPrimitive FilePath))
, LoadedBinders -> Seq DataRepr'
lbReprs :: !(Seq DataRepr')
, LoadedBinders -> DeclCache
lbCache :: !DeclCache
}
type LoadedBinderT m a = StateT LoadedBinders m a
type DeclCache = Map GHC.Module (Maybe (Map GHC.Name IfaceSyn.IfaceDecl))
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
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
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 }
[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
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)
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
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
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
getIfaceDeclM ::
forall m.
GHC.GhcMonad m =>
HDL ->
CoreSyn.CoreBndr ->
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
#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
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})
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 ->
(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})
GenModule Unit
-> LoadedBinderT m (Maybe (GenModule Unit, IfaceDecl))
go GenModule Unit
nameMod
Just Maybe (Map Name IfaceDecl)
Nothing ->
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) ->
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
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
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)
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