{-# LANGUAGE CPP             #-}
{-# LANGUAGE RecordWildCards #-}

-- | CoreFiles let us serialize Core to a file in order to later recover it
-- without reparsing or retypechecking
module Development.IDE.GHC.CoreFile
  ( CoreFile(..)
  , codeGutsToCoreFile
  , typecheckCoreFile
  , readBinCoreFile
  , writeBinCoreFile
  , getImplicitBinds
  ) where

import           Control.Monad
import           Data.IORef
import           Data.Maybe
import           Development.IDE.GHC.Compat
import qualified Development.IDE.GHC.Compat.Util as Util
import           GHC.Core
import           GHC.CoreToIface
import           GHC.Fingerprint
import           GHC.Iface.Binary
#if MIN_VERSION_ghc(9,11,0)
import qualified GHC.Iface.Load                  as Iface
#endif
import           GHC.Iface.Recomp.Binary         (fingerprintBinMem)
import           GHC.IfaceToCore
import           GHC.Types.Id.Make
import           GHC.Types.TypeEnv
import           GHC.Utils.Binary
import           Prelude                         hiding (mod)


-- | Initial ram buffer to allocate for writing interface files
initBinMemSize :: Int
initBinMemSize :: Int
initBinMemSize = Int
1024 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1024

data CoreFile
  = CoreFile
  { CoreFile -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
cf_bindings   :: [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
  -- ^ The actual core file bindings, deserialized lazily
  , CoreFile -> Fingerprint
cf_iface_hash :: !Fingerprint
  }

instance Binary CoreFile where
  put_ :: BinHandle -> CoreFile -> IO ()
put_ BinHandle
bh (CoreFile [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
core Fingerprint
fp) = BinHandle
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo] -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
lazyPut BinHandle
bh [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
core IO () -> IO () -> IO ()
forall a b. IO a -> IO b -> IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> BinHandle -> Fingerprint -> IO ()
forall a. Binary a => BinHandle -> a -> IO ()
put_ BinHandle
bh Fingerprint
fp
  get :: BinHandle -> IO CoreFile
get BinHandle
bh = [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> Fingerprint -> CoreFile
CoreFile ([IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
 -> Fingerprint -> CoreFile)
-> IO [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> IO (Fingerprint -> CoreFile)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BinHandle -> IO [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
forall a. Binary a => BinHandle -> IO a
lazyGet BinHandle
bh IO (Fingerprint -> CoreFile) -> IO Fingerprint -> IO CoreFile
forall a b. IO (a -> b) -> IO a -> IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> BinHandle -> IO Fingerprint
forall a. Binary a => BinHandle -> IO a
get BinHandle
bh

readBinCoreFile
  :: NameCacheUpdater
  -> FilePath
  -> IO (CoreFile, Fingerprint)
readBinCoreFile :: NameCacheUpdater -> FilePath -> IO (CoreFile, Fingerprint)
readBinCoreFile NameCacheUpdater
name_cache FilePath
fat_hi_path = do
    BinHandle
bh <- FilePath -> IO BinHandle
readBinMem FilePath
fat_hi_path
    CoreFile
file <- NameCacheUpdater -> BinHandle -> IO CoreFile
forall a. Binary a => NameCacheUpdater -> BinHandle -> IO a
getWithUserData NameCacheUpdater
name_cache BinHandle
bh
    !Fingerprint
fp <- FilePath -> IO Fingerprint
Util.getFileHash FilePath
fat_hi_path
    (CoreFile, Fingerprint) -> IO (CoreFile, Fingerprint)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreFile
file, Fingerprint
fp)

-- | Write a core file
writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint
writeBinCoreFile :: DynFlags -> FilePath -> CoreFile -> IO Fingerprint
writeBinCoreFile DynFlags
_dflags FilePath
core_path CoreFile
fat_iface = do
    BinHandle
bh <- Int -> IO BinHandle
openBinMem Int
initBinMemSize

    let quietTrace :: TraceBinIFace
quietTrace =
          TraceBinIFace
QuietBinIFace

    TraceBinIFace -> BinHandle -> CoreFile -> IO ()
forall a. Binary a => TraceBinIFace -> BinHandle -> a -> IO ()
putWithUserData
      TraceBinIFace
quietTrace
#if MIN_VERSION_ghc(9,11,0)
      (Iface.flagsToIfCompression _dflags)
#endif
      BinHandle
bh
      CoreFile
fat_iface

    -- And send the result to the file
    BinHandle -> FilePath -> IO ()
writeBinMem BinHandle
bh FilePath
core_path

    !Fingerprint
fp <- BinHandle -> IO Fingerprint
fingerprintBinMem BinHandle
bh
    Fingerprint -> IO Fingerprint
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Fingerprint
fp

-- Implicit binds aren't tidied, so we can't serialise them.
-- This isn't a problem however since we can regenerate them from the
-- original ModIface
codeGutsToCoreFile
  :: Fingerprint -- ^ Hash of the interface this was generated from
  -> CgGuts
  -> CoreFile
-- In GHC 9.6, implicit binds are tidied and part of core binds
codeGutsToCoreFile :: Fingerprint -> CgGuts -> CoreFile
codeGutsToCoreFile Fingerprint
hash CgGuts{[(ForeignSrcLang, FilePath)]
[TyCon]
[CostCentre]
CoreProgram
[SptEntry]
Maybe ModBreaks
Set UnitId
Module
HpcInfo
ForeignStubs
cg_module :: Module
cg_tycons :: [TyCon]
cg_binds :: CoreProgram
cg_ccs :: [CostCentre]
cg_foreign :: ForeignStubs
cg_foreign_files :: [(ForeignSrcLang, FilePath)]
cg_dep_pkgs :: Set UnitId
cg_hpc_info :: HpcInfo
cg_modBreaks :: Maybe ModBreaks
cg_spt_entries :: [SptEntry]
cg_spt_entries :: CgGuts -> [SptEntry]
cg_modBreaks :: CgGuts -> Maybe ModBreaks
cg_hpc_info :: CgGuts -> HpcInfo
cg_dep_pkgs :: CgGuts -> Set UnitId
cg_foreign_files :: CgGuts -> [(ForeignSrcLang, FilePath)]
cg_foreign :: CgGuts -> ForeignStubs
cg_ccs :: CgGuts -> [CostCentre]
cg_binds :: CgGuts -> CoreProgram
cg_tycons :: CgGuts -> [TyCon]
cg_module :: CgGuts -> Module
..} = [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> Fingerprint -> CoreFile
CoreFile ((Bind Id -> IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo)
-> CoreProgram -> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
forall a b. (a -> b) -> [a] -> [b]
map Bind Id -> IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo
toIfaceTopBind CoreProgram
cg_binds) Fingerprint
hash

getImplicitBinds :: TyCon -> [CoreBind]
getImplicitBinds :: TyCon -> CoreProgram
getImplicitBinds TyCon
tc = CoreProgram
cls_binds CoreProgram -> CoreProgram -> CoreProgram
forall a. [a] -> [a] -> [a]
++ TyCon -> CoreProgram
getTyConImplicitBinds TyCon
tc
  where
    cls_binds :: CoreProgram
cls_binds = CoreProgram -> (Class -> CoreProgram) -> Maybe Class -> CoreProgram
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Class -> CoreProgram
getClassImplicitBinds (TyCon -> Maybe Class
tyConClass_maybe TyCon
tc)

getTyConImplicitBinds :: TyCon -> [CoreBind]
getTyConImplicitBinds :: TyCon -> CoreProgram
getTyConImplicitBinds TyCon
tc
  | TyCon -> Bool
isNewTyCon TyCon
tc = []  -- See Note [Compulsory newtype unfolding] in MkId
  | Bool
otherwise     = (Id -> Bind Id) -> [Id] -> CoreProgram
forall a b. (a -> b) -> [a] -> [b]
map Id -> Bind Id
get_defn ((DataCon -> Maybe Id) -> [DataCon] -> [Id]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe DataCon -> Maybe Id
dataConWrapId_maybe (TyCon -> [DataCon]
tyConDataCons TyCon
tc))

getClassImplicitBinds :: Class -> [CoreBind]
getClassImplicitBinds :: Class -> CoreProgram
getClassImplicitBinds Class
cls
  = [ Id -> Expr Id -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
op (Class -> Int -> Expr Id
mkDictSelRhs Class
cls Int
val_index)
    | (Id
op, Int
val_index) <- Class -> [Id]
classAllSelIds Class
cls [Id] -> [Int] -> [(Id, Int)]
forall a b. [a] -> [b] -> [(a, b)]
`zip` [Int
0..] ]

get_defn :: Id -> CoreBind
get_defn :: Id -> Bind Id
get_defn Id
identifier = Id -> Expr Id -> Bind Id
forall b. b -> Expr b -> Bind b
NonRec Id
identifier Expr Id
templ
  where
    templ :: Expr Id
templ = case Unfolding -> Maybe (Expr Id)
maybeUnfoldingTemplate (Id -> Unfolding
realIdUnfolding Id
identifier) of
              Maybe (Expr Id)
Nothing -> FilePath -> Expr Id
forall a. HasCallStack => FilePath -> a
error FilePath
"get_dfn: no unfolding template"
              Just Expr Id
x  -> Expr Id
x

typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
typecheckCoreFile :: Module -> IORef TypeEnv -> CoreFile -> IfG CoreProgram
typecheckCoreFile Module
this_mod IORef TypeEnv
type_var (CoreFile [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
prepd_binding Fingerprint
_) =
  Module
-> SDoc -> IsBootInterface -> IfL CoreProgram -> IfG CoreProgram
forall a lcl.
Module -> SDoc -> IsBootInterface -> IfL a -> IfM lcl a
initIfaceLcl Module
this_mod (FilePath -> SDoc
forall doc. IsLine doc => FilePath -> doc
text FilePath
"typecheckCoreFile") IsBootInterface
NotBoot (IfL CoreProgram -> IfG CoreProgram)
-> IfL CoreProgram -> IfG CoreProgram
forall a b. (a -> b) -> a -> b
$ do
    IORef TypeEnv
-> [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
-> IfL CoreProgram
tcTopIfaceBindings IORef TypeEnv
type_var [IfaceBindingX IfaceMaybeRhs IfaceTopBndrInfo]
prepd_binding