{-# OPTIONS_GHC -fno-warn-orphans #-}
module PprCmmExpr
( pprExpr, pprLit
)
where
import GhcPrelude
import CmmExpr
import Outputable
import DynFlags
import Data.Maybe
import Numeric ( fromRat )
instance Outputable CmmExpr where
ppr :: CmmExpr -> SDoc
ppr CmmExpr
e = CmmExpr -> SDoc
pprExpr CmmExpr
e
instance Outputable CmmReg where
ppr :: CmmReg -> SDoc
ppr CmmReg
e = CmmReg -> SDoc
pprReg CmmReg
e
instance Outputable CmmLit where
ppr :: CmmLit -> SDoc
ppr CmmLit
l = CmmLit -> SDoc
pprLit CmmLit
l
instance Outputable LocalReg where
ppr :: LocalReg -> SDoc
ppr LocalReg
e = LocalReg -> SDoc
pprLocalReg LocalReg
e
instance Outputable Area where
ppr :: Area -> SDoc
ppr Area
e = Area -> SDoc
pprArea Area
e
instance Outputable GlobalReg where
ppr :: GlobalReg -> SDoc
ppr GlobalReg
e = GlobalReg -> SDoc
pprGlobalReg GlobalReg
e
pprExpr :: CmmExpr -> SDoc
pprExpr :: CmmExpr -> SDoc
pprExpr CmmExpr
e
= (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
case CmmExpr
e of
CmmRegOff CmmReg
reg Int
i ->
CmmExpr -> SDoc
pprExpr (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
rep)
[CmmReg -> CmmExpr
CmmReg CmmReg
reg, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Int -> Integer
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
i) Width
rep)])
where rep :: Width
rep = CmmType -> Width
typeWidth (DynFlags -> CmmReg -> CmmType
cmmRegType DynFlags
dflags CmmReg
reg)
CmmLit CmmLit
lit -> CmmLit -> SDoc
pprLit CmmLit
lit
CmmExpr
_other -> CmmExpr -> SDoc
pprExpr1 CmmExpr
e
pprExpr1, pprExpr7, pprExpr8 :: CmmExpr -> SDoc
pprExpr1 :: CmmExpr -> SDoc
pprExpr1 (CmmMachOp MachOp
op [CmmExpr
x,CmmExpr
y]) | Just SDoc
doc <- MachOp -> Maybe SDoc
infixMachOp1 MachOp
op
= CmmExpr -> SDoc
pprExpr7 CmmExpr
x SDoc -> SDoc -> SDoc
<+> SDoc
doc SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
pprExpr7 CmmExpr
y
pprExpr1 CmmExpr
e = CmmExpr -> SDoc
pprExpr7 CmmExpr
e
infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
infixMachOp1 :: MachOp -> Maybe SDoc
infixMachOp1 (MO_Eq Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"==")
infixMachOp1 (MO_Ne Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"!=")
infixMachOp1 (MO_Shl Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"<<")
infixMachOp1 (MO_U_Shr Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
">>")
infixMachOp1 (MO_U_Ge Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
">=")
infixMachOp1 (MO_U_Le Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
text String
"<=")
infixMachOp1 (MO_U_Gt Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
char Char
'>')
infixMachOp1 (MO_U_Lt Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
char Char
'<')
infixMachOp1 MachOp
_ = Maybe SDoc
forall a. Maybe a
Nothing
pprExpr7 :: CmmExpr -> SDoc
pprExpr7 (CmmMachOp (MO_Add Width
rep1) [CmmExpr
x, CmmLit (CmmInt Integer
i Width
rep2)]) | Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0
= CmmExpr -> SDoc
pprExpr7 (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Sub Width
rep1) [CmmExpr
x, CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer -> Integer
forall a. Num a => a -> a
negate Integer
i) Width
rep2)])
pprExpr7 (CmmMachOp MachOp
op [CmmExpr
x,CmmExpr
y]) | Just SDoc
doc <- MachOp -> Maybe SDoc
infixMachOp7 MachOp
op
= CmmExpr -> SDoc
pprExpr7 CmmExpr
x SDoc -> SDoc -> SDoc
<+> SDoc
doc SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
pprExpr8 CmmExpr
y
pprExpr7 CmmExpr
e = CmmExpr -> SDoc
pprExpr8 CmmExpr
e
infixMachOp7 :: MachOp -> Maybe SDoc
infixMachOp7 (MO_Add Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
char Char
'+')
infixMachOp7 (MO_Sub Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
char Char
'-')
infixMachOp7 MachOp
_ = Maybe SDoc
forall a. Maybe a
Nothing
pprExpr8 :: CmmExpr -> SDoc
pprExpr8 (CmmMachOp MachOp
op [CmmExpr
x,CmmExpr
y]) | Just SDoc
doc <- MachOp -> Maybe SDoc
infixMachOp8 MachOp
op
= CmmExpr -> SDoc
pprExpr8 CmmExpr
x SDoc -> SDoc -> SDoc
<+> SDoc
doc SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
pprExpr9 CmmExpr
y
pprExpr8 CmmExpr
e = CmmExpr -> SDoc
pprExpr9 CmmExpr
e
infixMachOp8 :: MachOp -> Maybe SDoc
infixMachOp8 (MO_U_Quot Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
char Char
'/')
infixMachOp8 (MO_Mul Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
char Char
'*')
infixMachOp8 (MO_U_Rem Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
char Char
'%')
infixMachOp8 MachOp
_ = Maybe SDoc
forall a. Maybe a
Nothing
pprExpr9 :: CmmExpr -> SDoc
pprExpr9 :: CmmExpr -> SDoc
pprExpr9 CmmExpr
e =
case CmmExpr
e of
CmmLit CmmLit
lit -> CmmLit -> SDoc
pprLit1 CmmLit
lit
CmmLoad CmmExpr
expr CmmType
rep -> CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
rep SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
brackets (CmmExpr -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmExpr
expr)
CmmReg CmmReg
reg -> CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReg
reg
CmmRegOff CmmReg
reg Int
off -> SDoc -> SDoc
parens (CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReg
reg SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'+' SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
off)
CmmStackSlot Area
a Int
off -> SDoc -> SDoc
parens (Area -> SDoc
forall a. Outputable a => a -> SDoc
ppr Area
a SDoc -> SDoc -> SDoc
<+> Char -> SDoc
char Char
'+' SDoc -> SDoc -> SDoc
<+> Int -> SDoc
int Int
off)
CmmMachOp MachOp
mop [CmmExpr]
args -> MachOp -> [CmmExpr] -> SDoc
genMachOp MachOp
mop [CmmExpr]
args
genMachOp :: MachOp -> [CmmExpr] -> SDoc
genMachOp :: MachOp -> [CmmExpr] -> SDoc
genMachOp MachOp
mop [CmmExpr]
args
| Just SDoc
doc <- MachOp -> Maybe SDoc
infixMachOp MachOp
mop = case [CmmExpr]
args of
[CmmExpr
x,CmmExpr
y] -> CmmExpr -> SDoc
pprExpr9 CmmExpr
x SDoc -> SDoc -> SDoc
<+> SDoc
doc SDoc -> SDoc -> SDoc
<+> CmmExpr -> SDoc
pprExpr9 CmmExpr
y
[CmmExpr
x] -> SDoc
doc SDoc -> SDoc -> SDoc
<> CmmExpr -> SDoc
pprExpr9 CmmExpr
x
[CmmExpr]
_ -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"PprCmm.genMachOp: machop with strange number of args"
(MachOp -> SDoc
pprMachOp MachOp
mop SDoc -> SDoc -> SDoc
<+>
SDoc -> SDoc
parens ([SDoc] -> SDoc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma ((CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> SDoc
pprExpr [CmmExpr]
args)))
SDoc
empty
| Maybe SDoc -> Bool
forall a. Maybe a -> Bool
isJust (MachOp -> Maybe SDoc
infixMachOp1 MachOp
mop)
Bool -> Bool -> Bool
|| Maybe SDoc -> Bool
forall a. Maybe a -> Bool
isJust (MachOp -> Maybe SDoc
infixMachOp7 MachOp
mop)
Bool -> Bool -> Bool
|| Maybe SDoc -> Bool
forall a. Maybe a -> Bool
isJust (MachOp -> Maybe SDoc
infixMachOp8 MachOp
mop) = SDoc -> SDoc
parens (CmmExpr -> SDoc
pprExpr (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
mop [CmmExpr]
args))
| Bool
otherwise = Char -> SDoc
char Char
'%' SDoc -> SDoc -> SDoc
<> SDoc
ppr_op SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens ([SDoc] -> SDoc
commafy ((CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmExpr -> SDoc
pprExpr [CmmExpr]
args))
where ppr_op :: SDoc
ppr_op = String -> SDoc
text ((Char -> Char) -> String -> String
forall a b. (a -> b) -> [a] -> [b]
map (\Char
c -> if Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
' ' then Char
'_' else Char
c)
(MachOp -> String
forall a. Show a => a -> String
show MachOp
mop))
infixMachOp :: MachOp -> Maybe SDoc
infixMachOp :: MachOp -> Maybe SDoc
infixMachOp MachOp
mop
= case MachOp
mop of
MO_And Width
_ -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ Char -> SDoc
char Char
'&'
MO_Or Width
_ -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ Char -> SDoc
char Char
'|'
MO_Xor Width
_ -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ Char -> SDoc
char Char
'^'
MO_Not Width
_ -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ Char -> SDoc
char Char
'~'
MO_S_Neg Width
_ -> SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (SDoc -> Maybe SDoc) -> SDoc -> Maybe SDoc
forall a b. (a -> b) -> a -> b
$ Char -> SDoc
char Char
'-'
MachOp
_ -> Maybe SDoc
forall a. Maybe a
Nothing
pprLit :: CmmLit -> SDoc
pprLit :: CmmLit -> SDoc
pprLit CmmLit
lit = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
case CmmLit
lit of
CmmInt Integer
i Width
rep ->
[SDoc] -> SDoc
hcat [ (if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then SDoc -> SDoc
parens else SDoc -> SDoc
forall a. a -> a
id)(Integer -> SDoc
integer Integer
i)
, Bool -> SDoc -> SDoc
ppUnless (Width
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== DynFlags -> Width
wordWidth DynFlags
dflags) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
SDoc
space SDoc -> SDoc -> SDoc
<> SDoc
dcolon SDoc -> SDoc -> SDoc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
rep ]
CmmFloat Rational
f Width
rep -> [SDoc] -> SDoc
hsep [ Double -> SDoc
double (Rational -> Double
forall a. RealFloat a => Rational -> a
fromRat Rational
f), SDoc
dcolon, Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
rep ]
CmmVec [CmmLit]
lits -> Char -> SDoc
char Char
'<' SDoc -> SDoc -> SDoc
<> [SDoc] -> SDoc
commafy ((CmmLit -> SDoc) -> [CmmLit] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map CmmLit -> SDoc
pprLit [CmmLit]
lits) SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'>'
CmmLabel CLabel
clbl -> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
clbl
CmmLabelOff CLabel
clbl Int
i -> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
clbl SDoc -> SDoc -> SDoc
<> Int -> SDoc
ppr_offset Int
i
CmmLabelDiffOff CLabel
clbl1 CLabel
clbl2 Int
i Width
_ -> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
clbl1 SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'-'
SDoc -> SDoc -> SDoc
<> CLabel -> SDoc
forall a. Outputable a => a -> SDoc
ppr CLabel
clbl2 SDoc -> SDoc -> SDoc
<> Int -> SDoc
ppr_offset Int
i
CmmBlock BlockId
id -> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
id
CmmLit
CmmHighStackMark -> String -> SDoc
text String
"<highSp>"
pprLit1 :: CmmLit -> SDoc
pprLit1 :: CmmLit -> SDoc
pprLit1 lit :: CmmLit
lit@(CmmLabelOff {}) = SDoc -> SDoc
parens (CmmLit -> SDoc
pprLit CmmLit
lit)
pprLit1 CmmLit
lit = CmmLit -> SDoc
pprLit CmmLit
lit
ppr_offset :: Int -> SDoc
ppr_offset :: Int -> SDoc
ppr_offset Int
i
| Int
iInt -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
0 = SDoc
empty
| Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
0 = Char -> SDoc
char Char
'+' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
i
| Bool
otherwise = Char -> SDoc
char Char
'-' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int (-Int
i)
pprReg :: CmmReg -> SDoc
pprReg :: CmmReg -> SDoc
pprReg CmmReg
r
= case CmmReg
r of
CmmLocal LocalReg
local -> LocalReg -> SDoc
pprLocalReg LocalReg
local
CmmGlobal GlobalReg
global -> GlobalReg -> SDoc
pprGlobalReg GlobalReg
global
pprLocalReg :: LocalReg -> SDoc
pprLocalReg :: LocalReg -> SDoc
pprLocalReg (LocalReg Unique
uniq CmmType
rep) = (DynFlags -> SDoc) -> SDoc
sdocWithDynFlags ((DynFlags -> SDoc) -> SDoc) -> (DynFlags -> SDoc) -> SDoc
forall a b. (a -> b) -> a -> b
$ \DynFlags
dflags ->
Char -> SDoc
char Char
'_' SDoc -> SDoc -> SDoc
<> DynFlags -> Unique -> SDoc
forall a. Outputable a => DynFlags -> a -> SDoc
pprUnique DynFlags
dflags Unique
uniq SDoc -> SDoc -> SDoc
<>
(if CmmType -> Bool
isWord32 CmmType
rep
then SDoc
dcolon SDoc -> SDoc -> SDoc
<> SDoc
ptr SDoc -> SDoc -> SDoc
<> CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
rep
else SDoc
dcolon SDoc -> SDoc -> SDoc
<> SDoc
ptr SDoc -> SDoc -> SDoc
<> CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
rep)
where
pprUnique :: DynFlags -> a -> SDoc
pprUnique DynFlags
dflags a
unique =
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SuppressUniques DynFlags
dflags
then String -> SDoc
text String
"_locVar_"
else a -> SDoc
forall a. Outputable a => a -> SDoc
ppr a
unique
ptr :: SDoc
ptr = SDoc
empty
pprArea :: Area -> SDoc
pprArea :: Area -> SDoc
pprArea Area
Old = String -> SDoc
text String
"old"
pprArea (Young BlockId
id) = [SDoc] -> SDoc
hcat [ String -> SDoc
text String
"young<", BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
id, String -> SDoc
text String
">" ]
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg :: GlobalReg -> SDoc
pprGlobalReg GlobalReg
gr
= case GlobalReg
gr of
VanillaReg Int
n VGcPtr
_ -> Char -> SDoc
char Char
'R' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
FloatReg Int
n -> Char -> SDoc
char Char
'F' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
DoubleReg Int
n -> Char -> SDoc
char Char
'D' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
LongReg Int
n -> Char -> SDoc
char Char
'L' SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
XmmReg Int
n -> String -> SDoc
text String
"XMM" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
YmmReg Int
n -> String -> SDoc
text String
"YMM" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
ZmmReg Int
n -> String -> SDoc
text String
"ZMM" SDoc -> SDoc -> SDoc
<> Int -> SDoc
int Int
n
GlobalReg
Sp -> String -> SDoc
text String
"Sp"
GlobalReg
SpLim -> String -> SDoc
text String
"SpLim"
GlobalReg
Hp -> String -> SDoc
text String
"Hp"
GlobalReg
HpLim -> String -> SDoc
text String
"HpLim"
GlobalReg
MachSp -> String -> SDoc
text String
"MachSp"
GlobalReg
UnwindReturnReg-> String -> SDoc
text String
"UnwindReturnReg"
GlobalReg
CCCS -> String -> SDoc
text String
"CCCS"
GlobalReg
CurrentTSO -> String -> SDoc
text String
"CurrentTSO"
GlobalReg
CurrentNursery -> String -> SDoc
text String
"CurrentNursery"
GlobalReg
HpAlloc -> String -> SDoc
text String
"HpAlloc"
GlobalReg
EagerBlackholeInfo -> String -> SDoc
text String
"stg_EAGER_BLACKHOLE_info"
GlobalReg
GCEnter1 -> String -> SDoc
text String
"stg_gc_enter_1"
GlobalReg
GCFun -> String -> SDoc
text String
"stg_gc_fun"
GlobalReg
BaseReg -> String -> SDoc
text String
"BaseReg"
GlobalReg
PicBaseReg -> String -> SDoc
text String
"PicBaseReg"
commafy :: [SDoc] -> SDoc
commafy :: [SDoc] -> SDoc
commafy [SDoc]
xs = [SDoc] -> SDoc
fsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
comma [SDoc]
xs