module GHC.Unit.Module.Status
   ( HscBackendAction(..)
   , HscRecompStatus (..)
   , RecompLinkables (..)
   , RecompBytecodeLinkable (..)
   , emptyRecompLinkables
   , justBytecode
   , justObjects
   , bytecodeAndObjects
   , safeCastHomeModLinkable
   )
where

import GHC.Prelude

import GHC.Unit
import GHC.Unit.Home.ModInfo
import GHC.Unit.Module.ModGuts
import GHC.Unit.Module.ModIface

import GHC.Linker.Types ( Linkable, WholeCoreBindingsLinkable, linkableIsNativeCodeOnly, ModuleByteCode, LinkableWith )

import GHC.Utils.Fingerprint
import GHC.Utils.Outputable
import GHC.Utils.Panic

-- | Status of a module in incremental compilation
data HscRecompStatus
    -- | Nothing to do because code already exists.
    = HscUpToDate ModIface RecompLinkables
    -- | Recompilation of module, or update of interface is required. Optionally
    -- pass the old interface hash to avoid updating the existing interface when
    -- it has not changed.
    | HscRecompNeeded (Maybe Fingerprint)

-- | Action to perform in backend compilation
data HscBackendAction
    -- | Update the boot and signature file results.
    = HscUpdate ModIface
    -- | Recompile this module.
    | HscRecomp
        { HscBackendAction -> CgGuts
hscs_guts           :: CgGuts
          -- ^ Information for the code generator.
        , HscBackendAction -> ModLocation
hscs_mod_location   :: !ModLocation
          -- ^ Module info
        , HscBackendAction -> PartialModIface
hscs_partial_iface  :: !PartialModIface
          -- ^ Partial interface
        , HscBackendAction -> Maybe Fingerprint
hscs_old_iface_hash :: !(Maybe Fingerprint)
          -- ^ Old interface hash for this compilation, if an old interface file
          -- exists. Pass to `hscMaybeWriteIface` when writing the interface to
          -- avoid updating the existing interface when the interface isn't
          -- changed.
        }

-- | Linkables produced by @hscRecompStatus@. Might contain serialized core
-- which can be turned into BCOs (or object files), or used by some other
-- backend. See Note [Interface Files with Core Definitions].
data RecompLinkables = RecompLinkables { RecompLinkables -> RecompBytecodeLinkable
recompLinkables_bytecode :: !RecompBytecodeLinkable
                                       , RecompLinkables -> Maybe Linkable
recompLinkables_object   :: !(Maybe Linkable) }

data RecompBytecodeLinkable
  = NormalLinkable !(Maybe (LinkableWith ModuleByteCode))
  | WholeCoreBindingsLinkable !WholeCoreBindingsLinkable

instance Outputable HscRecompStatus where
  ppr :: HscRecompStatus -> SDoc
ppr HscUpToDate{} = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HscUpToDate"
  ppr HscRecompNeeded{} = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"HscRecompNeeded"

instance Outputable HscBackendAction where
  ppr :: HscBackendAction -> SDoc
ppr (HscUpdate ModIface
mi) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Update:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> (Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr (ModIface -> Module
forall (phase :: ModIfacePhase). ModIface_ phase -> Module
mi_module ModIface
mi))
  ppr (HscRecomp CgGuts
_ ModLocation
ml PartialModIface
_mi Maybe Fingerprint
_mf) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Recomp:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> ModLocation -> SDoc
forall a. Outputable a => a -> SDoc
ppr ModLocation
ml

instance Outputable RecompLinkables where
  ppr :: RecompLinkables -> SDoc
ppr (RecompLinkables RecompBytecodeLinkable
l1 Maybe Linkable
l2) = RecompBytecodeLinkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr RecompBytecodeLinkable
l1 SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Maybe Linkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe Linkable
l2

instance Outputable RecompBytecodeLinkable where
  ppr :: RecompBytecodeLinkable -> SDoc
ppr (NormalLinkable Maybe (LinkableWith ModuleByteCode)
lm) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"NormalLinkable:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Maybe (LinkableWith ModuleByteCode) -> SDoc
forall a. Outputable a => a -> SDoc
ppr Maybe (LinkableWith ModuleByteCode)
lm
  ppr (WholeCoreBindingsLinkable WholeCoreBindingsLinkable
lm) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"WholeCoreBindingsLinkable:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> WholeCoreBindingsLinkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr WholeCoreBindingsLinkable
lm

