{-# LANGUAGE GADTs #-}
module GHC.Driver.GenerateCgIPEStub (generateCgIPEStub) where
import qualified Data.Map.Strict as Map
import Data.Maybe (catMaybes, listToMaybe)
import GHC.Cmm
import GHC.Cmm.CLabel (CLabel)
import GHC.Cmm.Dataflow (Block, C, O)
import GHC.Cmm.Dataflow.Block (blockSplit, blockToList)
import GHC.Cmm.Dataflow.Collections (mapToList)
import GHC.Cmm.Dataflow.Label (Label)
import GHC.Cmm.Info.Build (emptySRT)
import GHC.Cmm.Pipeline (cmmPipeline)
import GHC.Cmm.Utils (toBlockList)
import GHC.Data.Maybe (firstJusts)
import GHC.Data.Stream (Stream, liftIO)
import qualified GHC.Data.Stream as Stream
import GHC.Driver.Env (hsc_dflags)
import GHC.Driver.Env.Types (HscEnv)
import GHC.Driver.Flags (GeneralFlag (Opt_InfoTableMap))
import GHC.Driver.Session (gopt, targetPlatform)
import GHC.Driver.Config.StgToCmm
import GHC.Prelude
import GHC.Runtime.Heap.Layout (isStackRep)
import GHC.Settings (Platform, platformUnregisterised)
import GHC.StgToCmm.Monad (getCmm, initC, runC, initFCodeState)
import GHC.StgToCmm.Prof (initInfoTableProv)
import GHC.StgToCmm.Types (CmmCgInfos (..), ModuleLFInfos)
import GHC.Types.IPE (InfoTableProvMap (provInfoTables), IpeSourceLocation)
import GHC.Types.Name.Set (NonCaffySet)
import GHC.Types.Tickish (GenTickish (SourceNote))
import GHC.Unit.Types (Module)
import GHC.Utils.Misc
generateCgIPEStub :: HscEnv -> Module -> InfoTableProvMap -> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos) -> Stream IO CmmGroupSRTs CmmCgInfos
generateCgIPEStub :: HscEnv
-> Module
-> InfoTableProvMap
-> Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
-> Stream IO CmmGroupSRTs CmmCgInfos
generateCgIPEStub HscEnv
hsc_env Module
this_mod InfoTableProvMap
denv Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
s = do
let dflags :: DynFlags
dflags = HscEnv -> DynFlags
hsc_dflags HscEnv
hsc_env
platform :: Platform
platform = DynFlags -> Platform
targetPlatform DynFlags
dflags
fstate :: FCodeState
fstate = Platform -> FCodeState
initFCodeState Platform
platform
CgState
cgState <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO CgState
initC
let collectFun :: [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
-> CmmGroupSRTs
-> IO
([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
collectFun = if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_InfoTableMap DynFlags
dflags then Platform
-> [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
-> CmmGroupSRTs
-> IO
([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
collect Platform
platform else forall a. [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)
collectNothing
([(Label, CmmInfoTable, Maybe IpeSourceLocation)]
labeledInfoTablesWithTickishes, (NonCaffySet
nonCaffySet, ModuleLFInfos
moduleLFInfos)) <- forall (m :: * -> *) a b c r.
Monad m =>
(c -> a -> m (c, b)) -> c -> Stream m a r -> Stream m b (c, r)
Stream.mapAccumL_ [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
-> CmmGroupSRTs
-> IO
([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
collectFun [] Stream IO CmmGroupSRTs (NonCaffySet, ModuleLFInfos)
s
let denv' :: InfoTableProvMap
denv' = InfoTableProvMap
denv {provInfoTables :: InfoTableToSourceLocationMap
provInfoTables = forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList (forall a b. (a -> b) -> [a] -> [b]
map (\(Label
_, CmmInfoTable
i, Maybe IpeSourceLocation
t) -> (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
i, Maybe IpeSourceLocation
t)) [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
labeledInfoTablesWithTickishes)}
((CStub
ipeStub, CmmGroup
ipeCmmGroup), CgState
_) = forall a.
StgToCmmConfig -> FCodeState -> CgState -> FCode a -> (a, CgState)
runC (DynFlags -> Module -> StgToCmmConfig
initStgToCmmConfig DynFlags
dflags Module
this_mod) FCodeState
fstate CgState
cgState forall a b. (a -> b) -> a -> b
$ forall a. FCode a -> FCode (a, CmmGroup)
getCmm ([CmmInfoTable] -> InfoTableProvMap -> FCode CStub
initInfoTableProv (forall a b. (a -> b) -> [a] -> [b]
map forall a b c. (a, b, c) -> b
sndOf3 [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
labeledInfoTablesWithTickishes) InfoTableProvMap
denv')
(ModuleSRTInfo
_, CmmGroupSRTs
ipeCmmGroupSRTs) <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ HscEnv
-> ModuleSRTInfo -> CmmGroup -> IO (ModuleSRTInfo, CmmGroupSRTs)
cmmPipeline HscEnv
hsc_env (Module -> ModuleSRTInfo
emptySRT Module
this_mod) CmmGroup
ipeCmmGroup
forall (m :: * -> *) a. Monad m => a -> Stream m a ()
Stream.yield CmmGroupSRTs
ipeCmmGroupSRTs
forall (m :: * -> *) a. Monad m => a -> m a
return CmmCgInfos {cgNonCafs :: NonCaffySet
cgNonCafs = NonCaffySet
nonCaffySet, cgLFInfos :: ModuleLFInfos
cgLFInfos = ModuleLFInfos
moduleLFInfos, cgIPEStub :: CStub
cgIPEStub = CStub
ipeStub}
where
collect :: Platform -> [(Label, CmmInfoTable, Maybe IpeSourceLocation)] -> CmmGroupSRTs -> IO ([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
collect :: Platform
-> [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
-> CmmGroupSRTs
-> IO
([(Label, CmmInfoTable, Maybe IpeSourceLocation)], CmmGroupSRTs)
collect Platform
platform [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
acc CmmGroupSRTs
cmmGroupSRTs = do
let labelsToInfoTables :: [(Label, CmmInfoTable)]
labelsToInfoTables = CmmGroupSRTs -> [(Label, CmmInfoTable)]
collectInfoTables CmmGroupSRTs
cmmGroupSRTs
labelsToInfoTablesToTickishes :: [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
labelsToInfoTablesToTickishes = forall a b. (a -> b) -> [a] -> [b]
map (\(Label
l, CmmInfoTable
i) -> (Label
l, CmmInfoTable
i, Platform
-> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation
lookupEstimatedTick Platform
platform CmmGroupSRTs
cmmGroupSRTs Label
l CmmInfoTable
i)) [(Label, CmmInfoTable)]
labelsToInfoTables
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Label, CmmInfoTable, Maybe IpeSourceLocation)]
acc forall a. [a] -> [a] -> [a]
++ [(Label, CmmInfoTable, Maybe IpeSourceLocation)]
labelsToInfoTablesToTickishes, CmmGroupSRTs
cmmGroupSRTs)
collectNothing :: [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)
collectNothing :: forall a. [a] -> CmmGroupSRTs -> IO ([a], CmmGroupSRTs)
collectNothing [a]
_ CmmGroupSRTs
cmmGroupSRTs = forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], CmmGroupSRTs
cmmGroupSRTs)
collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]
collectInfoTables :: CmmGroupSRTs -> [(Label, CmmInfoTable)]
collectInfoTables CmmGroupSRTs
cmmGroup = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
-> Maybe [(Label, CmmInfoTable)]
extractInfoTables CmmGroupSRTs
cmmGroup
extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph -> Maybe [(Label, CmmInfoTable)]
extractInfoTables :: GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
-> Maybe [(Label, CmmInfoTable)]
extractInfoTables (CmmProc CmmTopInfo
h CLabel
_ [GlobalReg]
_ CmmGraph
_) = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => map a -> [(KeyOf map, a)]
mapToList (CmmTopInfo -> LabelMap CmmInfoTable
info_tbls CmmTopInfo
h)
extractInfoTables GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
_ = forall a. Maybe a
Nothing
lookupEstimatedTick :: Platform -> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation
lookupEstimatedTick :: Platform
-> CmmGroupSRTs -> Label -> CmmInfoTable -> Maybe IpeSourceLocation
lookupEstimatedTick Platform
platform CmmGroupSRTs
cmmGroup Label
infoTableLabel CmmInfoTable
infoTable = do
if (SMRep -> Bool
isStackRep forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmInfoTable -> SMRep
cit_rep) CmmInfoTable
infoTable
then do
let findFun :: Block CmmNode C C -> Maybe IpeSourceLocation
findFun =
if Platform -> Bool
platformUnregisterised Platform
platform
then CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation
findCmmTickishForForUnregistered (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
infoTable)
else Label -> Block CmmNode C C -> Maybe IpeSourceLocation
findCmmTickishForRegistered Label
infoTableLabel
blocks :: [Block CmmNode C C]
blocks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap CmmGraph -> [Block CmmNode C C]
toBlockList (CmmGroupSRTs -> [CmmGraph]
graphs CmmGroupSRTs
cmmGroup)
forall (f :: * -> *) a. Foldable f => f (Maybe a) -> Maybe a
firstJusts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Block CmmNode C C -> Maybe IpeSourceLocation
findFun [Block CmmNode C C]
blocks
else forall a. Maybe a
Nothing
graphs :: CmmGroupSRTs -> [CmmGraph]
graphs :: CmmGroupSRTs -> [CmmGraph]
graphs = forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' forall d h. [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]
go []
where
go :: [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]
go :: forall d h. [CmmGraph] -> GenCmmDecl d h CmmGraph -> [CmmGraph]
go [CmmGraph]
acc (CmmProc h
_ CLabel
_ [GlobalReg]
_ CmmGraph
g) = CmmGraph
g forall a. a -> [a] -> [a]
: [CmmGraph]
acc
go [CmmGraph]
acc GenCmmDecl d h CmmGraph
_ = [CmmGraph]
acc
findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation
findCmmTickishForRegistered :: Label -> Block CmmNode C C -> Maybe IpeSourceLocation
findCmmTickishForRegistered Label
label Block CmmNode C C
block = do
let (CmmNode C O
_, Block CmmNode O O
middleBlock, CmmNode O C
endBlock) = forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit Block CmmNode C C
block
CmmNode O C -> Label -> Maybe ()
isCallWithReturnFrameLabel CmmNode O C
endBlock Label
label
Block CmmNode O O -> Maybe IpeSourceLocation
lastTickInBlock Block CmmNode O O
middleBlock
where
isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()
isCallWithReturnFrameLabel :: CmmNode O C -> Label -> Maybe ()
isCallWithReturnFrameLabel (CmmCall CmmExpr
_ (Just Label
l) [GlobalReg]
_ ByteOff
_ ByteOff
_ ByteOff
_) Label
clabel | Label
l forall a. Eq a => a -> a -> Bool
== Label
clabel = forall a. a -> Maybe a
Just ()
isCallWithReturnFrameLabel CmmNode O C
_ Label
_ = forall a. Maybe a
Nothing
lastTickInBlock :: Block CmmNode O O -> Maybe IpeSourceLocation
lastTickInBlock Block CmmNode O O
block =
forall a. [a] -> Maybe a
listToMaybe forall a b. (a -> b) -> a -> b
$
forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map CmmNode O O -> Maybe IpeSourceLocation
maybeTick forall a b. (a -> b) -> a -> b
$ (forall a. [a] -> [a]
reverse forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList) Block CmmNode O O
block
maybeTick :: CmmNode O O -> Maybe IpeSourceLocation
maybeTick :: CmmNode O O -> Maybe IpeSourceLocation
maybeTick (CmmTick (SourceNote RealSrcSpan
span String
name)) = forall a. a -> Maybe a
Just (RealSrcSpan
span, String
name)
maybeTick CmmNode O O
_ = forall a. Maybe a
Nothing
findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation
findCmmTickishForForUnregistered :: CLabel -> Block CmmNode C C -> Maybe IpeSourceLocation
findCmmTickishForForUnregistered CLabel
cLabel Block CmmNode C C
block = do
let (CmmNode C O
_, Block CmmNode O O
middleBlock, CmmNode O C
_) = forall (n :: Extensibility -> Extensibility -> *).
Block n C C -> (n C O, Block n O O, n O C)
blockSplit Block CmmNode C C
block
CLabel
-> [CmmNode O O]
-> Maybe IpeSourceLocation
-> Maybe IpeSourceLocation
find CLabel
cLabel (forall (n :: Extensibility -> Extensibility -> *).
Block n O O -> [n O O]
blockToList Block CmmNode O O
middleBlock) forall a. Maybe a
Nothing
where
find :: CLabel -> [CmmNode O O] -> Maybe IpeSourceLocation -> Maybe IpeSourceLocation
find :: CLabel
-> [CmmNode O O]
-> Maybe IpeSourceLocation
-> Maybe IpeSourceLocation
find CLabel
label (CmmNode O O
b : [CmmNode O O]
blocks) Maybe IpeSourceLocation
lastTick = case CmmNode O O
b of
(CmmStore CmmExpr
_ (CmmLit (CmmLabel CLabel
l)) AlignmentSpec
_) -> if CLabel
label forall a. Eq a => a -> a -> Bool
== CLabel
l then Maybe IpeSourceLocation
lastTick else CLabel
-> [CmmNode O O]
-> Maybe IpeSourceLocation
-> Maybe IpeSourceLocation
find CLabel
label [CmmNode O O]
blocks Maybe IpeSourceLocation
lastTick
(CmmTick (SourceNote RealSrcSpan
span String
name)) -> CLabel
-> [CmmNode O O]
-> Maybe IpeSourceLocation
-> Maybe IpeSourceLocation
find CLabel
label [CmmNode O O]
blocks forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just (RealSrcSpan
span, String
name)
CmmNode O O
_ -> CLabel
-> [CmmNode O O]
-> Maybe IpeSourceLocation
-> Maybe IpeSourceLocation
find CLabel
label [CmmNode O O]
blocks Maybe IpeSourceLocation
lastTick
find CLabel
_ [] Maybe IpeSourceLocation
_ = forall a. Maybe a
Nothing