{-# 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,
pprUnwindTable
) where
import GHC.Prelude
import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
import GHC.Cmm.Reg ( pprGlobalReg )
import GHC.Cmm.Utils
import GHC.Data.FastString ( nilFS, mkFastString )
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Utils.Panic
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 Platform DebugBlock where
pdoc :: Platform -> DebugBlock -> SDoc
pdoc Platform
env DebugBlock
blk =
(if | DebugBlock -> Label
dblProcedure DebugBlock
blk Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== DebugBlock -> Label
dblLabel DebugBlock
blk
-> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"proc"
| DebugBlock -> Bool
dblHasInfoTbl DebugBlock
blk
-> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"pp-blk"
| Bool
otherwise
-> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"blk") SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
Label -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DebugBlock -> Label
dblLabel DebugBlock
blk) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
env (DebugBlock -> CLabel
dblCLabel DebugBlock
blk)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
(SDoc
-> (GenTickish 'TickishPassCmm -> SDoc)
-> Maybe (GenTickish 'TickishPassCmm)
-> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe SDoc
forall doc. IsOutput doc => doc
empty GenTickish 'TickishPassCmm -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DebugBlock -> Maybe (GenTickish 'TickishPassCmm)
dblSourceTick DebugBlock
blk)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
(SDoc -> (Int -> SDoc) -> Maybe Int -> SDoc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"removed") ((String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"pos " SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<>) (SDoc -> SDoc) -> (Int -> SDoc) -> Int -> SDoc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SDoc
forall a. Outputable a => a -> SDoc
ppr)
(DebugBlock -> Maybe Int
dblPosition DebugBlock
blk)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
(Platform -> [UnwindPoint] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
env (DebugBlock -> [UnwindPoint]
dblUnwind DebugBlock
blk)) SDoc -> SDoc -> SDoc
$+$
(if [DebugBlock] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
blk) then SDoc
forall doc. IsOutput doc => doc
empty else Int -> SDoc -> SDoc
nest Int
4 (Platform -> [DebugBlock] -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
env (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
blk)))
type BlockContext = (CmmBlock, RawCmmDecl)
cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
cmmDebugGen :: ModLocation -> RawCmmGroup -> [DebugBlock]
cmmDebugGen ModLocation
modLoc RawCmmGroup
decls = (CmmTickScope -> DebugBlock) -> [CmmTickScope] -> [DebugBlock]
forall a b. (a -> b) -> [a] -> [b]
map (Maybe (GenTickish 'TickishPassCmm) -> CmmTickScope -> DebugBlock
blocksForScope Maybe (GenTickish 'TickishPassCmm)
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)
= [Either CmmTickScope (CmmTickScope, CmmTickScope)]
-> ([CmmTickScope], [(CmmTickScope, CmmTickScope)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either CmmTickScope (CmmTickScope, CmmTickScope)]
-> ([CmmTickScope], [(CmmTickScope, CmmTickScope)]))
-> [Either CmmTickScope (CmmTickScope, CmmTickScope)]
-> ([CmmTickScope], [(CmmTickScope, CmmTickScope)])
forall a b. (a -> b) -> a -> b
$ (CmmTickScope -> Either CmmTickScope (CmmTickScope, CmmTickScope))
-> [CmmTickScope]
-> [Either CmmTickScope (CmmTickScope, CmmTickScope)]
forall a b. (a -> b) -> [a] -> [b]
map (\CmmTickScope
a -> CmmTickScope
-> CmmTickScope -> Either CmmTickScope (CmmTickScope, CmmTickScope)
forall {t}. t -> CmmTickScope -> Either t (CmmTickScope, t)
findP CmmTickScope
a CmmTickScope
a) ([CmmTickScope]
-> [Either CmmTickScope (CmmTickScope, CmmTickScope)])
-> [CmmTickScope]
-> [Either CmmTickScope (CmmTickScope, CmmTickScope)]
forall a b. (a -> b) -> a -> b
$ Map CmmTickScope [BlockContext] -> [CmmTickScope]
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 = t -> Either t (CmmTickScope, t)
forall a b. a -> Either a b
Left t
tsc
findP t
tsc CmmTickScope
scp | CmmTickScope
scp' CmmTickScope -> Map CmmTickScope [BlockContext] -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.member` Map CmmTickScope [BlockContext]
blockCtxs = (CmmTickScope, t) -> Either t (CmmTickScope, t)
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 = (Map CmmTickScope [CmmTickScope]
-> (CmmTickScope, CmmTickScope) -> Map CmmTickScope [CmmTickScope])
-> Map CmmTickScope [CmmTickScope]
-> [(CmmTickScope, CmmTickScope)]
-> Map CmmTickScope [CmmTickScope]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (\Map CmmTickScope [CmmTickScope]
acc (CmmTickScope
key, CmmTickScope
scope) -> CmmTickScope
-> CmmTickScope
-> Map CmmTickScope [CmmTickScope]
-> Map CmmTickScope [CmmTickScope]
forall k a. Ord k => k -> a -> Map k [a] -> Map k [a]
insertMulti CmmTickScope
key CmmTickScope
scope Map CmmTickScope [CmmTickScope]
acc) Map CmmTickScope [CmmTickScope]
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 [GenTickish 'TickishPassCmm]
-> [GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm]
forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [GenTickish 'TickishPassCmm]
go CmmTickScope
s'
| CombinedScope CmmTickScope
s1 CmmTickScope
s2 <- CmmTickScope
s = [GenTickish 'TickishPassCmm]
ticks [GenTickish 'TickishPassCmm]
-> [GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm]
forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [GenTickish 'TickishPassCmm]
go CmmTickScope
s1 [GenTickish 'TickishPassCmm]
-> [GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm]
forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [GenTickish 'TickishPassCmm]
go CmmTickScope
s2
| Bool
otherwise = String -> [GenTickish 'TickishPassCmm]
forall a. HasCallStack => String -> a
panic String
"ticksToCopy impossible"
where ticks :: [GenTickish 'TickishPassCmm]
ticks = [BlockContext] -> [GenTickish 'TickishPassCmm]
forall {b}.
[(Block CmmNode C C, b)] -> [GenTickish 'TickishPassCmm]
bCtxsTicks ([BlockContext] -> [GenTickish 'TickishPassCmm])
-> [BlockContext] -> [GenTickish 'TickishPassCmm]
forall a b. (a -> b) -> a -> b
$ [BlockContext] -> Maybe [BlockContext] -> [BlockContext]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [BlockContext] -> [BlockContext])
-> Maybe [BlockContext] -> [BlockContext]
forall a b. (a -> b) -> a -> b
$ CmmTickScope
-> Map CmmTickScope [BlockContext] -> Maybe [BlockContext]
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 = ((Block CmmNode C C, b) -> [GenTickish 'TickishPassCmm])
-> [(Block CmmNode C C, b)] -> [GenTickish 'TickishPassCmm]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (Block CmmNode C C -> [GenTickish 'TickishPassCmm]
blockTicks (Block CmmNode C C -> [GenTickish 'TickishPassCmm])
-> ((Block CmmNode C C, b) -> Block CmmNode C C)
-> (Block CmmNode C C, b)
-> [GenTickish 'TickishPassCmm]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Block CmmNode C C, b) -> Block CmmNode C C
forall a b. (a, b) -> a
fst)
bestSrcTick :: [GenTickish 'TickishPassCmm] -> GenTickish 'TickishPassCmm
bestSrcTick = (GenTickish 'TickishPassCmm
-> GenTickish 'TickishPassCmm -> Ordering)
-> [GenTickish 'TickishPassCmm] -> GenTickish 'TickishPassCmm
forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
minimumBy ((GenTickish 'TickishPassCmm -> Int)
-> GenTickish 'TickishPassCmm
-> GenTickish 'TickishPassCmm
-> Ordering
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 FastString -> FastString -> Bool
forall a. Eq a => a -> a -> Bool
== FastString
thisFile = Int
1
| Bool
otherwise = Int
2 :: Int
rangeRating GenTickish 'TickishPassCmm
note = String -> SDoc -> Int
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"rangeRating" (GenTickish 'TickishPassCmm -> SDoc
forall a. Outputable a => a -> SDoc
ppr GenTickish 'TickishPassCmm
note)
thisFile :: FastString
thisFile = FastString -> (String -> FastString) -> Maybe String -> FastString
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FastString
nilFS String -> FastString
mkFastString (Maybe String -> FastString) -> Maybe String -> FastString
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 ([BlockContext] -> BlockContext
forall a. HasCallStack => [a] -> a
head [BlockContext]
bctxs)
where bctxs :: [BlockContext]
bctxs = Maybe [BlockContext] -> [BlockContext]
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe [BlockContext] -> [BlockContext])
-> Maybe [BlockContext] -> [BlockContext]
forall a b. (a -> b) -> a -> b
$ CmmTickScope
-> Map CmmTickScope [BlockContext] -> Maybe [BlockContext]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CmmTickScope
scope Map CmmTickScope [BlockContext]
blockCtxs
nested :: [CmmTickScope]
nested = [CmmTickScope] -> Maybe [CmmTickScope] -> [CmmTickScope]
forall a. a -> Maybe a -> a
fromMaybe [] (Maybe [CmmTickScope] -> [CmmTickScope])
-> Maybe [CmmTickScope] -> [CmmTickScope]
forall a b. (a -> b) -> a -> b
$ CmmTickScope
-> Map CmmTickScope [CmmTickScope] -> Maybe [CmmTickScope]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup CmmTickScope
scope Map CmmTickScope [CmmTickScope]
scopeMap
childs :: [DebugBlock]
childs = (BlockContext -> DebugBlock) -> [BlockContext] -> [DebugBlock]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> BlockContext -> DebugBlock
mkBlock Bool
False) ([BlockContext] -> [BlockContext]
forall a. HasCallStack => [a] -> [a]
tail [BlockContext]
bctxs) [DebugBlock] -> [DebugBlock] -> [DebugBlock]
forall a. [a] -> [a] -> [a]
++
(CmmTickScope -> DebugBlock) -> [CmmTickScope] -> [DebugBlock]
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 = GenCmmGraph CmmNode -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry GenCmmGraph CmmNode
graph
, dblLabel :: Label
dblLabel = Label
label
, dblCLabel :: CLabel
dblCLabel = case Maybe RawCmmStatics
info of
Just (CmmStaticsRaw CLabel
infoLbl [CmmStatic]
_) -> CLabel
infoLbl
Maybe RawCmmStatics
Nothing
| GenCmmGraph CmmNode -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry GenCmmGraph CmmNode
graph Label -> Label -> Bool
forall a. Eq a => a -> a -> Bool
== Label
label -> CLabel
entryLbl
| Bool
otherwise -> Label -> CLabel
blockLbl Label
label
, dblHasInfoTbl :: Bool
dblHasInfoTbl = Maybe RawCmmStatics -> Bool
forall a. Maybe a -> Bool
isJust Maybe RawCmmStatics
info
, dblParent :: Maybe DebugBlock
dblParent = Maybe DebugBlock
forall a. Maybe a
Nothing
, dblTicks :: [GenTickish 'TickishPassCmm]
dblTicks = [GenTickish 'TickishPassCmm]
ticks
, dblPosition :: Maybe Int
dblPosition = Maybe Int
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]
_ GenCmmGraph CmmNode
graph) = RawCmmDecl
prc
label :: Label
label = Block CmmNode C C -> Label
forall (x :: Extensibility). Block CmmNode C x -> Label
forall (thing :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
NonLocal thing =>
thing C x -> Label
entryLabel Block CmmNode C C
block
info :: Maybe RawCmmStatics
info = KeyOf LabelMap -> LabelMap RawCmmStatics -> Maybe RawCmmStatics
forall a. KeyOf LabelMap -> LabelMap a -> Maybe a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> map a -> Maybe a
mapLookup KeyOf LabelMap
Label
label LabelMap RawCmmStatics
infos
blocks :: [DebugBlock]
blocks | Bool
top = [DebugBlock] -> [DebugBlock] -> [DebugBlock]
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 = (GenTickish 'TickishPassCmm -> GenTickish 'TickishPassCmm -> Bool)
-> [GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy ((GenTickish 'TickishPassCmm -> GenTickish 'TickishPassCmm -> Bool)
-> GenTickish 'TickishPassCmm -> GenTickish 'TickishPassCmm -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip GenTickish 'TickishPassCmm -> GenTickish 'TickishPassCmm -> Bool
forall (pass :: TickishPass).
Eq (GenTickish pass) =>
GenTickish pass -> GenTickish pass -> Bool
tickishContains) ([GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm])
-> [GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm]
forall a b. (a -> b) -> a -> b
$
[BlockContext] -> [GenTickish 'TickishPassCmm]
forall {b}.
[(Block CmmNode C C, b)] -> [GenTickish 'TickishPassCmm]
bCtxsTicks [BlockContext]
bctxs [GenTickish 'TickishPassCmm]
-> [GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm]
forall a. [a] -> [a] -> [a]
++ CmmTickScope -> [GenTickish 'TickishPassCmm]
ticksToCopy CmmTickScope
scope
stick :: Maybe (GenTickish 'TickishPassCmm)
stick = case (GenTickish 'TickishPassCmm -> Bool)
-> [GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm]
forall a. (a -> Bool) -> [a] -> [a]
filter GenTickish 'TickishPassCmm -> Bool
forall {pass :: TickishPass}. GenTickish pass -> Bool
isSourceTick [GenTickish 'TickishPassCmm]
ticks of
[] -> Maybe (GenTickish 'TickishPassCmm)
cstick
[GenTickish 'TickishPassCmm]
sticks -> GenTickish 'TickishPassCmm -> Maybe (GenTickish 'TickishPassCmm)
forall a. a -> Maybe a
Just (GenTickish 'TickishPassCmm -> Maybe (GenTickish 'TickishPassCmm))
-> GenTickish 'TickishPassCmm -> Maybe (GenTickish 'TickishPassCmm)
forall a b. (a -> b) -> a -> b
$! [GenTickish 'TickishPassCmm] -> GenTickish 'TickishPassCmm
bestSrcTick ([GenTickish 'TickishPassCmm]
sticks [GenTickish 'TickishPassCmm]
-> [GenTickish 'TickishPassCmm] -> [GenTickish 'TickishPassCmm]
forall a. [a] -> [a] -> [a]
++ Maybe (GenTickish 'TickishPassCmm) -> [GenTickish 'TickishPassCmm]
forall a. Maybe a -> [a]
maybeToList Maybe (GenTickish 'TickishPassCmm)
cstick)
blockContexts :: RawCmmGroup -> Map.Map CmmTickScope [BlockContext]
blockContexts :: RawCmmGroup -> Map CmmTickScope [BlockContext]
blockContexts RawCmmGroup
decls = ([BlockContext] -> [BlockContext])
-> Map CmmTickScope [BlockContext]
-> Map CmmTickScope [BlockContext]
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map [BlockContext] -> [BlockContext]
forall a. [a] -> [a]
reverse (Map CmmTickScope [BlockContext]
-> Map CmmTickScope [BlockContext])
-> Map CmmTickScope [BlockContext]
-> Map CmmTickScope [BlockContext]
forall a b. (a -> b) -> a -> b
$ (RawCmmDecl
-> Map CmmTickScope [BlockContext]
-> Map CmmTickScope [BlockContext])
-> Map CmmTickScope [BlockContext]
-> RawCmmGroup
-> Map CmmTickScope [BlockContext]
forall a b. (a -> b -> b) -> 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 Map CmmTickScope [BlockContext]
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]
_ GenCmmGraph CmmNode
graph) Map CmmTickScope [BlockContext]
m
| LabelMap (Block CmmNode C C) -> Bool
forall a. LabelMap a -> Bool
forall (map :: * -> *) a. IsMap map => map a -> Bool
mapNull LabelMap (Block CmmNode C C)
blocks = Map CmmTickScope [BlockContext]
m
| Bool
otherwise = (LabelSet, Map CmmTickScope [BlockContext])
-> Map CmmTickScope [BlockContext]
forall a b. (a, b) -> b
snd ((LabelSet, Map CmmTickScope [BlockContext])
-> Map CmmTickScope [BlockContext])
-> (LabelSet, Map CmmTickScope [BlockContext])
-> Map CmmTickScope [BlockContext]
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 = GenCmmGraph CmmNode -> LabelMap (Block CmmNode C C)
toBlockMap GenCmmGraph CmmNode
graph
entry :: [Block CmmNode C C]
entry = [KeyOf LabelMap -> LabelMap (Block CmmNode C C) -> Block CmmNode C C
forall {a}. KeyOf LabelMap -> LabelMap a -> a
mapFind (GenCmmGraph CmmNode -> Label
forall (n :: Extensibility -> Extensibility -> *).
GenCmmGraph n -> Label
g_entry GenCmmGraph CmmNode
graph) LabelMap (Block CmmNode C C)
blocks]
emptyLbls :: LabelSet
emptyLbls = LabelSet
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)
| ElemOf LabelSet
Label
lbl ElemOf LabelSet -> LabelSet -> Bool
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 ((LabelSet, Map CmmTickScope [BlockContext])
-> (LabelSet, Map CmmTickScope [BlockContext]))
-> (LabelSet, Map CmmTickScope [BlockContext])
-> (LabelSet, Map CmmTickScope [BlockContext])
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
(ElemOf LabelSet
Label
lbl ElemOf LabelSet -> LabelSet -> LabelSet
forall set. IsSet set => ElemOf set -> set -> set
`setInsert` LabelSet
visited,
CmmTickScope
-> BlockContext
-> Map CmmTickScope [BlockContext]
-> Map CmmTickScope [BlockContext]
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 = Block CmmNode C C -> CmmNode C O
forall (n :: Extensibility -> Extensibility -> *)
(x :: Extensibility).
Block n C x -> n C O
firstNode Block CmmNode C C
block
(CmmProc LabelMap RawCmmStatics
_ CLabel
_ [GlobalReg]
_ GenCmmGraph CmmNode
graph) = RawCmmDecl
prc
succs :: [Block CmmNode C C]
succs = (Label -> Block CmmNode C C) -> [Label] -> [Block CmmNode C C]
forall a b. (a -> b) -> [a] -> [b]
map ((Label -> LabelMap (Block CmmNode C C) -> Block CmmNode C C)
-> LabelMap (Block CmmNode C C) -> Label -> Block CmmNode C C
forall a b c. (a -> b -> c) -> b -> a -> c
flip KeyOf LabelMap -> LabelMap (Block CmmNode C C) -> Block CmmNode C C
Label -> LabelMap (Block CmmNode C C) -> Block CmmNode C C
forall {a}. KeyOf LabelMap -> LabelMap a -> a
mapFind (GenCmmGraph CmmNode -> LabelMap (Block CmmNode C C)
toBlockMap GenCmmGraph CmmNode
graph))
(CmmNode O C -> [Label]
forall (e :: Extensibility). CmmNode e C -> [Label]
forall (thing :: Extensibility -> Extensibility -> *)
(e :: Extensibility).
NonLocal thing =>
thing e C -> [Label]
successors (Block CmmNode C C -> CmmNode O C
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 = a -> KeyOf LabelMap -> LabelMap a -> a
forall a. a -> KeyOf LabelMap -> LabelMap a -> a
forall (map :: * -> *) a. IsMap map => a -> KeyOf map -> map a -> a
mapFindWithDefault (String -> a
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 = ([a] -> [a] -> [a]) -> k -> [a] -> Map k [a] -> Map k [a]
forall k a. Ord k => (a -> a -> a) -> k -> a -> Map k a -> Map k a
Map.insertWith (([a] -> [a]) -> [a] -> [a] -> [a]
forall a b. a -> b -> a
const (a
va -> [a] -> [a]
forall 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 = [Label] -> [Label] -> [Label]
forall a b. [a] -> b -> b
seqList [Label]
lbls [Label]
lbls
where
lbls :: [Label]
lbls = (GenBasicBlock i -> Label) -> [GenBasicBlock i] -> [Label]
forall a b. (a -> b) -> [a] -> [b]
map GenBasicBlock i -> Label
forall i. GenBasicBlock i -> Label
blockId ([GenBasicBlock i] -> [Label]) -> [GenBasicBlock i] -> [Label]
forall a b. (a -> b) -> a -> b
$ (GenBasicBlock i -> Bool) -> [GenBasicBlock i] -> [GenBasicBlock i]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (GenBasicBlock i -> Bool) -> GenBasicBlock i -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GenBasicBlock i -> Bool
allMeta) ([GenBasicBlock i] -> [GenBasicBlock i])
-> [GenBasicBlock i] -> [GenBasicBlock i]
forall a b. (a -> b) -> a -> b
$ (GenCmmDecl d g (ListGraph i) -> [GenBasicBlock i])
-> GenCmmGroup d g (ListGraph i) -> [GenBasicBlock i]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap GenCmmDecl d g (ListGraph i) -> [GenBasicBlock i]
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) = (i -> Bool) -> [i] -> Bool
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 = (DebugBlock -> DebugBlock) -> [DebugBlock] -> [DebugBlock]
forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> DebugBlock
link [DebugBlock]
blocks
where blockPos :: LabelMap Int
blockPos :: LabelMap Int
blockPos = [(KeyOf LabelMap, Int)] -> LabelMap Int
forall a. [(KeyOf LabelMap, a)] -> LabelMap a
forall (map :: * -> *) a. IsMap map => [(KeyOf map, a)] -> map a
mapFromList ([(KeyOf LabelMap, Int)] -> LabelMap Int)
-> [(KeyOf LabelMap, Int)] -> LabelMap Int
forall a b. (a -> b) -> a -> b
$ ([Label] -> [Int] -> [(Label, Int)])
-> [Int] -> [Label] -> [(Label, Int)]
forall a b c. (a -> b -> c) -> b -> a -> c
flip [Label] -> [Int] -> [(Label, Int)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Label]
labels
link :: DebugBlock -> DebugBlock
link DebugBlock
block = DebugBlock
block { dblPosition = mapLookup (dblLabel block) blockPos
, dblBlocks = map link (dblBlocks block)
, dblUnwind = fromMaybe mempty
$ mapLookup (dblLabel block) unwindPts
}
debugToMap :: [DebugBlock] -> LabelMap DebugBlock
debugToMap :: [DebugBlock] -> LabelMap DebugBlock
debugToMap = [LabelMap DebugBlock] -> LabelMap DebugBlock
forall (map :: * -> *) a. IsMap map => [map a] -> map a
mapUnions ([LabelMap DebugBlock] -> LabelMap DebugBlock)
-> ([DebugBlock] -> [LabelMap DebugBlock])
-> [DebugBlock]
-> LabelMap DebugBlock
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DebugBlock -> LabelMap DebugBlock)
-> [DebugBlock] -> [LabelMap DebugBlock]
forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> LabelMap DebugBlock
forall {map :: * -> *}.
(KeyOf map ~ Label, IsMap map) =>
DebugBlock -> map DebugBlock
go
where go :: DebugBlock -> map DebugBlock
go DebugBlock
b = KeyOf map -> DebugBlock -> map DebugBlock -> map DebugBlock
forall a. KeyOf map -> a -> map a -> map a
forall (map :: * -> *) a.
IsMap map =>
KeyOf map -> a -> map a -> map a
mapInsert (DebugBlock -> Label
dblLabel DebugBlock
b) DebugBlock
b (map DebugBlock -> map DebugBlock)
-> map DebugBlock -> map DebugBlock
forall a b. (a -> b) -> a -> b
$ [map DebugBlock] -> map DebugBlock
forall (map :: * -> *) a. IsMap map => [map a] -> map a
mapUnions ([map DebugBlock] -> map DebugBlock)
-> [map DebugBlock] -> map DebugBlock
forall a b. (a -> b) -> a -> b
$ (DebugBlock -> map DebugBlock) -> [DebugBlock] -> [map DebugBlock]
forall a b. (a -> b) -> [a] -> [b]
map DebugBlock -> map DebugBlock
go (DebugBlock -> [DebugBlock]
dblBlocks DebugBlock
b)
data UnwindPoint = UnwindPoint !CLabel !UnwindTable
instance OutputableP Platform UnwindPoint where
pdoc :: Platform -> UnwindPoint -> SDoc
pdoc Platform
env (UnwindPoint CLabel
lbl UnwindTable
uws) =
SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
braces (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$ Platform -> CLabel -> SDoc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
env CLabel
lbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
forall doc. IsLine doc => doc
colon
SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep (SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ([SDoc] -> [SDoc]) -> [SDoc] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ ((GlobalReg, Maybe UnwindExpr) -> SDoc)
-> [(GlobalReg, Maybe UnwindExpr)] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalReg, Maybe UnwindExpr) -> SDoc
pprUw ([(GlobalReg, Maybe UnwindExpr)] -> [SDoc])
-> [(GlobalReg, Maybe UnwindExpr)] -> [SDoc]
forall a b. (a -> b) -> a -> b
$ UnwindTable -> [(GlobalReg, Maybe UnwindExpr)]
forall k a. Map k a -> [(k, a)]
Map.toList UnwindTable
uws)
where
pprUw :: (GlobalReg, Maybe UnwindExpr) -> SDoc
pprUw (GlobalReg
g, Maybe UnwindExpr
expr) = GlobalReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr GlobalReg
g SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'=' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> Maybe UnwindExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
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
(UnwindExpr -> UnwindExpr -> Bool)
-> (UnwindExpr -> UnwindExpr -> Bool) -> Eq UnwindExpr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnwindExpr -> UnwindExpr -> Bool
== :: UnwindExpr -> UnwindExpr -> Bool
$c/= :: UnwindExpr -> UnwindExpr -> Bool
/= :: UnwindExpr -> UnwindExpr -> Bool
Eq)
instance OutputableP Platform UnwindExpr where
pdoc :: Platform -> UnwindExpr -> SDoc
pdoc = Rational -> Platform -> UnwindExpr -> SDoc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
0
pprUnwindTable :: IsLine doc => Platform -> UnwindTable -> doc
pprUnwindTable :: forall doc. IsLine doc => Platform -> UnwindTable -> doc
pprUnwindTable Platform
platform UnwindTable
u = doc -> doc
forall doc. IsLine doc => doc -> doc
brackets ([doc] -> doc
forall doc. IsLine doc => [doc] -> doc
fsep (doc -> [doc] -> [doc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate doc
forall doc. IsLine doc => doc
comma (((GlobalReg, Maybe UnwindExpr) -> doc)
-> [(GlobalReg, Maybe UnwindExpr)] -> [doc]
forall a b. (a -> b) -> [a] -> [b]
map (GlobalReg, Maybe UnwindExpr) -> doc
print_entry (UnwindTable -> [(GlobalReg, Maybe UnwindExpr)]
forall k a. Map k a -> [(k, a)]
Map.toList UnwindTable
u))))
where print_entry :: (GlobalReg, Maybe UnwindExpr) -> doc
print_entry (GlobalReg
reg, Maybe UnwindExpr
Nothing) =
doc -> doc
forall doc. IsLine doc => doc -> doc
parens ([doc] -> doc
forall doc. IsLine doc => [doc] -> doc
sep [GlobalReg -> doc
forall doc. IsLine doc => GlobalReg -> doc
pprGlobalReg GlobalReg
reg, String -> doc
forall doc. IsLine doc => String -> doc
text String
"Nothing"])
print_entry (GlobalReg
reg, Just UnwindExpr
x) =
doc -> doc
forall doc. IsLine doc => doc -> doc
parens ([doc] -> doc
forall doc. IsLine doc => [doc] -> doc
sep [GlobalReg -> doc
forall doc. IsLine doc => GlobalReg -> doc
pprGlobalReg GlobalReg
reg, String -> doc
forall doc. IsLine doc => String -> doc
text String
"Just" doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<+> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
0 Platform
platform UnwindExpr
x])
pprUnwindExpr :: IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr :: forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
p Platform
env = \case
UwConst Int
i -> Int -> doc
forall doc. IsLine doc => Int -> doc
int Int
i
UwReg GlobalReg
g Int
0 -> GlobalReg -> doc
forall doc. IsLine doc => GlobalReg -> doc
pprGlobalReg GlobalReg
g
UwReg GlobalReg
g Int
x -> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
p Platform
env (UnwindExpr -> UnwindExpr -> UnwindExpr
UwPlus (GlobalReg -> Int -> UnwindExpr
UwReg GlobalReg
g Int
0) (Int -> UnwindExpr
UwConst Int
x))
UwDeref UnwindExpr
e -> Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'*' doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
3 Platform
env UnwindExpr
e
UwLabel CLabel
l -> Platform -> CLabel -> doc
forall doc. IsLine doc => Platform -> CLabel -> doc
pprAsmLabel Platform
env CLabel
l
UwPlus UnwindExpr
e0 UnwindExpr
e1
| Rational
p Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0 -> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
0 Platform
env UnwindExpr
e0 doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'+' doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
0 Platform
env UnwindExpr
e1
UwMinus UnwindExpr
e0 UnwindExpr
e1
| Rational
p Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
0 -> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
1 Platform
env UnwindExpr
e0 doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'-' doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
1 Platform
env UnwindExpr
e1
UwTimes UnwindExpr
e0 UnwindExpr
e1
| Rational
p Rational -> Rational -> Bool
forall a. Ord a => a -> a -> Bool
<= Rational
1 -> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
2 Platform
env UnwindExpr
e0 doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> doc
forall doc. IsLine doc => Char -> doc
char Char
'*' doc -> doc -> doc
forall doc. IsLine doc => doc -> doc -> doc
<> Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
2 Platform
env UnwindExpr
e1
UnwindExpr
other -> doc -> doc
forall doc. IsLine doc => doc -> doc
parens (Rational -> Platform -> UnwindExpr -> doc
forall doc. IsLine doc => Rational -> Platform -> UnwindExpr -> doc
pprUnwindExpr Rational
0 Platform
env UnwindExpr
other)
{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> SDoc #-}
{-# SPECIALIZE pprUnwindExpr :: Rational -> Platform -> UnwindExpr -> HLine #-}
toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
toUnwindExpr :: Platform -> CmmExpr -> UnwindExpr
toUnwindExpr Platform
_ (CmmLit (CmmInt Integer
i Width
_)) = Int -> UnwindExpr
UwConst (Integer -> Int
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 Int -> Int -> Int
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 Int -> Int -> Int
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 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y)
(MO_Add{}, UwConst Int
x, UwConst Int
y) -> Int -> UnwindExpr
UwConst (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
y)
(MO_Sub{}, UwConst Int
x, UwConst Int
y) -> Int -> UnwindExpr
UwConst (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
y)
(MO_Mul{}, UwConst Int
x, UwConst Int
y) -> Int -> UnwindExpr
UwConst (Int
x Int -> Int -> Int
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 -> String -> SDoc -> UnwindExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unsupported operator in unwind expression!"
(Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
e)
toUnwindExpr Platform
platform CmmExpr
e
= String -> SDoc -> UnwindExpr
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"Unsupported unwind expression!" (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
e)