{-# LANGUAGE CPP #-}
{-# LANGUAGE LambdaCase #-}
module GHC.StgToCmm.Utils (
cgLit, mkSimpleLit,
emitDataLits, emitRODataLits,
emitDataCon,
emitRtsCall, emitRtsCallWithResult, emitRtsCallGen,
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,
newStringCLit, newByteStringCLit,
whenUpdRemSetEnabled,
emitUpdRemSetPush,
emitUpdRemSetPushThunk,
convertInfoProvMap, cmmInfoTableToInfoProvEnt
) where
#include "HsVersions.h"
import GHC.Prelude
import GHC.Platform
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Closure
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 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.Types.Unique.Supply (MonadUnique(..))
import GHC.Driver.Session
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 Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as BS8
import qualified Data.Map as M
import Data.Char
import Data.List (sortBy)
import Data.Ord
import GHC.Types.Unique.Map
import Data.Maybe
import GHC.Driver.Ppr
import qualified Data.List.NonEmpty as NE
import GHC.Core.DataCon
import GHC.Types.Unique.FM
import GHC.Data.Maybe
import Control.Monad
cgLit :: Literal -> FCode CmmLit
cgLit :: Literal -> FCode CmmLit
cgLit (LitString ByteString
s) = ByteString -> FCode CmmLit
newByteStringCLit ByteString
s
cgLit Literal
other_lit = do Platform
platform <- FCode Platform
getPlatform
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> Literal -> CmmLit
mkSimpleLit Platform
platform Literal
other_lit)
mkSimpleLit :: Platform -> Literal -> CmmLit
mkSimpleLit :: Platform -> Literal -> CmmLit
mkSimpleLit Platform
platform = \case
(LitChar Char
c) -> Integer -> Width -> CmmLit
CmmInt (forall a b. (Integral a, Num b) => a -> b
fromIntegral (Char -> Int
ord Char
c))
(Platform -> Width
wordWidth Platform
platform)
Literal
LitNullAddr -> Platform -> CmmLit
zeroCLit Platform
platform
(LitNumber LitNumType
LitNumInt Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i (Platform -> Width
wordWidth Platform
platform)
(LitNumber LitNumType
LitNumInt8 Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i Width
W8
(LitNumber LitNumType
LitNumInt16 Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i Width
W16
(LitNumber LitNumType
LitNumInt32 Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i Width
W32
(LitNumber LitNumType
LitNumInt64 Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i Width
W64
(LitNumber LitNumType
LitNumWord Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i (Platform -> Width
wordWidth Platform
platform)
(LitNumber LitNumType
LitNumWord8 Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i Width
W8
(LitNumber LitNumType
LitNumWord16 Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i Width
W16
(LitNumber LitNumType
LitNumWord32 Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i Width
W32
(LitNumber LitNumType
LitNumWord64 Integer
i) -> Integer -> Width -> CmmLit
CmmInt Integer
i Width
W64
(LitFloat Rational
r) -> Rational -> Width -> CmmLit
CmmFloat Rational
r Width
W32
(LitDouble Rational
r) -> Rational -> Width -> CmmLit
CmmFloat Rational
r Width
W64
(LitLabel FastString
fs Maybe Int
ms FunctionOrData
fod)
-> let
labelSrc :: ForeignLabelSource
labelSrc = ForeignLabelSource
ForeignLabelInThisPackage
in CLabel -> CmmLit
CmmLabel (FastString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel FastString
fs Maybe Int
ms ForeignLabelSource
labelSrc FunctionOrData
fod)
Literal
other -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"mkSimpleLit" (forall a. Outputable a => a -> SDoc
ppr Literal
other)
addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl :: CmmType -> CLabel -> Int -> CmmAGraph
addToMemLbl CmmType
rep CLabel
lbl Int
n = CmmType -> CmmExpr -> Int -> CmmAGraph
addToMem CmmType
rep (CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel CLabel
lbl)) Int
n
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 (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])
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 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
emitRtsCall :: UnitId -> FastString -> [(CmmExpr,ForeignHint)] -> Bool -> FCode ()
emitRtsCall :: UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall UnitId
pkg FastString
fun [(CmmExpr, ForeignHint)]
args Bool
safe = [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [] (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
pkg FastString
fun) [(CmmExpr, ForeignHint)]
args Bool
safe
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 FastString
fun [(CmmExpr, ForeignHint)]
args Bool
safe
= [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [(LocalReg
res,ForeignHint
hint)] (UnitId -> FastString -> CLabel
mkCmmCodeLabel UnitId
pkg FastString
fun) [(CmmExpr, ForeignHint)]
args Bool
safe
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
platform <- DynFlags -> Platform
targetPlatform forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Int
updfr_off <- FCode Int
getUpdFrameOff
; let (CmmAGraph
caller_save, CmmAGraph
caller_load) = Platform -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs Platform
platform
; CmmAGraph -> FCode ()
emit CmmAGraph
caller_save
; Int -> FCode ()
call Int
updfr_off
; CmmAGraph -> FCode ()
emit CmmAGraph
caller_load }
where
call :: Int -> FCode ()
call Int
updfr_off =
if Bool
safe then
CmmAGraph -> FCode ()
emit 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 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) = forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
args
([LocalReg]
res', [ForeignHint]
res_hints) = 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 (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 (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 = 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
= CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Platform -> GlobalReg -> CmmExpr
get_GlobalReg_addr Platform
platform GlobalReg
reg) (CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
reg))
callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph
callerRestoreGlobalReg :: Platform -> GlobalReg -> CmmAGraph
callerRestoreGlobalReg Platform
platform GlobalReg
reg
= CmmReg -> CmmExpr -> CmmAGraph
mkAssign (GlobalReg -> CmmReg
CmmGlobal GlobalReg
reg)
(CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> GlobalReg -> CmmExpr
get_GlobalReg_addr Platform
platform GlobalReg
reg)
(Platform -> GlobalReg -> CmmType
globalRegType Platform
platform GlobalReg
reg)
AlignmentSpec
NaturallyAligned)
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
emitDataLits :: CLabel -> [CmmLit] -> FCode ()
emitDataLits CLabel
lbl [CmmLit]
lits = CmmDecl -> FCode ()
emitDecl (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 = CmmDecl -> FCode ()
emitDecl (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 =
CmmDecl -> FCode ()
emitDecl (forall d h g. Section -> d -> GenCmmDecl d h g
CmmData (SectionType -> CLabel -> Section
Section SectionType
Data CLabel
lbl) (CLabel
-> CmmInfoTable
-> CostCentreStack
-> [CmmLit]
-> GenCmmStatics 'False
CmmStatics CLabel
lbl CmmInfoTable
itbl CostCentreStack
ccs [CmmLit]
payload))
newStringCLit :: String -> FCode CmmLit
newStringCLit :: String -> FCode CmmLit
newStringCLit String
str = ByteString -> FCode CmmLit
newByteStringCLit (String -> ByteString
BS8.pack String
str)
newByteStringCLit :: ByteString -> FCode CmmLit
newByteStringCLit :: ByteString -> FCode CmmLit
newByteStringCLit ByteString
bytes
= do { Unique
uniq <- FCode Unique
newUnique
; let (CmmLit
lit, CmmDecl
decl) = forall (raw :: Bool) info stmt.
CLabel
-> ByteString -> (CmmLit, GenCmmDecl (GenCmmStatics raw) info stmt)
mkByteStringCLit (Unique -> CLabel
mkStringLitLabel Unique
uniq) ByteString
bytes
; CmmDecl -> FCode ()
emitDecl CmmDecl
decl
; forall (m :: * -> *) a. Monad m => a -> m a
return CmmLit
lit }
assignTemp :: CmmExpr -> FCode LocalReg
assignTemp :: CmmExpr -> FCode LocalReg
assignTemp (CmmReg (CmmLocal LocalReg
reg)) = forall (m :: * -> *) a. Monad m => a -> m a
return LocalReg
reg
assignTemp CmmExpr
e = do { Platform
platform <- FCode Platform
getPlatform
; LocalReg
reg <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
e)
; CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
e
; forall (m :: * -> *) a. Monad m => a -> m a
return LocalReg
reg }
newTemp :: MonadUnique m => CmmType -> m LocalReg
newTemp :: forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp CmmType
rep = do { Unique
uniq <- forall (m :: * -> *). MonadUnique m => m Unique
getUniqueM
; forall (m :: * -> *) a. Monad m => a -> m a
return (Unique -> CmmType -> LocalReg
LocalReg Unique
uniq CmmType
rep) }
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs :: Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs Type
res_ty
= ASSERT( isUnboxedTupleType res_ty )
do { Platform
platform <- FCode Platform
getPlatform
; Sequel
sequel <- FCode Sequel
getSequel
; [LocalReg]
regs <- Platform -> Sequel -> FCode [LocalReg]
choose_regs Platform
platform Sequel
sequel
; ASSERT( regs `equalLength` reps )
forall (m :: * -> *) a. Monad m => a -> m a
return ([LocalReg]
regs, forall a b. (a -> b) -> [a] -> [b]
map PrimRep -> ForeignHint
primRepForeignHint [PrimRep]
reps) }
where
reps :: [PrimRep]
reps = HasDebugCallStack => Type -> [PrimRep]
typePrimRep Type
res_ty
choose_regs :: Platform -> Sequel -> FCode [LocalReg]
choose_regs Platform
_ (AssignTo [LocalReg]
regs Bool
_) = forall (m :: * -> *) a. Monad m => a -> m a
return [LocalReg]
regs
choose_regs Platform
platform Sequel
_ = forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp 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 [] [] = 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
platform <- FCode Platform
getPlatform
ASSERT2( equalLength regs rhss, ppr regs $$ pdoc platform rhss )
Platform -> [Vrtx] -> FCode ()
unscramble Platform
platform ([Int
1..] forall a b. [a] -> [b] -> [(a, b)]
`zip` ([LocalReg]
regs forall a b. [a] -> [b] -> [(a, b)]
`zip` [CmmExpr]
rhss))
unscramble :: Platform -> [Vrtx] -> FCode ()
unscramble :: Platform -> [Vrtx] -> FCode ()
unscramble Platform
platform [Vrtx]
vertices = 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 = [ forall key payload. payload -> key -> [key] -> Node key payload
DigraphNode Vrtx
vertex Int
key1 ((LocalReg, CmmExpr) -> [Int]
edges_from (LocalReg, CmmExpr)
stmt1)
| vertex :: Vrtx
vertex@(Int
key1, (LocalReg, CmmExpr)
stmt1) <- [Vrtx]
vertices ]
edges_from :: Stmt -> [Key]
edges_from :: (LocalReg, CmmExpr) -> [Int]
edges_from (LocalReg, CmmExpr)
stmt1 = [ Int
key2 | (Int
key2, (LocalReg, CmmExpr)
stmt2) <- [Vrtx]
vertices,
(LocalReg, CmmExpr)
stmt1 (LocalReg, CmmExpr) -> (LocalReg, CmmExpr) -> Bool
`mustFollow` (LocalReg, CmmExpr)
stmt2 ]
components :: [SCC Vrtx]
components :: [SCC Vrtx]
components = 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
_,(LocalReg, CmmExpr)
stmt)) = (LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg, CmmExpr)
stmt
do_component (CyclicSCC []) = forall a. String -> a
panic String
"do_component"
do_component (CyclicSCC [(Int
_,(LocalReg, CmmExpr)
stmt)]) = (LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg, CmmExpr)
stmt
do_component (CyclicSCC ((Int
_,(LocalReg, CmmExpr)
first_stmt) : [Vrtx]
rest)) = do
Unique
u <- FCode Unique
newUnique
let ((LocalReg, CmmExpr)
to_tmp, (LocalReg, CmmExpr)
from_tmp) = Unique
-> (LocalReg, CmmExpr)
-> ((LocalReg, CmmExpr), (LocalReg, CmmExpr))
split Unique
u (LocalReg, CmmExpr)
first_stmt
(LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg, CmmExpr)
to_tmp
Platform -> [Vrtx] -> FCode ()
unscramble Platform
platform [Vrtx]
rest
(LocalReg, CmmExpr) -> FCode ()
mk_graph (LocalReg, CmmExpr)
from_tmp
split :: Unique -> Stmt -> (Stmt, Stmt)
split :: Unique
-> (LocalReg, CmmExpr)
-> ((LocalReg, CmmExpr), (LocalReg, CmmExpr))
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 :: (LocalReg, CmmExpr) -> 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 :: (LocalReg, CmmExpr) -> (LocalReg, CmmExpr) -> 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 (forall a b. (a, b) -> a
fst CmmAGraphScoped
code)
emitSwitch CmmExpr
_ [(Int
_,CmmAGraphScoped
code)] Maybe CmmAGraphScoped
Nothing Int
_ Int
_ = CmmAGraph -> FCode ()
emit (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
BlockId
join_lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
Maybe BlockId
mb_deflt_lbl <- BlockId -> Maybe CmmAGraphScoped -> FCode (Maybe BlockId)
label_default BlockId
join_lbl Maybe CmmAGraphScoped
mb_deflt
[(Int, BlockId)]
branches_lbls <- forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
join_lbl [(Int, CmmAGraphScoped)]
branches
CmmExpr
tag_expr' <- CmmExpr -> FCode CmmExpr
assignTemp' CmmExpr
tag_expr
let branches_lbls' :: [(Integer, BlockId)]
branches_lbls' = [ (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i, BlockId
l) | (Int
i,BlockId
l) <- forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing forall a b. (a, b) -> a
fst) [(Int, BlockId)]
branches_lbls ]
let range :: (Integer, Integer)
range = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
lo_tag, forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
hi_tag)
CmmAGraph -> FCode ()
emit forall a b. (a -> b) -> a -> b
$ Bool
-> CmmExpr
-> [(Integer, BlockId)]
-> Maybe BlockId
-> (Integer, Integer)
-> CmmAGraph
mk_discrete_switch Bool
False CmmExpr
tag_expr' [(Integer, BlockId)]
branches_lbls' Maybe BlockId
mb_deflt_lbl (Integer, Integer)
range
BlockId -> FCode ()
emitLabel BlockId
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 forall a. Eq a => a -> a -> Bool
== Integer
hi_tag
= ASSERT( tag == lo_tag )
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 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 (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 forall a. [a] -> Int -> a
!! (forall (t :: * -> *) a. Foldable t => t a -> Int
length [(a, b)]
branches forall a. Integral a => a -> a -> a
`div` Int
2)
([(a, b)]
lo_branches, [(a, b)]
hi_branches) = 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 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 forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst CmmAGraphScoped
deflt
emitCmmLitSwitch CmmExpr
scrut [(Literal, CmmAGraphScoped)]
branches CmmAGraphScoped
deflt = do
CmmExpr
scrut' <- CmmExpr -> FCode CmmExpr
assignTemp' CmmExpr
scrut
BlockId
join_lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId
deflt_lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl CmmAGraphScoped
deflt
[(Literal, BlockId)]
branches_lbls <- forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
join_lbl [(Literal, CmmAGraphScoped)]
branches
Platform
platform <- FCode Platform
getPlatform
let cmm_ty :: CmmType
cmm_ty = Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
scrut
rep :: Width
rep = CmmType -> Width
typeWidth CmmType
cmm_ty
let signed :: Bool
signed = case forall a. [a] -> a
head [(Literal, CmmAGraphScoped)]
branches of
(LitNumber LitNumType
nt Integer
_, CmmAGraphScoped
_) -> LitNumType -> Bool
litNumIsSigned LitNumType
nt
(Literal, CmmAGraphScoped)
_ -> Bool
False
let range :: (Integer, Integer)
range | Bool
signed = (Platform -> Integer
platformMinInt Platform
platform, Platform -> Integer
platformMaxInt Platform
platform)
| Bool
otherwise = (Integer
0, Platform -> Integer
platformMaxWord Platform
platform)
if CmmType -> Bool
isFloatType CmmType
cmm_ty
then CmmAGraph -> FCode ()
emit forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Width
-> CmmExpr
-> BlockId
-> LitBound
-> [(Literal, BlockId)]
-> FCode CmmAGraph
mk_float_switch Width
rep CmmExpr
scrut' BlockId
deflt_lbl LitBound
noBound [(Literal, BlockId)]
branches_lbls
else CmmAGraph -> FCode ()
emit forall a b. (a -> b) -> a -> b
$ Bool
-> CmmExpr
-> [(Integer, BlockId)]
-> Maybe BlockId
-> (Integer, Integer)
-> CmmAGraph
mk_discrete_switch
Bool
signed
CmmExpr
scrut'
[(Literal -> Integer
litValue Literal
lit,BlockId
l) | (Literal
lit,BlockId
l) <- [(Literal, BlockId)]
branches_lbls]
(forall a. a -> Maybe a
Just BlockId
deflt_lbl)
(Integer, Integer)
range
BlockId -> FCode ()
emitLabel BlockId
join_lbl
type LitBound = (Maybe Literal, Maybe Literal)
noBound :: LitBound
noBound :: LitBound
noBound = (forall a. Maybe a
Nothing, 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
platform <- FCode Platform
getPlatform
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch (Platform -> CmmExpr
cond Platform
platform) BlockId
deflt BlockId
blk forall a. Maybe a
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
platform <- FCode Platform
getPlatform
CmmAGraph
lo_blk <- Width
-> CmmExpr
-> BlockId
-> LitBound
-> [(Literal, BlockId)]
-> FCode CmmAGraph
mk_float_switch Width
rep CmmExpr
scrut BlockId
deflt_blk_id LitBound
bounds_lo [(Literal, BlockId)]
lo_branches
CmmAGraph
hi_blk <- Width
-> CmmExpr
-> BlockId
-> LitBound
-> [(Literal, BlockId)]
-> FCode CmmAGraph
mk_float_switch Width
rep CmmExpr
scrut BlockId
deflt_blk_id LitBound
bounds_hi [(Literal, BlockId)]
hi_branches
CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse (Platform -> CmmExpr
cond Platform
platform) CmmAGraph
lo_blk CmmAGraph
hi_blk
where
([(Literal, BlockId)]
lo_branches, Literal
mid_lit, [(Literal, BlockId)]
hi_branches) = 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, forall a. a -> Maybe a
Just Literal
mid_lit)
bounds_hi :: LitBound
bounds_hi = (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
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
label_default BlockId
join_lbl (Just CmmAGraphScoped
code)
= do BlockId
lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl CmmAGraphScoped
code
forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just BlockId
lbl)
label_branches :: BlockId -> [(a,CmmAGraphScoped)] -> FCode [(a,BlockId)]
label_branches :: forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
_join_lbl []
= forall (m :: * -> *) a. Monad m => a -> m a
return []
label_branches BlockId
join_lbl ((a
tag,CmmAGraphScoped
code):[(a, CmmAGraphScoped)]
branches)
= do BlockId
lbl <- BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl CmmAGraphScoped
code
[(a, BlockId)]
branches' <- forall a. BlockId -> [(a, CmmAGraphScoped)] -> FCode [(a, BlockId)]
label_branches BlockId
join_lbl [(a, CmmAGraphScoped)]
branches
forall (m :: * -> *) a. Monad m => a -> m a
return ((a
tag,BlockId
lbl)forall a. a -> [a] -> [a]
:[(a, BlockId)]
branches')
label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
label_code :: BlockId -> CmmAGraphScoped -> FCode BlockId
label_code BlockId
join_lbl (CmmAGraph
code,CmmTickScope
tsc) = do
BlockId
lbl <- forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine BlockId
lbl (CmmAGraph
code CmmAGraph -> CmmAGraph -> CmmAGraph
CmmGraph.<*> BlockId -> CmmAGraph
mkBranch BlockId
join_lbl, CmmTickScope
tsc)
forall (m :: * -> *) a. Monad m => a -> m a
return BlockId
lbl
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' :: CmmExpr -> FCode CmmExpr
assignTemp' CmmExpr
e
| CmmExpr -> Bool
isTrivialCmmExpr CmmExpr
e = forall (m :: * -> *) a. Monad m => a -> m a
return CmmExpr
e
| Bool
otherwise = do
Platform
platform <- FCode Platform
getPlatform
LocalReg
lreg <- forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
e)
let reg :: CmmReg
reg = LocalReg -> CmmReg
CmmLocal LocalReg
lreg
CmmReg -> CmmExpr -> FCode ()
emitAssign CmmReg
reg CmmExpr
e
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmReg -> CmmExpr
CmmReg CmmReg
reg)
whenUpdRemSetEnabled :: FCode a -> FCode ()
whenUpdRemSetEnabled :: forall a. FCode a -> FCode ()
whenUpdRemSetEnabled FCode a
code = do
Platform
platform <- FCode Platform
getPlatform
CmmAGraph
do_it <- forall a. FCode a -> FCode CmmAGraph
getCode FCode a
code
let
enabled :: CmmExpr
enabled = Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform (CmmLit -> CmmExpr
CmmLit forall a b. (a -> b) -> a -> b
$ CLabel -> CmmLit
CmmLabel CLabel
mkNonmovingWriteBarrierEnabledLabel)
zero :: CmmExpr
zero = Platform -> CmmExpr
zeroExpr Platform
platform
is_enabled :: CmmExpr
is_enabled = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord Platform
platform CmmExpr
enabled CmmExpr
zero
CmmAGraph
the_if <- CmmExpr -> CmmAGraph -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThenElse' CmmExpr
is_enabled CmmAGraph
do_it CmmAGraph
mkNop (forall a. a -> Maybe a
Just Bool
False)
CmmAGraph -> FCode ()
emit CmmAGraph
the_if
emitUpdRemSetPush :: CmmExpr
-> FCode ()
emitUpdRemSetPush :: CmmExpr -> FCode ()
emitUpdRemSetPush CmmExpr
ptr =
UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall
UnitId
rtsUnitId
(String -> FastString
fsLit String
"updateRemembSetPushClosure_")
[(CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
BaseReg), ForeignHint
AddrHint),
(CmmExpr
ptr, ForeignHint
AddrHint)]
Bool
False
emitUpdRemSetPushThunk :: CmmExpr
-> FCode ()
emitUpdRemSetPushThunk :: CmmExpr -> FCode ()
emitUpdRemSetPushThunk CmmExpr
ptr =
UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall
UnitId
rtsUnitId
(String -> FastString
fsLit String
"updateRemembSetPushThunk_")
[(CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
BaseReg), ForeignHint
AddrHint),
(CmmExpr
ptr, ForeignHint
AddrHint)]
Bool
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, String)
-> InfoProvEnt
InfoProvEnt CLabel
cl Int
cn String
"" Module
this_mod forall a. Maybe a
Nothing
convertInfoProvMap :: DynFlags -> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]
convertInfoProvMap :: DynFlags
-> [CmmInfoTable] -> Module -> InfoTableProvMap -> [InfoProvEnt]
convertInfoProvMap DynFlags
dflags [CmmInfoTable]
defns Module
this_mod (InfoTableProvMap (UniqMap UniqFM
DataCon (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String)))
dcenv) ClosureMap
denv) =
forall a b. (a -> b) -> [a] -> [b]
map (\CmmInfoTable
cmit ->
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 a
t = forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags a
t
lookupClosureMap :: Maybe InfoProvEnt
lookupClosureMap :: Maybe InfoProvEnt
lookupClosureMap = case CLabel -> Maybe Name
hasHaskellName CLabel
cl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall k a. Uniquable k => UniqMap k a -> k -> Maybe a
lookupUniqMap ClosureMap
denv of
Just (Type
ty, Maybe (RealSrcSpan, String)
mbspan) -> forall a. a -> Maybe a
Just (CLabel
-> Int
-> String
-> Module
-> Maybe (RealSrcSpan, String)
-> InfoProvEnt
InfoProvEnt CLabel
cl Int
cn (forall a. Outputable a => a -> String
tyString Type
ty) Module
this_mod Maybe (RealSrcSpan, String)
mbspan)
Maybe (Type, Maybe (RealSrcSpan, String))
Nothing -> forall a. Maybe a
Nothing
lookupDataConMap :: Maybe InfoProvEnt
lookupDataConMap = do
UsageSite Module
_ Int
n <- CLabel -> Maybe IdLabelInfo
hasIdLabelInfo CLabel
cl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= IdLabelInfo -> Maybe ConInfoTableLocation
getConInfoTableLocation
(DataCon
dc, NonEmpty (Int, Maybe (RealSrcSpan, String))
ns) <- (CLabel -> Maybe Name
hasHaskellName CLabel
cl forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall key elt. UniqFM key elt -> Unique -> Maybe elt
lookupUFM_Directly UniqFM
DataCon (DataCon, NonEmpty (Int, Maybe (RealSrcSpan, String)))
dcenv forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Uniquable a => a -> Unique
getUnique)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ CLabel
-> Int
-> String
-> Module
-> Maybe (RealSrcSpan, String)
-> InfoProvEnt
InfoProvEnt CLabel
cl Int
cn (forall a. Outputable a => a -> String
tyString (DataCon -> TyCon
dataConTyCon DataCon
dc)) Module
this_mod (forall (m :: * -> *) a. Monad m => m (m a) -> m a
join forall a b. (a -> b) -> a -> b
$ forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Int
n (forall a. NonEmpty a -> [a]
NE.toList NonEmpty (Int, Maybe (RealSrcSpan, String))
ns))
simpleFallback :: InfoProvEnt
simpleFallback = Module -> CmmInfoTable -> InfoProvEnt
cmmInfoTableToInfoProvEnt Module
this_mod CmmInfoTable
cmit
in forall a. a -> Maybe a -> a
fromMaybe InfoProvEnt
simpleFallback (Maybe InfoProvEnt
lookupDataConMap forall a. Maybe a -> Maybe a -> Maybe a
`firstJust` Maybe InfoProvEnt
lookupClosureMap)) [CmmInfoTable]
defns