emptyRecompLinkables :: RecompLinkables
emptyRecompLinkables :: RecompLinkables
emptyRecompLinkables = RecompBytecodeLinkable -> Maybe Linkable -> RecompLinkables
RecompLinkables (Maybe (LinkableWith ModuleByteCode) -> RecompBytecodeLinkable
NormalLinkable Maybe (LinkableWith ModuleByteCode)
forall a. Maybe a
Nothing) Maybe Linkable
forall a. Maybe a
Nothing

safeCastHomeModLinkable :: HomeModLinkable -> RecompLinkables
safeCastHomeModLinkable :: HomeModLinkable -> RecompLinkables
safeCastHomeModLinkable (HomeModLinkable Maybe (LinkableWith ModuleByteCode)
bc Maybe Linkable
o) = RecompBytecodeLinkable -> Maybe Linkable -> RecompLinkables
RecompLinkables (Maybe (LinkableWith ModuleByteCode) -> RecompBytecodeLinkable
NormalLinkable Maybe (LinkableWith ModuleByteCode)
bc) Maybe Linkable
o

justBytecode :: Either (LinkableWith ModuleByteCode) WholeCoreBindingsLinkable -> RecompLinkables
justBytecode :: Either (LinkableWith ModuleByteCode) WholeCoreBindingsLinkable
-> RecompLinkables
justBytecode = \case
  Left LinkableWith ModuleByteCode
lm -> RecompLinkables
emptyRecompLinkables { recompLinkables_bytecode = NormalLinkable (Just lm) }
  Right WholeCoreBindingsLinkable
lm -> RecompLinkables
emptyRecompLinkables { recompLinkables_bytecode = WholeCoreBindingsLinkable lm }

justObjects :: Linkable -> RecompLinkables
justObjects :: Linkable -> RecompLinkables
justObjects Linkable
lm =
  Bool -> SDoc -> RecompLinkables -> RecompLinkables
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Linkable -> Bool
linkableIsNativeCodeOnly Linkable
lm) (Linkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr Linkable
lm)
    (RecompLinkables -> RecompLinkables)
-> RecompLinkables -> RecompLinkables
forall a b. (a -> b) -> a -> b
$ RecompLinkables
emptyRecompLinkables { recompLinkables_object = Just lm }

bytecodeAndObjects :: Either (LinkableWith ModuleByteCode) WholeCoreBindingsLinkable -> Linkable -> RecompLinkables
bytecodeAndObjects :: Either (LinkableWith ModuleByteCode) WholeCoreBindingsLinkable
-> Linkable -> RecompLinkables
bytecodeAndObjects Either (LinkableWith ModuleByteCode) WholeCoreBindingsLinkable
either_bc Linkable
o = case Either (LinkableWith ModuleByteCode) WholeCoreBindingsLinkable
either_bc of
  Left LinkableWith ModuleByteCode
bc ->
    Bool -> SDoc -> RecompLinkables -> RecompLinkables
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Linkable -> Bool
linkableIsNativeCodeOnly Linkable
o) (Linkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr Linkable
o)
      (RecompLinkables -> RecompLinkables)
-> RecompLinkables -> RecompLinkables
forall a b. (a -> b) -> a -> b
$ RecompBytecodeLinkable -> Maybe Linkable -> RecompLinkables
RecompLinkables (Maybe (LinkableWith ModuleByteCode) -> RecompBytecodeLinkable
NormalLinkable (LinkableWith ModuleByteCode -> Maybe (LinkableWith ModuleByteCode)
forall a. a -> Maybe a
Just LinkableWith ModuleByteCode
bc)) (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
o)
  Right WholeCoreBindingsLinkable
bc ->
    Bool -> SDoc -> RecompLinkables -> RecompLinkables
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr (Linkable -> Bool
linkableIsNativeCodeOnly Linkable
o) (Linkable -> SDoc
forall a. Outputable a => a -> SDoc
ppr Linkable
o)
      (RecompLinkables -> RecompLinkables)
-> RecompLinkables -> RecompLinkables
forall a b. (a -> b) -> a -> b
$ RecompBytecodeLinkable -> Maybe Linkable -> RecompLinkables
RecompLinkables (WholeCoreBindingsLinkable -> RecompBytecodeLinkable
WholeCoreBindingsLinkable WholeCoreBindingsLinkable
bc) (Linkable -> Maybe Linkable
forall a. a -> Maybe a
Just Linkable
o)