{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TupleSections #-}
module GHC.StgToCmm.Utils (
emitDataLits, emitRODataLits,
emitDataCon,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
emitBarf,
assignTemp, newTemp,
newUnboxedTupleRegs,
emitMultiAssign, emitCmmLitSwitch, emitSwitch,
tagToClosure, mkTaggedObjectLoad,
callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
callerSaveGlobalReg, callerRestoreGlobalReg,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord, cmmSubWord, cmmMulWord, cmmAddWord, cmmUShrWord,
cmmOffsetExprW, cmmOffsetExprB,
cmmRegOffW, cmmRegOffB,
cmmLabelOffW, cmmLabelOffB,
cmmOffsetW, cmmOffsetB,
cmmOffsetLitW, cmmOffsetLitB,
cmmLoadIndexW,
cmmConstrTag1,
cmmUntag, cmmIsTagged,
addToMem, addToMemE, addToMemLblE, addToMemLbl,
emitAtomicRead, emitAtomicWrite,
whenUpdRemSetEnabled,
emitUpdRemSetPush,
emitUpdRemSetPushThunk,
convertInfoProvMap, cmmInfoTableToInfoProvEnt, IPEStats(..),
closureIpeStats, fallbackIpeStats, skippedIpeStats,
) where
import GHC.Prelude hiding ( head, init, last, tail )
import GHC.Platform
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Lit (mkSimpleLit, newStringCLit)
import GHC.Cmm
import GHC.Cmm.BlockId
import GHC.Cmm.Graph as CmmGraph
import GHC.Platform.Regs
import GHC.Cmm.CLabel
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import {-# SOURCE #-} GHC.StgToCmm.Foreign (emitPrimCall)
import GHC.StgToCmm.CgUtils
import GHC.Types.ForeignCall
import GHC.Types.Id.Info
import GHC.Core.Type
import GHC.Core.TyCon
import GHC.Runtime.Heap.Layout
import GHC.Unit
import GHC.Types.Literal
import GHC.Data.Graph.Directed
import GHC.Utils.Misc
import GHC.Types.Unique
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Types.RepType
import GHC.Types.CostCentre
import GHC.Types.IPE
import qualified Data.Map as M
import Data.List (sortBy)
import Data.Ord
import Data.Maybe
import qualified Data.List.NonEmpty as NE
import GHC.Core.DataCon
import GHC.Types.Unique.DFM
import GHC.Data.Maybe
import Control.Monad
import qualified Data.Map.Strict as Map
import qualified Data.IntMap.Strict as I
import qualified Data.Semigroup (Semigroup(..))
addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl CmmType
rep CLabel
lbl = CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem CmmType
rep (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl))
addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
addToMemLblE :: CmmType -> CLabel -> CmmExpr -> CmmAGraph
addToMemLblE CmmType
rep CLabel
lbl = CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
rep (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl))
addToMem :: CmmType
-> CmmExpr
-> Int
-> CmmAGraph
addToMem :: CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem CmmType
rep CmmExpr
ptr Int
n = CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
rep CmmExpr
ptr (CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a. Integral a => a -> Integer
toInteger Int
n) (CmmType -> Width
typeWidth CmmType
rep)))
addToMemE :: CmmType
-> CmmExpr
-> CmmExpr
-> CmmAGraph
addToMemE :: CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
rep CmmExpr
ptr CmmExpr
n
= CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
ptr (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add (CmmType -> Width
typeWidth CmmType
rep)) [CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad CmmExpr
ptr CmmType
rep AlignmentSpec
NaturallyAligned, CmmExpr
n])
emitAtomicRead
:: MemoryOrdering
-> LocalReg
-> CmmExpr
-> FCode ()
emitAtomicRead :: MemoryOrdering -> LocalReg -> CmmExpr -> FCode ()
emitAtomicRead MemoryOrdering
mord LocalReg
res CmmExpr
addr
= FCode () -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall [LocalReg
res] (Width -> MemoryOrdering -> CallishMachOp
MO_AtomicRead Width
w MemoryOrdering
mord) [CmmExpr
addr]
where
w :: Width
w = CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ LocalReg -> CmmType
localRegType LocalReg
res
emitAtomicWrite
:: MemoryOrdering
-> CmmExpr
-> CmmExpr
-> FCode ()
emitAtomicWrite :: MemoryOrdering -> CmmExpr -> CmmExpr -> FCode ()
emitAtomicWrite MemoryOrdering
mord CmmExpr
addr CmmExpr
val
= do platform <- FCode Platform
getPlatform
let w = CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
val
void $ emitPrimCall [] (MO_AtomicWrite w mord) [addr, val]
mkTaggedObjectLoad
:: Platform -> LocalReg -> LocalReg -> ByteOff -> DynTag -> CmmAGraph
mkTaggedObjectLoad :: Platform -> LocalReg -> LocalReg -> Int -> Int -> CmmAGraph
mkTaggedObjectLoad Platform
platform LocalReg
reg LocalReg
base Int
offset Int
tag
= CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg)
(CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr -> Int -> CmmExpr
cmmOffsetB Platform
platform
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
base))
(Int
offset Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
tag))
(LocalReg -> CmmType
localRegType LocalReg
reg)
AlignmentSpec
NaturallyAligned)
tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr
tagToClosure :: Platform -> TyCon -> CmmExpr -> CmmExpr
tagToClosure Platform
platform TyCon
tycon CmmExpr
tag
= Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform (Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExprW Platform
platform CmmExpr
closure_tbl CmmExpr
tag)
where closure_tbl :: CmmExpr
closure_tbl = CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)
lbl :: CLabel
lbl = Name -> CafInfo -> CLabel
mkClosureTableLabel (TyCon -> Name
tyConName TyCon
tycon) CafInfo
NoCafRefs
emitBarf :: String -> FCode ()
emitBarf :: String -> FCode ()
emitBarf String
msg = do
strLbl <- String -> FCode CmmLit
newStringCLit String
msg
emitRtsCall rtsUnitId (fsLit "barf") [(CmmLit strLbl,AddrHint)] False
emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall :: UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall UnitId
pkg FastString
fun = [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [] (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
pkg FastString
fun)
emitRtsCallWithResult :: LocalReg -> ForeignHint -> UnitId -> FastString
-> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCallWithResult :: LocalReg
-> ForeignHint
-> UnitId
-> FastString
-> [(CmmExpr, ForeignHint)]
-> Bool
-> FCode ()
emitRtsCallWithResult LocalReg
res ForeignHint
hint UnitId
pkg = [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [(LocalReg
res,ForeignHint
hint)] (CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ())
-> (FastString -> CLabel)
-> FastString
-> [(CmmExpr, ForeignHint)]
-> Bool
-> FCode ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
pkg
emitRtsCallGen
:: [(LocalReg,ForeignHint)]
-> CLabel
-> [(CmmExpr,ForeignHint)]
-> Bool
-> FCode ()
emitRtsCallGen :: [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [(LocalReg, ForeignHint)]
res CLabel
lbl [(CmmExpr, ForeignHint)]
args Bool
safe
= do { platform <- FCode Platform
getPlatform
; updfr_off <- getUpdFrameOff
; let (caller_save, caller_load) = callerSaveVolatileRegs platform
; emit caller_save
; call updfr_off
; emit caller_load }
where
call :: Int -> FCode ()
call Int
updfr_off =
if Bool
safe then
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> [LocalReg] -> [CmmExpr] -> Int -> FCode CmmAGraph
mkCmmCall CmmExpr
fun_expr [LocalReg]
res' [CmmExpr]
args' Int
updfr_off
else do
let conv :: ForeignConvention
conv = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint]
arg_hints [ForeignHint]
res_hints CmmReturnInfo
CmmMayReturn
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall (CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
fun_expr ForeignConvention
conv) [LocalReg]
res' [CmmExpr]
args'
([CmmExpr]
args', [ForeignHint]
arg_hints) = [(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
args
([LocalReg]
res', [ForeignHint]
res_hints) = [(LocalReg, ForeignHint)] -> ([LocalReg], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LocalReg, ForeignHint)]
res
fun_expr :: CmmExpr
fun_expr = CLabel -> CmmExpr
mkLblExpr CLabel
lbl
callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs :: Platform -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs Platform
platform = (CmmAGraph
caller_save, CmmAGraph
caller_load)
where
caller_save :: CmmAGraph
caller_save = [CmmAGraph] -> CmmAGraph
catAGraphs ((GlobalReg -> CmmAGraph) -> [GlobalReg] -> [CmmAGraph]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalReg -> CmmAGraph
callerSaveGlobalReg Platform
platform) [GlobalReg]
regs_to_save)
caller_load :: CmmAGraph
caller_load = [CmmAGraph] -> CmmAGraph
catAGraphs ((GlobalReg -> CmmAGraph) -> [GlobalReg] -> [CmmAGraph]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalReg -> CmmAGraph
callerRestoreGlobalReg Platform
platform) [GlobalReg]
regs_to_save)
system_regs :: [GlobalReg]
system_regs =
[ GlobalReg
Sp, GlobalReg
SpLim
, GlobalReg
Hp, GlobalReg
HpLim
, GlobalReg
CCCS, GlobalReg
CurrentTSO, GlobalReg
CurrentNursery
, GlobalReg
BaseReg ]
regs_to_save :: [GlobalReg]
regs_to_save = (GlobalReg -> Bool) -> [GlobalReg] -> [GlobalReg]
forall a. (a -> Bool) -> [a] -> [a]
filter (Platform -> GlobalReg -> Bool
callerSaves Platform
platform) [GlobalReg]
system_regs
callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph
callerSaveGlobalReg :: Platform -> GlobalReg -> CmmAGraph
callerSaveGlobalReg Platform
platform GlobalReg
reg
= let ru :: GlobalRegUse
ru = GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
reg (Platform -> GlobalReg -> CmmType
globalRegSpillType Platform
platform GlobalReg
reg)
in CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Platform -> GlobalReg -> CmmExpr
get_GlobalReg_addr Platform
platform GlobalReg
reg) (CmmReg -> CmmExpr
CmmReg (GlobalRegUse -> CmmReg
CmmGlobal GlobalRegUse
ru))
callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph
callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph
callerRestoreGlobalReg Platform
platform GlobalReg
reg
= let reg_ty :: CmmType
reg_ty = Platform -> GlobalReg -> CmmType
globalRegSpillType Platform
platform GlobalReg
reg
ru :: GlobalRegUse
ru = GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
reg CmmType
reg_ty
in CmmReg -> CmmExpr -> CmmAGraph
mkAssign (GlobalRegUse -> CmmReg
CmmGlobal GlobalRegUse
ru)
(CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> GlobalReg -> CmmExpr
get_GlobalReg_addr Platform
platform GlobalReg
reg)
CmmType
reg_ty AlignmentSpec
NaturallyAligned)
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
emitDataLits CLabel
lbl [CmmLit]
lits = DCmmDecl -> FCode ()
emitDecl (Section -> CLabel -> [CmmLit] -> DCmmDecl
forall (raw :: Bool) info stmt.
Section
-> CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkDataLits (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) CLabel
lbl [CmmLit]
lits)
emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
emitRODataLits :: CLabel -> [CmmLit] -> FCode ()
emitRODataLits CLabel
lbl [CmmLit]
lits = DCmmDecl -> FCode ()
emitDecl (CLabel -> [CmmLit] -> DCmmDecl
forall (raw :: Bool) info stmt.
CLabel -> [CmmLit] -> GenCmmDecl (GenCmmStatics raw) info stmt
mkRODataLits CLabel
lbl [CmmLit]
lits)
emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon :: CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon CLabel
lbl CmmInfoTable
itbl CostCentreStack
ccs [CmmLit]
payload =
DCmmDecl -> FCode ()
emitDecl (Section -> CmmStatics -> DCmmDecl
forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) (CLabel
-> CmmInfoTable
-> CostCentreStack
-> [CmmLit]
-> [CmmLit]
-> CmmStatics
CmmStatics CLabel
lbl CmmInfoTable
itbl CostCentreStack
ccs [CmmLit]
payload []))
assignTemp :: CmmExpr -> FCode LocalReg
assignTemp :: CmmExpr -> FCode LocalReg
assignTemp (CmmReg (CmmLocal LocalReg
reg)) = LocalReg -> FCode LocalReg
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return LocalReg
reg
assignTemp CmmExpr
e = do { platform <- FCode Platform
getPlatform
; reg <- newTemp (cmmExprType platform e)
; emitAssign (CmmLocal reg) e
; return reg }
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs Type
res_ty
= Bool
-> FCode ([LocalReg], [ForeignHint])
-> FCode ([LocalReg], [ForeignHint])
forall a. HasCallStack => Bool -> a -> a
assert (Type -> Bool
isUnboxedTupleType Type
res_ty) (FCode ([LocalReg], [ForeignHint])
-> FCode ([LocalReg], [ForeignHint]))
-> FCode ([LocalReg], [ForeignHint])
-> FCode ([LocalReg], [ForeignHint])
forall a b. (a -> b) -> a -> b
$
do { platform <- FCode Platform
getPlatform
; sequel <- getSequel
; regs <- choose_regs platform sequel
; massert (regs `equalLength` reps)
; return (regs, map primRepForeignHint reps) }
where
reps :: [PrimRep]
reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
res_ty
choose_regs :: Platform -> Sequel -> FCode [LocalReg]
choose_regs Platform
_ (AssignTo [LocalReg]
regs Bool
_) = [LocalReg] -> FCode [LocalReg]
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return [LocalReg]
regs
choose_regs Platform
platform Sequel
_ = (PrimRep -> FCode LocalReg) -> [PrimRep] -> FCode [LocalReg]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (CmmType -> FCode LocalReg
forall (m :: * -> *). MonadGetUnique m => CmmType -> m LocalReg
newTemp (CmmType -> FCode LocalReg)
-> (PrimRep -> CmmType) -> PrimRep -> FCode LocalReg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Platform -> PrimRep -> CmmType
primRepCmmType Platform
platform) [PrimRep]
reps
emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
type Key = Int
type Vrtx = (Key, Stmt)
type Stmt = (LocalReg, CmmExpr)
emitMultiAssign :: [LocalReg] -> [CmmExpr] -> FCode ()
emitMultiAssign [] [] = () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
emitMultiAssign [LocalReg
reg] [CmmExpr
rhs] = CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
rhs
emitMultiAssign [LocalReg]
regs [CmmExpr]
rhss = do
platform <- FCode Platform
getPlatform
assertPpr (equalLength regs rhss) (ppr regs $$ pdoc platform rhss) $
unscramble platform ([1..] `zip` (regs `zip` rhss))
unscramble :: Platform -> [Vrtx] -> FCode ()
unscramble :: Platform -> [Vrtx] -> FCode ()
unscramble Platform
platform [Vrtx]
vertices = (SCC Vrtx -> FCode ()) -> [SCC Vrtx] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ SCC Vrtx -> FCode ()
do_component [SCC Vrtx]
components
where
edges :: [ Node Key Vrtx ]
edges :: [Node Int Vrtx]
edges = [ Vrtx -> Int -> [Int] -> Node Int Vrtx
forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode Vrtx
vertex Int
key1 (Stmt -> [Int]
edges_from Stmt
stmt1)
| vertex :: Vrtx
vertex@(Int
key1, Stmt
stmt1) <- [Vrtx]
vertices ]
edges_from :: Stmt -> [Key]
edges_from :: Stmt -> [Int]
edges_from Stmt
stmt1 = [ Int
key2 | (Int
key2, Stmt
stmt2) <- [Vrtx]
vertices,
Stmt
stmt1 Stmt -> Stmt -> Bool
`mustFollow` Stmt
stmt2 ]
components :: [SCC Vrtx]
components :: [SCC Vrtx]
components = [Node Int Vrtx] -> [SCC Vrtx]
forall key payload.
Uniquable key =>
[Node key payload] -> [SCC payload]
stronglyConnCompFromEdgedVerticesUniq [Node Int Vrtx]
edges
do_component :: SCC Vrtx -> FCode ()
do_component :: SCC Vrtx -> FCode ()
do_component (AcyclicSCC (Int
_,Stmt
stmt)) = Stmt -> FCode ()
mk_graph Stmt
stmt
do_component (CyclicSCC []) = String -> FCode ()
forall a. HasCallStack => String -> a
panic String
"do_component"
do_component (CyclicSCC [(Int
_,Stmt
stmt)]) = Stmt -> FCode ()
mk_graph Stmt
stmt
do_component (CyclicSCC ((Int
_,Stmt
first_stmt) : [Vrtx]
rest)) = do
u <- FCode Unique
newUnique
let (to_tmp, from_tmp) = split u first_stmt
mk_graph to_tmp
unscramble platform rest
mk_graph from_tmp
split :: Unique -> Stmt -> (Stmt, Stmt)
split :: Unique -> Stmt -> (Stmt, Stmt)
split Unique
uniq (LocalReg
reg, CmmExpr
rhs)
= ((LocalReg
tmp, CmmExpr
rhs), (LocalReg
reg, CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tmp)))
where
rep :: CmmType
rep = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
rhs
tmp :: LocalReg
tmp = Unique -> CmmType -> LocalReg
LocalReg Unique
uniq CmmType
rep
mk_graph :: Stmt -> FCode ()
mk_graph :: Stmt -> FCode ()
mk_graph (LocalReg
reg, CmmExpr
rhs) = CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
rhs
mustFollow :: Stmt -> Stmt -> Bool
(LocalReg
reg, CmmExpr
_) mustFollow :: Stmt -> Stmt -> Bool
`mustFollow` (LocalReg
_, CmmExpr
rhs) = Platform -> CmmReg -> CmmExpr -> Bool
regUsedIn Platform
platform (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
rhs
emitSwitch :: CmmExpr
-> [(ConTagZ, CmmAGraphScoped)]
-> Maybe CmmAGraphScoped
-> ConTagZ -> ConTagZ
-> FCode ()
emitSwitch :: CmmExpr
-> [(Int, CmmAGraphScoped)]
-> Maybe CmmAGraphScoped
-> Int
-> Int
-> FCode ()
emitSwitch CmmExpr
_ [] (Just CmmAGraphScoped
code) Int
_ Int
_ = CmmAGraph -> FCode ()
emit (CmmAGraphScoped -> CmmAGraph
forall a b. (a, b) -> a
fst CmmAGraphScoped
code)
emitSwitch CmmExpr
_ [(Int
_,CmmAGraphScoped
code)] Maybe CmmAGraphScoped
Nothing Int
_ Int
_ = CmmAGraph -> FCode ()
emit (CmmAGraphScoped -> CmmAGraph
forall a b. (a, b) -> a
fst CmmAGraphScoped
code)
emitSwitch CmmExpr
tag_expr [(Int, CmmAGraphScoped)]
branches Maybe CmmAGraphScoped
mb_deflt Int
lo_tag Int
hi_tag = do
join_lbl <- FCode BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
mb_deflt_lbl <- label_default join_lbl mb_deflt
branches_lbls <- label_branches join_lbl branches
tag_expr' <- assignTemp' tag_expr
let branches_lbls' = [ (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i, BlockId
l) | (Int
i,BlockId
l) <- ((Int, BlockId) -> (Int, BlockId) -> Ordering)
-> [(Int, BlockId)] -> [(Int, BlockId)]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (((Int, BlockId) -> Int)
-> (Int, BlockId) -> (Int, BlockId) -> Ordering
forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing (Int, BlockId) -> Int
forall a b. (a, b) -> a
fst) [(Int, BlockId)]
branches_lbls ]
let range = (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lo_tag, Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hi_tag)
emit $ mk_discrete_switch False tag_expr' branches_lbls' mb_deflt_lbl range
emitLabel join_lbl
mk_discrete_switch :: Bool
-> CmmExpr
-> [(Integer, BlockId)]
-> Maybe BlockId
-> (Integer, Integer)
-> CmmAGraph
mk_discrete_switch :: Bool
-> CmmExpr
-> [(Integer, BlockId)]
-> Maybe BlockId
-> (Integer, Integer)
-> CmmAGraph
mk_discrete_switch Bool
_ CmmExpr
_tag_expr [(Integer
tag, BlockId
lbl)] Maybe BlockId
_ (Integer
lo_tag, Integer
hi_tag)
| Integer
lo_tag Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
hi_tag
= Bool -> CmmAGraph -> CmmAGraph
forall a. HasCallStack => Bool -> a -> a
assert (Integer
tag Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
lo_tag) (CmmAGraph -> CmmAGraph) -> CmmAGraph -> CmmAGraph
forall a b. (a -> b) -> a -> b
$
BlockId -> CmmAGraph
mkBranch BlockId
lbl
mk_discrete_switch Bool
_ CmmExpr
_tag_expr [(Integer
_tag,BlockId
lbl)] Maybe BlockId
Nothing (Integer, Integer)
_
= BlockId -> CmmAGraph
mkBranch BlockId
lbl
mk_discrete_switch Bool
signed CmmExpr
tag_expr [(Integer, BlockId)]
branches Maybe BlockId
mb_deflt (Integer, Integer)
range
= CmmExpr -> SwitchTargets -> CmmAGraph
mkSwitch CmmExpr
tag_expr (SwitchTargets -> CmmAGraph) -> SwitchTargets -> CmmAGraph
forall a b. (a -> b) -> a -> b
$ Bool
-> (Integer, Integer)
-> Maybe BlockId
-> Map Integer BlockId
-> SwitchTargets
mkSwitchTargets Bool
signed (Integer, Integer)
range Maybe BlockId
mb_deflt ([(Integer, BlockId)] -> Map Integer BlockId
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList [(Integer, BlockId)]
branches)
divideBranches :: Ord a => [(a,b)] -> ([(a,b)], a, [(a,b)])
divideBranches :: forall a b. Ord a => [(a, b)] -> ([(a, b)], a, [(a, b)])
divideBranches [(a, b)]
branches = ([(a, b)]
lo_branches, a
mid, [(a, b)]
hi_branches)
where
(a
mid,b
_) = [(a, b)]
branches [(a, b)] -> Int -> (a, b)
forall a. HasCallStack => [a] -> Int -> a
!! ([(a, b)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
branches Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
2)
([(a, b)]
lo_branches, [(a, b)]
hi_branches) = ((a, b) -> Bool) -> [(a, b)] -> ([(a, b)], [(a, b)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
span (a, b) -> Bool
is_lo [(a, b)]
branches
is_lo :: (a, b) -> Bool
is_lo (a
t,b
_) = a
t a -> a -> Bool
forall a. Ord a => a -> a -> Bool
< a
mid
emitCmmLitSwitch :: CmmExpr
-> [(Literal, CmmAGraphScoped)]
-> CmmAGraphScoped
-> FCode ()
emitCmmLitSwitch :: CmmExpr
-> [(Literal, CmmAGraphScoped)] -> CmmAGraphScoped -> FCode ()
emitCmmLitSwitch CmmExpr
_scrut [] CmmAGraphScoped
deflt = CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmAGraphScoped -> CmmAGraph
forall a b. (a, b) -> a
fst CmmAGraphScoped
deflt
emitCmmLitSwitch CmmExpr
scrut branches :: [(Literal, CmmAGraphScoped)]
branches@((Literal, CmmAGraphScoped)
branch:[(Literal, CmmAGraphScoped)]
_) CmmAGraphScoped
deflt = do
scrut' <- CmmExpr -> FCode CmmExpr
assignTemp' CmmExpr
scrut
join_lbl <- newBlockId
deflt_lbl <- label_code join_lbl deflt
branches_lbls <- label_branches join_lbl branches
platform <- getPlatform
let cmm_ty = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
scrut
rep = CmmType -> Width
typeWidth CmmType
cmm_ty
let (signed,range) = case branch of
(LitNumber LitNumType
nt Integer
_, CmmAGraphScoped
_) -> (Bool
signed,(Integer, Integer)
range)
where
signed :: Bool
signed = LitNumType -> Bool
litNumIsSigned LitNumType
nt
range :: (Integer, Integer)
range = case Platform -> LitNumType -> (Maybe Integer, Maybe Integer)
litNumRange Platform
platform LitNumType
nt of
(Just Integer
mi, Just Integer
ma) -> (Integer
mi,Integer
ma)
(Maybe Integer, Maybe Integer)
partial_bounds -> String -> SDoc -> (Integer, Integer)
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unexpected unbounded literal range"
((Maybe Integer, Maybe Integer) -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Maybe Integer, Maybe Integer)
partial_bounds)
(Literal, CmmAGraphScoped)
_ -> (Bool
False, (Integer
0, Platform -> Integer
platformMaxWord Platform
platform))
if isFloatType cmm_ty
then emit =<< mk_float_switch rep scrut' deflt_lbl noBound branches_lbls
else emit $ mk_discrete_switch
signed
scrut'
[(litValue lit,l) | (lit,l) <- branches_lbls]
(Just deflt_lbl)
range
emitLabel join_lbl
type LitBound = (Maybe Literal, Maybe Literal)
noBound :: LitBound
noBound :: LitBound
noBound = (Maybe Literal
forall a. Maybe a
Nothing, Maybe Literal
forall a. Maybe a
Nothing)
mk_float_switch :: Width -> CmmExpr -> BlockId
-> LitBound
-> [(Literal,BlockId)]
-> FCode CmmAGraph
mk_float_switch :: Width
-> CmmExpr
-> BlockId
-> LitBound
-> [(Literal, BlockId)]
-> FCode CmmAGraph
mk_float_switch Width
rep CmmExpr
scrut BlockId
deflt LitBound
_bounds [(Literal
lit,BlockId
blk)]
= do platform <- FCode Platform
getPlatform
return $ mkCbranch (cond platform) deflt blk Nothing
where
cond :: Platform -> CmmExpr
cond Platform
platform = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
ne [CmmExpr
scrut, CmmLit -> CmmExpr
CmmLit CmmLit
cmm_lit]
where
cmm_lit :: CmmLit
cmm_lit = Platform -> Literal -> CmmLit
mkSimpleLit Platform
platform Literal
lit
ne :: MachOp
ne = Width -> MachOp
MO_F_Ne Width
rep
mk_float_switch Width
rep CmmExpr
scrut BlockId
deflt_blk_id (Maybe Literal
lo_bound, Maybe Literal
hi_bound) [(Literal, BlockId)]
branches
= do platform <- FCode Platform
getPlatform
lo_blk <- mk_float_switch rep scrut deflt_blk_id bounds_lo lo_branches
hi_blk <- mk_float_switch rep scrut deflt_blk_id bounds_hi hi_branches
mkCmmIfThenElse (cond platform) lo_blk hi_blk
where
([(Literal, BlockId)]
lo_branches, Literal
mid_lit, [(Literal, BlockId)]
hi_branches) = [(Literal, BlockId)]
-> ([(Literal, BlockId)], Literal, [(Literal, BlockId)])
forall a b. Ord a => [(a, b)] -> ([(a, b)], a, [(a, b)])
divideBranches [(Literal, BlockId)]
branches
bounds_lo :: LitBound
bounds_lo = (Maybe Literal
lo_bound, Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
mid_lit)
bounds_hi :: LitBound
bounds_hi = (Literal -> Maybe Literal
forall a. a -> Maybe a
Just Literal
mid_lit, Maybe Literal
hi_bound)
cond :: Platform -> CmmExpr
cond Platform
platform = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
lt [CmmExpr
scrut, CmmLit -> CmmExpr
CmmLit CmmLit
cmm_lit]
where
cmm_lit :: CmmLit
cmm_lit = Platform -> Literal -> CmmLit
mkSimpleLit Platform
platform Literal
mid_lit
lt :: MachOp
lt = Width -> MachOp
MO_F_Lt Width
rep
label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
label_default :: BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
label_default BlockId
_ Maybe CmmAGraphScoped
Nothing
= Maybe BlockId -> FCode (Maybe BlockId)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe BlockId
forall a. Maybe a
Nothing
label_default BlockId
join_lbl (Just CmmAGraphScoped
code)
= do lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl CmmAGraphScoped
code
return (Just lbl)
label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
label_branches :: forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
_join_lbl []
= [(a, BlockId)] -> FCode [(a, BlockId)]
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return []
label_branches BlockId
join_lbl ((a
tag,CmmAGraphScoped
code):[(a, CmmAGraphScoped)]
branches)
= do lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl CmmAGraphScoped
code
branches' <- label_branches join_lbl branches
return ((tag,lbl):branches')
label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl (CmmAGraph
code,CmmTickScope
tsc) = do
lbl <- FCode BlockId
forall (m :: * -> *). MonadGetUnique m => m BlockId
newBlockId
emitOutOfLine lbl (code CmmGraph.<*> mkBranch join_lbl, tsc)
return lbl
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' CmmExpr
e
| CmmExpr -> Bool
isTrivialCmmExpr CmmExpr
e = CmmExpr -> FCode CmmExpr
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return CmmExpr
e
| Bool
otherwise = do
platform <- FCode Platform
getPlatform
lreg <- newTemp (cmmExprType platform e)
let reg = LocalReg -> CmmReg
CmmLocal LocalReg
lreg
emitAssign reg e
return (CmmReg reg)
whenUpdRemSetEnabled :: FCode a -> FCode ()
whenUpdRemSetEnabled :: forall a. FCode a -> FCode ()
whenUpdRemSetEnabled FCode a
code = do
platform <- FCode Platform
getPlatform
do_it <- getCode code
let
enabled = Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ CLabel -> CmmLit
CmmLabel CLabel
mkNonmovingWriteBarrierEnabledLabel)
zero = Platform -> CmmExpr
zeroExpr Platform
platform
is_enabled = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord Platform
platform CmmExpr
enabled CmmExpr
zero
the_if <- mkCmmIfThenElse' is_enabled do_it mkNop (Just False)
emit the_if
emitUpdRemSetPush :: CmmExpr
-> FCode ()
emitUpdRemSetPush :: CmmExpr -> FCode ()
emitUpdRemSetPush CmmExpr
ptr = do
platform <- FCode Platform
getPlatform
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushClosure_")
[(CmmReg $ baseReg platform, AddrHint),
(ptr, AddrHint)]
False
emitUpdRemSetPushThunk :: CmmExpr
-> FCode ()
emitUpdRemSetPushThunk :: CmmExpr -> FCode ()
emitUpdRemSetPushThunk CmmExpr
ptr = do
platform <- FCode Platform
getPlatform
emitRtsCall
rtsUnitId
(fsLit "updateRemembSetPushThunk_")
[(CmmReg $ baseReg platform, AddrHint),
(ptr, AddrHint)]
False
cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt
cmmInfoTableToInfoProvEnt :: Module -> CmmInfoTable -> InfoProvEnt
cmmInfoTableToInfoProvEnt Module
this_mod CmmInfoTable
cmit =
let cl :: CLabel
cl = CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
cmit
cn :: Int
cn = SMRep -> Int
rtsClosureType (CmmInfoTable -> SMRep
cit_rep CmmInfoTable
cmit)
in CLabel
-> Int
-> String
-> Module
-> Maybe (RealSrcSpan, LexicalFastString)
-> InfoProvEnt
InfoProvEnt CLabel
cl Int
cn String
"" Module
this_mod Maybe (RealSrcSpan, LexicalFastString)
forall a. Maybe a
Nothing
data IPEStats = IPEStats { IPEStats -> Int
ipe_total :: !Int
, IPEStats -> IntMap Int
ipe_closure_types :: !(I.IntMap Int)
, IPEStats -> Int
ipe_fallback :: !Int
, IPEStats -> Int
ipe_skipped :: !Int }
instance Semigroup IPEStats where
(IPEStats Int
a1 IntMap Int
a2 Int
a3 Int
a4) <> :: IPEStats -> IPEStats -> IPEStats
<> (IPEStats Int
b1 IntMap Int
b2 Int
b3 Int
b4) = Int -> IntMap Int -> Int -> Int -> IPEStats
IPEStats (Int
a1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b1) ((Int -> Int -> Int) -> IntMap Int -> IntMap Int -> IntMap Int
forall a. (a -> a -> a) -> IntMap a -> IntMap a -> IntMap a
I.unionWith Int -> Int -> Int
forall a. Num a => a -> a -> a
(+) IntMap Int
a2 IntMap Int
b2) (Int
a3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b3) (Int
a4 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
b4)
instance Monoid IPEStats where
mempty :: IPEStats
mempty = Int -> IntMap Int -> Int -> Int -> IPEStats
IPEStats Int
0 IntMap Int
forall a. IntMap a
I.empty Int
0 Int
0
fallbackIpeStats :: IPEStats
fallbackIpeStats :: IPEStats
fallbackIpeStats = IPEStats
forall a. Monoid a => a
mempty { ipe_total = 1, ipe_fallback = 1 }
closureIpeStats :: Int -> IPEStats
closureIpeStats :: Int -> IPEStats
closureIpeStats Int
t = IPEStats
forall a. Monoid a => a
mempty { ipe_total = 1, ipe_closure_types = I.singleton t 1 }
skippedIpeStats :: IPEStats
skippedIpeStats :: IPEStats
skippedIpeStats = IPEStats
forall a. Monoid a => a
mempty { ipe_skipped = 1 }
instance Outputable IPEStats where
ppr :: IPEStats -> SDoc
ppr = IPEStats -> SDoc
pprIPEStats
pprIPEStats :: IPEStats -> SDoc
pprIPEStats :: IPEStats -> SDoc
pprIPEStats (IPEStats{Int
IntMap Int
ipe_total :: IPEStats -> Int
ipe_closure_types :: IPEStats -> IntMap Int
ipe_fallback :: IPEStats -> Int
ipe_skipped :: IPEStats -> Int
ipe_total :: Int
ipe_closure_types :: IntMap Int
ipe_fallback :: Int
ipe_skipped :: Int
..}) =
[SDoc] -> SDoc
forall doc. IsDoc doc => [doc] -> doc
vcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Tables with info:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
ipe_total
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Tables with fallback:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
ipe_fallback
, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Tables skipped:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
ipe_skipped
] [SDoc] -> [SDoc] -> [SDoc]
forall a. [a] -> [a] -> [a]
++ [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"Info(" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
k SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"):" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr Int
n | (Int
k, Int
n) <- IntMap Int -> [(Int, Int)]
forall a. IntMap a -> [(Int, a)]
I.assocs IntMap Int
ipe_closure_types ]
convertInfoProvMap :: StgToCmmConfig -> Module -> InfoTableProvMap -> IPEStats -> [CmmInfoTable] -> (IPEStats, [InfoProvEnt])
convertInfoProvMap :: StgToCmmConfig
-> Module
-> InfoTableProvMap
-> IPEStats
-> [CmmInfoTable]
-> (IPEStats, [InfoProvEnt])
convertInfoProvMap StgToCmmConfig
cfg Module
this_mod (InfoTableProvMap DCMap
dcenv ClosureMap
denv InfoTableToSourceLocationMap
infoTableToSourceLocationMap) IPEStats
initStats [CmmInfoTable]
cmits =
((IPEStats, [InfoProvEnt])
-> CmmInfoTable -> (IPEStats, [InfoProvEnt]))
-> (IPEStats, [InfoProvEnt])
-> [CmmInfoTable]
-> (IPEStats, [InfoProvEnt])
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (IPEStats, [InfoProvEnt])
-> CmmInfoTable -> (IPEStats, [InfoProvEnt])
convertInfoProvMap' (IPEStats
initStats, []) [CmmInfoTable]
cmits
where
convertInfoProvMap' :: (IPEStats, [InfoProvEnt]) -> CmmInfoTable -> (IPEStats, [InfoProvEnt])
convertInfoProvMap' :: (IPEStats, [InfoProvEnt])
-> CmmInfoTable -> (IPEStats, [InfoProvEnt])
convertInfoProvMap' (!IPEStats
stats, [InfoProvEnt]
acc) CmmInfoTable
cmit = do
let
cl :: CLabel
cl = CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
cmit
cn :: Int
cn = SMRep -> Int
rtsClosureType (CmmInfoTable -> SMRep
cit_rep CmmInfoTable
cmit)
tyString :: Outputable a => a -> String
tyString :: forall a. Outputable a => a -> String
tyString = SDocContext -> SDoc -> String
renderWithContext SDocContext
defaultSDocContext (SDoc -> String) -> (a -> SDoc) -> a -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> SDoc
forall a. Outputable a => a -> SDoc
ppr
lookupClosureMap :: Maybe (IPEStats, InfoProvEnt)
lookupClosureMap :: Maybe (IPEStats, InfoProvEnt)
lookupClosureMap = case CLabel -> Maybe Name
hasHaskellName CLabel
cl Maybe Name
-> (Name -> Maybe (Type, Maybe (RealSrcSpan, LexicalFastString)))
-> Maybe (Type, Maybe (RealSrcSpan, LexicalFastString))
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ((Name, (Type, Maybe (RealSrcSpan, LexicalFastString)))
-> (Type, Maybe (RealSrcSpan, LexicalFastString)))
-> Maybe (Name, (Type, Maybe (RealSrcSpan, LexicalFastString)))
-> Maybe (Type, Maybe (RealSrcSpan, LexicalFastString))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name, (Type, Maybe (RealSrcSpan, LexicalFastString)))
-> (Type, Maybe (RealSrcSpan, LexicalFastString))
forall a b. (a, b) -> b
snd (Maybe (Name, (Type, Maybe (RealSrcSpan, LexicalFastString)))
-> Maybe (Type, Maybe (RealSrcSpan, LexicalFastString)))
-> (Name
-> Maybe (Name, (Type, Maybe (RealSrcSpan, LexicalFastString))))
-> Name
-> Maybe (Type, Maybe (RealSrcSpan, LexicalFastString))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClosureMap
-> Name
-> Maybe (Name, (Type, Maybe (RealSrcSpan, LexicalFastString)))
forall key elt.
Uniquable key =>
UniqDFM key elt -> key -> Maybe elt
lookupUDFM ClosureMap
denv of
Just (Type
ty, Maybe (RealSrcSpan, LexicalFastString)
mbspan) -> (IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
forall a. a -> Maybe a
Just (Int -> IPEStats
closureIpeStats Int
cn, (CLabel
-> Int
-> String
-> Module
-> Maybe (RealSrcSpan, LexicalFastString)
-> InfoProvEnt
InfoProvEnt CLabel
cl Int
cn (Type -> String
forall a. Outputable a => a -> String
tyString Type
ty) Module
this_mod Maybe (RealSrcSpan, LexicalFastString)
mbspan))
Maybe (Type, Maybe (RealSrcSpan, LexicalFastString))
Nothing -> Maybe (IPEStats, InfoProvEnt)
forall a. Maybe a
Nothing
lookupDataConMap :: Maybe (IPEStats, InfoProvEnt)
lookupDataConMap :: Maybe (IPEStats, InfoProvEnt)
lookupDataConMap = (Int -> IPEStats
closureIpeStats Int
cn,) (InfoProvEnt -> (IPEStats, InfoProvEnt))
-> Maybe InfoProvEnt -> Maybe (IPEStats, InfoProvEnt)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
UsageSite _ n <- CLabel -> Maybe IdLabelInfo
hasIdLabelInfo CLabel
cl Maybe IdLabelInfo
-> (IdLabelInfo -> Maybe ConInfoTableLocation)
-> Maybe ConInfoTableLocation
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IdLabelInfo -> Maybe ConInfoTableLocation
getConInfoTableLocation
(dc, ns) <- hasHaskellName cl >>= lookupUDFM_Directly dcenv . getUnique
return $ (InfoProvEnt cl cn (tyString (dataConTyCon dc)) this_mod (join $ lookup n (NE.toList ns)))
lookupInfoTableToSourceLocation :: Maybe (IPEStats, InfoProvEnt)
lookupInfoTableToSourceLocation :: Maybe (IPEStats, InfoProvEnt)
lookupInfoTableToSourceLocation = do
sourceNote <- CLabel
-> InfoTableToSourceLocationMap
-> Maybe (Maybe (RealSrcSpan, LexicalFastString))
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup (CmmInfoTable -> CLabel
cit_lbl CmmInfoTable
cmit) InfoTableToSourceLocationMap
infoTableToSourceLocationMap
return $ (closureIpeStats cn, (InfoProvEnt cl cn "" this_mod sourceNote))
simpleFallback :: Maybe (IPEStats, InfoProvEnt)
simpleFallback =
if StgToCmmConfig -> Bool
stgToCmmInfoTableMapWithFallback StgToCmmConfig
cfg then
(IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
forall a. a -> Maybe a
Just (IPEStats
fallbackIpeStats, Module -> CmmInfoTable -> InfoProvEnt
cmmInfoTableToInfoProvEnt Module
this_mod CmmInfoTable
cmit)
else
Maybe (IPEStats, InfoProvEnt)
forall a. Maybe a
Nothing
trackSkipped :: Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])
trackSkipped :: Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])
trackSkipped Maybe (IPEStats, InfoProvEnt)
Nothing =
(IPEStats
stats IPEStats -> IPEStats -> IPEStats
forall a. Semigroup a => a -> a -> a
Data.Semigroup.<> IPEStats
skippedIpeStats, [InfoProvEnt]
acc)
trackSkipped (Just (IPEStats
s, !InfoProvEnt
c)) =
(IPEStats
stats IPEStats -> IPEStats -> IPEStats
forall a. Semigroup a => a -> a -> a
Data.Semigroup.<> IPEStats
s, InfoProvEnt
cInfoProvEnt -> [InfoProvEnt] -> [InfoProvEnt]
forall a. a -> [a] -> [a]
:[InfoProvEnt]
acc)
Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])
trackSkipped (Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt]))
-> Maybe (IPEStats, InfoProvEnt) -> (IPEStats, [InfoProvEnt])
forall a b. (a -> b) -> a -> b
$
if (SMRep -> Bool
isStackRep (SMRep -> Bool) -> (CmmInfoTable -> SMRep) -> CmmInfoTable -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CmmInfoTable -> SMRep
cit_rep) CmmInfoTable
cmit then
Maybe (IPEStats, InfoProvEnt)
-> Maybe (Maybe (IPEStats, InfoProvEnt))
-> Maybe (IPEStats, InfoProvEnt)
forall a. a -> Maybe a -> a
fromMaybe Maybe (IPEStats, InfoProvEnt)
simpleFallback ((IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
forall a. a -> Maybe a
Just ((IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt))
-> Maybe (IPEStats, InfoProvEnt)
-> Maybe (Maybe (IPEStats, InfoProvEnt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (IPEStats, InfoProvEnt)
lookupInfoTableToSourceLocation)
else
Maybe (IPEStats, InfoProvEnt)
-> Maybe (Maybe (IPEStats, InfoProvEnt))
-> Maybe (IPEStats, InfoProvEnt)
forall a. a -> Maybe a -> a
fromMaybe Maybe (IPEStats, InfoProvEnt)
simpleFallback ((IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
forall a. a -> Maybe a
Just ((IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt))
-> Maybe (IPEStats, InfoProvEnt)
-> Maybe (Maybe (IPEStats, InfoProvEnt))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (IPEStats, InfoProvEnt)
-> Maybe (IPEStats, InfoProvEnt) -> Maybe (IPEStats, InfoProvEnt)
forall a. Maybe a -> Maybe a -> Maybe a
firstJust Maybe (IPEStats, InfoProvEnt)
lookupDataConMap Maybe (IPEStats, InfoProvEnt)
lookupClosureMap)