{-# LANGUAGE CPP #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE UndecidableInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
module GHC.Cmm.DebugBlock (
DebugBlock(..),
cmmDebugGen,
cmmDebugLabels,
cmmDebugLink,
debugToMap,
UnwindTable, UnwindPoint(..),
UnwindExpr(..), toUnwindExpr
) where
import GHC.Prelude
import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Data.FastString ( nilFS, mkFastString )
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Cmm.Ppr.Expr ( pprExpr )
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Utils.Misc ( seqList )
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import Data.Maybe
import Data.List ( minimumBy, nubBy )
import Data.Ord ( comparing )
import qualified Data.Map as Map
import Data.Either ( partitionEithers )
data DebugBlock =
DebugBlock
{ DebugBlock -> Label
dblProcedure :: !Label
, DebugBlock -> Label
dblLabel :: !Label
, DebugBlock -> CLabel
dblCLabel :: !CLabel
, DebugBlock -> Bool
dblHasInfoTbl :: !Bool
, DebugBlock -> Maybe DebugBlock
dblParent :: !(Maybe DebugBlock)
, DebugBlock -> [GenTickish 'TickishPassCmm]
dblTicks :: ![CmmTickish]
, DebugBlock -> Maybe (GenTickish 'TickishPassCmm)
dblSourceTick :: !(Maybe CmmTickish)
, DebugBlock -> Maybe Int
dblPosition :: !(Maybe Int)
, DebugBlock -> [UnwindPoint]
dblUnwind :: [UnwindPoint]
, DebugBlock -> [DebugBlock]
dblBlocks :: ![DebugBlock]
}
instance OutputableP env CLabel => OutputableP env DebugBlock where
pdoc :: env -> DebugBlock -> SDoc
pdoc env
env DebugBlock
blk =
(if | DebugBlock -> Label
dblProcedure DebugBlock
blk forall a. Eq a => a -> a -> Bool
== DebugBlock -> Label
dblLabel DebugBlock
blk
-> String -> SDoc
text String
"proc"
| DebugBlock -> Bool
dblHasInfoTbl DebugBlock
blk
-> String -> SDoc
text String
"pp-blk"
| Bool
otherwise
-> String -> SDoc
text String
"blk") SDoc -> SDoc -> SDoc
<+>
forall a. Outputable a => a -> SDoc
ppr (DebugBlock -> Label
dblLabel DebugBlock
blk) SDoc -> SDoc -> SDoc
<+> SDoc -> SDoc
parens (forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env (DebugBlock -> CLabel
dblCLabel DebugBlock
blk)) SDoc -> SDoc -> SDoc
<+>
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
empty forall a. Outputable a => a -> SDoc
ppr (DebugBlock -> Maybe (GenTickish 'TickishPassCmm)
dblSourceTick DebugBlock
blk)) SDoc -> SDoc -> SDoc
<+>
(forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> SDoc
text String
"removed") ((String -> SDoc
text String
"pos " SDoc -> SDoc -> SDoc
<>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Outputable a => a -> SDoc
ppr)
(DebugBlock -> Maybe Int
dblPosition DebugBlock
blk)) SDoc -> SDoc -> SDoc
<+>
(forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env (DebugBlock -> [UnwindPoint]
dblUnwind DebugBlock
blk)) SDoc -> SDoc -> SDoc
$+$
(if forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
blk) then SDoc
empty else Int -> SDoc -> SDoc
nest Int
4 (forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
blk)))
type BlockContext = (CmmBlock, RawCmmDecl)
cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
cmmDebugGen ModLocation
modLoc RawCmmGroup
decls = forall a b. (a -> b) -> [a] -> [b]
map (Maybe (GenTickish 'TickishPassCmm) -> CmmTickScope -> DebugBlock
blocksForScope forall a. Maybe a
Nothing) [CmmTickScope]
topScopes
where
blockCtxs :: Map.Map CmmTickScope [BlockContext]
blockCtxs :: Map CmmTickScope [BlockContext]
blockCtxs = RawCmmGroup -> Map CmmTickScope [BlockContext]
blockContexts RawCmmGroup
decls
([CmmTickScope]
topScopes, [(CmmTickScope, CmmTickScope)]
childScopes)
= forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (\CmmTickScope
a -> forall {t}. t -> CmmTickScope -> Either t (CmmTickScope, t)
findP CmmTickScope
a CmmTickScope
a) forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [k]
Map.keys Map CmmTickScope [BlockContext]
blockCtxs
findP :: t -> CmmTickScope -> Either t (CmmTickScope, t)
findP t
tsc CmmTickScope
GlobalScope = forall a b. a -> Either a b
Left t
tsc
findP t
tsc CmmTickScope
scp | CmmTickScope
scp' forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map CmmTickScope [BlockContext]
blockCtxs = forall a b. b -> Either a b
Right (CmmTickScope
scp', t
tsc)
| Bool
otherwise = t -> CmmTickScope -> Either t (CmmTickScope, t)
findP t
tsc CmmTickScope
scp'
where
scp' :: CmmTickScope
scp' | SubScope Unique
_ CmmTickScope
scp' <- CmmTickScope
scp = CmmTickScope
scp'
| CombinedScope CmmTickScope
scp' CmmTickScope
_ <- CmmTickScope
scp = CmmTickScope
scp'
#if __GLASGOW_HASKELL__ < 901
| otherwise = panic "findP impossible"
#endif
scopeMap :: Map CmmTickScope [CmmTickScope]
scopeMap = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall k a. Ord k => k -> a -> Map k [a] -> Map k [a]
insertMulti) forall k a. Map k a
Map.empty [(CmmTickScope, CmmTickScope)]
childScopes
ticksToCopy :: CmmTickScope -> [CmmTickish]
ticksToCopy :: CmmTickScope -> [GenTickish 'TickishPassCmm]
ticksToCopy (CombinedScope CmmTickScope
scp CmmTickScope
s) = CmmTickScope -> [GenTickish 'TickishPassCmm]
go CmmTickScope
s
where go :: CmmTickScope -> [GenTickish 'TickishPassCmm]
go CmmTickScope
s | CmmTickScope
scp CmmTickScope -> CmmTickScope -> Bool
`isTickSubScope` CmmTickScope
s = []
| SubScope Unique
_ CmmTickScope
s' <- CmmTickScope
s = [GenTickish 'TickishPassCmm]
ticks forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [GenTickish 'TickishPassCmm]
go CmmTickScope
s'
| CombinedScope CmmTickScope
s1 CmmTickScope
s2 <- CmmTickScope
s = [GenTickish 'TickishPassCmm]
ticks forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [GenTickish 'TickishPassCmm]
go CmmTickScope
s1 forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [GenTickish 'TickishPassCmm]
go CmmTickScope
s2
| Bool
otherwise = forall a. String -> a
panic String
"ticksToCopy impossible"
where ticks :: [GenTickish 'TickishPassCmm]
ticks = forall {b}.
[(Block CmmNode C C, b)] -> [GenTickish 'TickishPassCmm]
bCtxsTicks forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CmmTickScope
s Map CmmTickScope [BlockContext]
blockCtxs
ticksToCopy CmmTickScope
_ = []
bCtxsTicks :: [(Block CmmNode C C, b)] -> [GenTickish 'TickishPassCmm]
bCtxsTicks = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Block CmmNode C C -> [GenTickish 'TickishPassCmm]
blockTicks forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst)
bestSrcTick :: [GenTickish 'TickishPassCmm] -> GenTickish 'TickishPassCmm
bestSrcTick = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy (forall a b. Ord a => (b -> a) -> b -> b -> Ordering
comparing GenTickish 'TickishPassCmm -> Int
rangeRating)
rangeRating :: GenTickish 'TickishPassCmm -> Int
rangeRating (SourceNote RealSrcSpan
span String
_)
| RealSrcSpan -> FastString
srcSpanFile RealSrcSpan
span forall a. Eq a => a -> a -> Bool
== FastString
thisFile = Int
1
| Bool
otherwise = Int
2 :: Int
rangeRating GenTickish 'TickishPassCmm
note = forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rangeRating" (forall a. Outputable a => a -> SDoc
ppr GenTickish 'TickishPassCmm
note)
thisFile :: FastString
thisFile = forall b a. b -> (a -> b) -> Maybe a -> b
maybe FastString
nilFS String -> FastString
mkFastString forall a b. (a -> b) -> a -> b
$ ModLocation -> Maybe String
ml_hs_file ModLocation
modLoc
blocksForScope :: Maybe CmmTickish -> CmmTickScope -> DebugBlock
blocksForScope :: Maybe (GenTickish 'TickishPassCmm) -> CmmTickScope -> DebugBlock
blocksForScope Maybe (GenTickish 'TickishPassCmm)
cstick CmmTickScope
scope = Bool -> BlockContext -> DebugBlock
mkBlock Bool
True (forall a. [a] -> a
head [BlockContext]
bctxs)
where bctxs :: [BlockContext]
bctxs = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CmmTickScope
scope Map CmmTickScope [BlockContext]
blockCtxs
nested :: [CmmTickScope]
nested = forall a. a -> Maybe a -> a
fromMaybe [] forall a b. (a -> b) -> a -> b
$ forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CmmTickScope
scope Map CmmTickScope [CmmTickScope]
scopeMap
childs :: [DebugBlock]
childs = forall a b. (a -> b) -> [a] -> [b]
map (Bool -> BlockContext -> DebugBlock
mkBlock Bool
False) (forall a. [a] -> [a]
tail [BlockContext]
bctxs) forall a. [a] -> [a] -> [a]
++
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (GenTickish 'TickishPassCmm) -> CmmTickScope -> DebugBlock
blocksForScope Maybe (GenTickish 'TickishPassCmm)
stick) [CmmTickScope]
nested
mkBlock :: Bool -> BlockContext -> DebugBlock
mkBlock :: Bool -> BlockContext -> DebugBlock
mkBlock Bool
top (Block CmmNode C C
block, RawCmmDecl
prc)
= DebugBlock { dblProcedure :: Label
dblProcedure = forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
graph
, dblLabel :: Label
dblLabel = Label
label
, dblCLabel :: CLabel
dblCLabel = case Maybe RawCmmStatics
info of
Just (CmmStaticsRaw CLabel
infoLbl [CmmStatic]
_) -> CLabel
infoLbl
Maybe RawCmmStatics
Nothing
| forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
graph forall a. Eq a => a -> a -> Bool
== Label
label -> CLabel
entryLbl
| Bool
otherwise -> Label -> CLabel
blockLbl Label
label
, dblHasInfoTbl :: Bool
dblHasInfoTbl = forall a. Maybe a -> Bool
isJust Maybe RawCmmStatics
info
, dblParent :: Maybe DebugBlock
dblParent = forall a. Maybe a
Nothing
, dblTicks :: [GenTickish 'TickishPassCmm]
dblTicks = [GenTickish 'TickishPassCmm]
ticks
, dblPosition :: Maybe Int
dblPosition = forall a. Maybe a
Nothing
, dblSourceTick :: Maybe (GenTickish 'TickishPassCmm)
dblSourceTick = Maybe (GenTickish 'TickishPassCmm)
stick
, dblBlocks :: [DebugBlock]
dblBlocks = [DebugBlock]
blocks
, dblUnwind :: [UnwindPoint]
dblUnwind = []
}
where (CmmProc LabelMap RawCmmStatics
infos CLabel
entryLbl [GlobalReg]
_ CmmGraph
graph) = RawCmmDecl
prc
label :: Label
label = forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
block
info :: Maybe RawCmmStatics
info = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup Label
label LabelMap RawCmmStatics
infos
blocks :: [DebugBlock]
blocks | Bool
top = forall a b. [a] -> b -> b
seqList [DebugBlock]
childs [DebugBlock]
childs
| Bool
otherwise = []
isSourceTick :: GenTickish pass -> Bool
isSourceTick SourceNote {} = Bool
True
isSourceTick GenTickish pass
_ = Bool
False
ticks :: [GenTickish 'TickishPassCmm]
ticks = forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains) forall a b. (a -> b) -> a -> b
$
forall {b}.
[(Block CmmNode C C, b)] -> [GenTickish 'TickishPassCmm]
bCtxsTicks [BlockContext]
bctxs forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [GenTickish 'TickishPassCmm]
ticksToCopy CmmTickScope
scope
stick :: Maybe (GenTickish 'TickishPassCmm)
stick = case forall a. (a -> Bool) -> [a] -> [a]
filter forall {pass :: TickishPass}. GenTickish pass -> Bool
isSourceTick [GenTickish 'TickishPassCmm]
ticks of
[] -> Maybe (GenTickish 'TickishPassCmm)
cstick
[GenTickish 'TickishPassCmm]
sticks -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$! [GenTickish 'TickishPassCmm] -> GenTickish 'TickishPassCmm
bestSrcTick ([GenTickish 'TickishPassCmm]
sticks forall a. [a] -> [a] -> [a]
++ forall a. Maybe a -> [a]
maybeToList Maybe (GenTickish 'TickishPassCmm)
cstick)
blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
blockContexts :: RawCmmGroup -> Map CmmTickScope [BlockContext]
blockContexts RawCmmGroup
decls = forall a b k. (a -> b) -> Map k a -> Map k b
Map.map forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RawCmmDecl
-> Map CmmTickScope [BlockContext]
-> Map CmmTickScope [BlockContext]
walkProc forall k a. Map k a
Map.empty RawCmmGroup
decls
where walkProc :: RawCmmDecl
-> Map.Map CmmTickScope [BlockContext]
-> Map.Map CmmTickScope [BlockContext]
walkProc :: RawCmmDecl
-> Map CmmTickScope [BlockContext]
-> Map CmmTickScope [BlockContext]
walkProc CmmData{} Map CmmTickScope [BlockContext]
m = Map CmmTickScope [BlockContext]
m
walkProc prc :: RawCmmDecl
prc@(CmmProc LabelMap RawCmmStatics
_ CLabel
_ [GlobalReg]
_ CmmGraph
graph) Map CmmTickScope [BlockContext]
m
| forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap (Block CmmNode C C)
blocks = Map CmmTickScope [BlockContext]
m
| Bool
otherwise = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ RawCmmDecl
-> [Block CmmNode C C]
-> (LabelSet, Map CmmTickScope [BlockContext])
-> (LabelSet, Map CmmTickScope [BlockContext])
walkBlock RawCmmDecl
prc [Block CmmNode C C]
entry (LabelSet
emptyLbls, Map CmmTickScope [BlockContext]
m)
where blocks :: LabelMap (Block CmmNode C C)
blocks = CmmGraph -> LabelMap (Block CmmNode C C)
toBlockMap CmmGraph
graph
entry :: [Block CmmNode C C]
entry = [forall {a}. KeyOf LabelMap -> LabelMap a -> a
mapFind (forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry CmmGraph
graph) LabelMap (Block CmmNode C C)
blocks]
emptyLbls :: LabelSet
emptyLbls = forall set. IsSet set => set
setEmpty :: LabelSet
walkBlock :: RawCmmDecl -> [Block CmmNode C C]
-> (LabelSet, Map.Map CmmTickScope [BlockContext])
-> (LabelSet, Map.Map CmmTickScope [BlockContext])
walkBlock :: RawCmmDecl
-> [Block CmmNode C C]
-> (LabelSet, Map CmmTickScope [BlockContext])
-> (LabelSet, Map CmmTickScope [BlockContext])
walkBlock RawCmmDecl
_ [] (LabelSet, Map CmmTickScope [BlockContext])
c = (LabelSet, Map CmmTickScope [BlockContext])
c
walkBlock RawCmmDecl
prc (Block CmmNode C C
block:[Block CmmNode C C]
blocks) (LabelSet
visited, Map CmmTickScope [BlockContext]
m)
| Label
lbl forall set. IsSet set => ElemOf set -> set -> Bool
`setMember` LabelSet
visited
= RawCmmDecl
-> [Block CmmNode C C]
-> (LabelSet, Map CmmTickScope [BlockContext])
-> (LabelSet, Map CmmTickScope [BlockContext])
walkBlock RawCmmDecl
prc [Block CmmNode C C]
blocks (LabelSet
visited, Map CmmTickScope [BlockContext]
m)
| Bool
otherwise
= RawCmmDecl
-> [Block CmmNode C C]
-> (LabelSet, Map CmmTickScope [BlockContext])
-> (LabelSet, Map CmmTickScope [BlockContext])
walkBlock RawCmmDecl
prc [Block CmmNode C C]
blocks forall a b. (a -> b) -> a -> b
$
RawCmmDecl
-> [Block CmmNode C C]
-> (LabelSet, Map CmmTickScope [BlockContext])
-> (LabelSet, Map CmmTickScope [BlockContext])
walkBlock RawCmmDecl
prc [Block CmmNode C C]
succs
(Label
lbl forall set. IsSet set => ElemOf set -> set -> set
`setInsert` LabelSet
visited,
forall k a. Ord k => k -> a -> Map k [a] -> Map k [a]
insertMulti CmmTickScope
scope (Block CmmNode C C
block, RawCmmDecl
prc) Map CmmTickScope [BlockContext]
m)
where CmmEntry Label
lbl CmmTickScope
scope = forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n C x -> n C O
firstNode Block CmmNode C C
block
(CmmProc LabelMap RawCmmStatics
_ CLabel
_ [GlobalReg]
_ CmmGraph
graph) = RawCmmDecl
prc
succs :: [Block CmmNode C C]
succs = forall a b. (a -> b) -> [a] -> [b]
map (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall {a}. KeyOf LabelMap -> LabelMap a -> a
mapFind (CmmGraph -> LabelMap (Block CmmNode C C)
toBlockMap CmmGraph
graph))
(forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors (forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n x C -> n O C
lastNode Block CmmNode C C
block))
mapFind :: KeyOf LabelMap -> LabelMap a -> a
mapFind = forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault (forall a. HasCallStack => String -> a
error String
"contextTree: block not found!")
insertMulti :: Ord k => k -> a -> Map.Map k [a] -> Map.Map k [a]
insertMulti :: forall k a. Ord k => k -> a -> Map k [a] -> Map k [a]
insertMulti k
k a
v = forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (forall a b. a -> b -> a
const (a
vforall a. a -> [a] -> [a]
:)) k
k [a
v]
cmmDebugLabels :: (i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
cmmDebugLabels :: forall i d g.
(i -> Bool) -> GenCmmGroup d g (ListGraph i) -> [Label]
cmmDebugLabels i -> Bool
isMeta GenCmmGroup d g (ListGraph i)
nats = forall a b. [a] -> b -> b
seqList [Label]
lbls [Label]
lbls
where
lbls :: [Label]
lbls = forall a b. (a -> b) -> [a] -> [b]
map forall i. GenBasicBlock i -> Label
blockId forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenBasicBlock i -> Bool
allMeta) forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap forall {d} {h} {i}.
GenCmmDecl d h (ListGraph i) -> [GenBasicBlock i]
getBlocks GenCmmGroup d g (ListGraph i)
nats
getBlocks :: GenCmmDecl d h (ListGraph i) -> [GenBasicBlock i]
getBlocks (CmmProc h
_ CLabel
_ [GlobalReg]
_ (ListGraph [GenBasicBlock i]
bs)) = [GenBasicBlock i]
bs
getBlocks GenCmmDecl d h (ListGraph i)
_other = []
allMeta :: GenBasicBlock i -> Bool
allMeta (BasicBlock Label
_ [i]
instrs) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all i -> Bool
isMeta [i]
instrs
cmmDebugLink :: [Label] -> LabelMap [UnwindPoint]
-> [DebugBlock] -> [DebugBlock]
cmmDebugLink :: [Label] -> LabelMap [UnwindPoint] -> [DebugBlock] -> [DebugBlock]
cmmDebugLink [Label]
labels LabelMap [UnwindPoint]
unwindPts [DebugBlock]
blocks = forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> DebugBlock
link [DebugBlock]
blocks
where blockPos :: LabelMap Int
blockPos :: LabelMap Int
blockPos = forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Label]
labels
link :: DebugBlock -> DebugBlock
link DebugBlock
block = DebugBlock
block { dblPosition :: Maybe Int
dblPosition = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (DebugBlock -> Label
dblLabel DebugBlock
block) LabelMap Int
blockPos
, dblBlocks :: [DebugBlock]
dblBlocks = forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> DebugBlock
link (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
block)
, dblUnwind :: [UnwindPoint]
dblUnwind = forall a. a -> Maybe a -> a
fromMaybe forall a. Monoid a => a
mempty
forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup (DebugBlock -> Label
dblLabel DebugBlock
block) LabelMap [UnwindPoint]
unwindPts
}
debugToMap :: [DebugBlock] -> LabelMap DebugBlock
debugToMap :: [DebugBlock] -> LabelMap DebugBlock
debugToMap = forall (map :: * -> *) a. IsMap map => [map a] -> map a
mapUnions forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall {map :: * -> *}.
(KeyOf map ~ Label, IsMap map) =>
DebugBlock -> map DebugBlock
go
where go :: DebugBlock -> map DebugBlock
go DebugBlock
b = forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (DebugBlock -> Label
dblLabel DebugBlock
b) DebugBlock
b forall a b. (a -> b) -> a -> b
$ forall (map :: * -> *) a. IsMap map => [map a] -> map a
mapUnions forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> map DebugBlock
go (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
b)
data UnwindPoint = UnwindPoint !CLabel !UnwindTable
instance OutputableP env CLabel => OutputableP env UnwindPoint where
pdoc :: env -> UnwindPoint -> SDoc
pdoc env
env (UnwindPoint CLabel
lbl UnwindTable
uws) =
SDoc -> SDoc
braces forall a b. (a -> b) -> a -> b
$ forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env CLabel
lbl SDoc -> SDoc -> SDoc
<> SDoc
colon
SDoc -> SDoc -> SDoc
<+> [SDoc] -> SDoc
hsep (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (GlobalReg, Maybe UnwindExpr) -> SDoc
pprUw forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toList UnwindTable
uws)
where
pprUw :: (GlobalReg, Maybe UnwindExpr) -> SDoc
pprUw (GlobalReg
g, Maybe UnwindExpr
expr) = forall a. Outputable a => a -> SDoc
ppr GlobalReg
g SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'=' SDoc -> SDoc -> SDoc
<> forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env Maybe UnwindExpr
expr
type UnwindTable = Map.Map GlobalReg (Maybe UnwindExpr)
data UnwindExpr = UwConst !Int
| UwReg !GlobalReg !Int
| UwDeref UnwindExpr
| UwLabel CLabel
| UwPlus UnwindExpr UnwindExpr
| UwMinus UnwindExpr UnwindExpr
| UwTimes UnwindExpr UnwindExpr
deriving (UnwindExpr -> UnwindExpr -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnwindExpr -> UnwindExpr -> Bool
$c/= :: UnwindExpr -> UnwindExpr -> Bool
== :: UnwindExpr -> UnwindExpr -> Bool
$c== :: UnwindExpr -> UnwindExpr -> Bool
Eq)
instance OutputableP env CLabel => OutputableP env UnwindExpr where
pdoc :: env -> UnwindExpr -> SDoc
pdoc = forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
0
pprUnwindExpr :: OutputableP env CLabel => Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr :: forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
p env
env = \case
UwConst Int
i -> forall a. Outputable a => a -> SDoc
ppr Int
i
UwReg GlobalReg
g Int
0 -> forall a. Outputable a => a -> SDoc
ppr GlobalReg
g
UwReg GlobalReg
g Int
x -> forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
p env
env (UnwindExpr -> UnwindExpr -> UnwindExpr
UwPlus (GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
g Int
0) (Int -> UnwindExpr
UwConst Int
x))
UwDeref UnwindExpr
e -> Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
3 env
env UnwindExpr
e
UwLabel CLabel
l -> forall env a. OutputableP env a => env -> a -> SDoc
pdoc env
env CLabel
l
UwPlus UnwindExpr
e0 UnwindExpr
e1
| Rational
p forall a. Ord a => a -> a -> Bool
<= Rational
0 -> forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
0 env
env UnwindExpr
e0 SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'+' SDoc -> SDoc -> SDoc
<> forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
0 env
env UnwindExpr
e1
UwMinus UnwindExpr
e0 UnwindExpr
e1
| Rational
p forall a. Ord a => a -> a -> Bool
<= Rational
0 -> forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
1 env
env UnwindExpr
e0 SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'-' SDoc -> SDoc -> SDoc
<> forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
1 env
env UnwindExpr
e1
UwTimes UnwindExpr
e0 UnwindExpr
e1
| Rational
p forall a. Ord a => a -> a -> Bool
<= Rational
1 -> forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
2 env
env UnwindExpr
e0 SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
2 env
env UnwindExpr
e1
UnwindExpr
other -> SDoc -> SDoc
parens (forall env.
OutputableP env CLabel =>
Rational -> env -> UnwindExpr -> SDoc
pprUnwindExpr Rational
0 env
env UnwindExpr
other)
toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
toUnwindExpr Platform
_ (CmmLit (CmmInt Integer
i Width
_)) = Int -> UnwindExpr
UwConst (forall a b. (Integral a, Num b) => a -> b
fromIntegral Integer
i)
toUnwindExpr Platform
_ (CmmLit (CmmLabel CLabel
l)) = CLabel -> UnwindExpr
UwLabel CLabel
l
toUnwindExpr Platform
_ (CmmRegOff (CmmGlobal GlobalReg
g) Int
i) = GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
g Int
i
toUnwindExpr Platform
_ (CmmReg (CmmGlobal GlobalReg
g)) = GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
g Int
0
toUnwindExpr Platform
platform (CmmLoad CmmExpr
e CmmType
_ AlignmentSpec
_) = UnwindExpr -> UnwindExpr
UwDeref (Platform -> CmmExpr -> UnwindExpr
toUnwindExpr Platform
platform CmmExpr
e)
toUnwindExpr Platform
platform e :: CmmExpr
e@(CmmMachOp MachOp
op [CmmExpr
e1, CmmExpr
e2]) =
case (MachOp
op, Platform -> CmmExpr -> UnwindExpr
toUnwindExpr Platform
platform CmmExpr
e1, Platform -> CmmExpr -> UnwindExpr
toUnwindExpr Platform
platform CmmExpr
e2) of
(MO_Add{}, UwReg GlobalReg
r Int
x, UwConst Int
y) -> GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
r (Int
x forall a. Num a => a -> a -> a
+ Int
y)
(MO_Sub{}, UwReg GlobalReg
r Int
x, UwConst Int
y) -> GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
r (Int
x forall a. Num a => a -> a -> a
- Int
y)
(MO_Add{}, UwConst Int
x, UwReg GlobalReg
r Int
y) -> GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
r (Int
x forall a. Num a => a -> a -> a
+ Int
y)
(MO_Add{}, UwConst Int
x, UwConst Int
y) -> Int -> UnwindExpr
UwConst (Int
x forall a. Num a => a -> a -> a
+ Int
y)
(MO_Sub{}, UwConst Int
x, UwConst Int
y) -> Int -> UnwindExpr
UwConst (Int
x forall a. Num a => a -> a -> a
- Int
y)
(MO_Mul{}, UwConst Int
x, UwConst Int
y) -> Int -> UnwindExpr
UwConst (Int
x forall a. Num a => a -> a -> a
* Int
y)
(MO_Add{}, UnwindExpr
u1, UnwindExpr
u2 ) -> UnwindExpr -> UnwindExpr -> UnwindExpr
UwPlus UnwindExpr
u1 UnwindExpr
u2
(MO_Sub{}, UnwindExpr
u1, UnwindExpr
u2 ) -> UnwindExpr -> UnwindExpr -> UnwindExpr
UwMinus UnwindExpr
u1 UnwindExpr
u2
(MO_Mul{}, UnwindExpr
u1, UnwindExpr
u2 ) -> UnwindExpr -> UnwindExpr -> UnwindExpr
UwTimes UnwindExpr
u1 UnwindExpr
u2
(MachOp, UnwindExpr, UnwindExpr)
_otherwise -> forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unsupported operator in unwind expression!"
(Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
e)
toUnwindExpr Platform
platform CmmExpr
e
= forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unsupported unwind expression!" (forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
e)