{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE UndecidableInstances #-}

module GHC.Cmm.Expr
    ( CmmExpr(..), cmmExprType, cmmExprWidth, cmmExprAlignment, maybeInvertCmmExpr
    , CmmReg(..), cmmRegType, cmmRegWidth
    , CmmLit(..), cmmLitType
    , AlignmentSpec(..)
      -- TODO: Remove:
    , LocalReg(..), localRegType
    , GlobalReg(..), isArgReg, globalRegType
    , spReg, hpReg, spLimReg, hpLimReg, nodeReg
    , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
    , node, baseReg
    , VGcPtr(..)

    , DefinerOfRegs, UserOfRegs
    , foldRegsDefd, foldRegsUsed
    , foldLocalRegsDefd, foldLocalRegsUsed

    , RegSet, LocalRegSet, GlobalRegSet
    , emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet
    , plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
    , regSetToList

    , isTrivialCmmExpr
    , hasNoGlobalRegs
    , isLit
    , isComparisonExpr

    , Area(..)
    , module GHC.Cmm.MachOp
    , module GHC.Cmm.Type
    )
where

import GHC.Prelude

import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.MachOp
import GHC.Cmm.Type
import GHC.Cmm.Reg
import GHC.Utils.Panic (panic)
import GHC.Utils.Outputable

import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
import Numeric ( fromRat )

import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf)

-----------------------------------------------------------------------------
--              CmmExpr
-- An expression.  Expressions have no side effects.
-----------------------------------------------------------------------------

data CmmExpr
  = CmmLit !CmmLit              -- Literal
  | CmmLoad !CmmExpr !CmmType !AlignmentSpec
                                -- Read memory location
  | CmmReg !CmmReg              -- Contents of register
  | CmmMachOp MachOp [CmmExpr]  -- Machine operation (+, -, *, etc.)
  | CmmStackSlot Area {-# UNPACK #-} !Int
                                -- Addressing expression of a stack slot
                                -- See Note [CmmStackSlot aliasing]
  | CmmRegOff !CmmReg !Int
        -- CmmRegOff reg i
        --        ** is shorthand only, meaning **
        -- CmmMachOp (MO_Add rep) [x, CmmLit (CmmInt (fromIntegral i) rep)]
        --      where rep = typeWidth (cmmRegType reg)
  deriving Int -> CmmExpr -> ShowS
[CmmExpr] -> ShowS
CmmExpr -> String
(Int -> CmmExpr -> ShowS)
-> (CmmExpr -> String) -> ([CmmExpr] -> ShowS) -> Show CmmExpr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CmmExpr -> ShowS
showsPrec :: Int -> CmmExpr -> ShowS
$cshow :: CmmExpr -> String
show :: CmmExpr -> String
$cshowList :: [CmmExpr] -> ShowS
showList :: [CmmExpr] -> ShowS
Show

instance Eq CmmExpr where       -- Equality ignores the types
  CmmLit CmmLit
l1          == :: CmmExpr -> CmmExpr -> Bool
== CmmLit CmmLit
l2          = CmmLit
l1CmmLit -> CmmLit -> Bool
forall a. Eq a => a -> a -> Bool
==CmmLit
l2
  CmmLoad CmmExpr
e1 CmmType
_ AlignmentSpec
_     == CmmLoad CmmExpr
e2 CmmType
_ AlignmentSpec
_     = CmmExpr
e1CmmExpr -> CmmExpr -> Bool
forall a. Eq a => a -> a -> Bool
==CmmExpr
e2
  CmmReg CmmReg
r1          == CmmReg CmmReg
r2          = CmmReg
r1CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
==CmmReg
r2
  CmmRegOff CmmReg
r1 Int
i1    == CmmRegOff CmmReg
r2 Int
i2    = CmmReg
r1CmmReg -> CmmReg -> Bool
forall a. Eq a => a -> a -> Bool
==CmmReg
r2 Bool -> Bool -> Bool
&& Int
i1Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
i2
  CmmMachOp MachOp
op1 [CmmExpr]
es1  == CmmMachOp MachOp
op2 [CmmExpr]
es2  = MachOp
op1MachOp -> MachOp -> Bool
forall a. Eq a => a -> a -> Bool
==MachOp
op2 Bool -> Bool -> Bool
&& [CmmExpr]
es1[CmmExpr] -> [CmmExpr] -> Bool
forall a. Eq a => a -> a -> Bool
==[CmmExpr]
es2
  CmmStackSlot Area
a1 Int
i1 == CmmStackSlot Area
a2 Int
i2 = Area
a1Area -> Area -> Bool
forall a. Eq a => a -> a -> Bool
==Area
a2 Bool -> Bool -> Bool
&& Int
i1Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
==Int
i2
  CmmExpr
_e1                == CmmExpr
_e2                = Bool
False

instance OutputableP Platform CmmExpr where
    pdoc :: Platform -> CmmExpr -> SDoc
pdoc = Platform -> CmmExpr -> SDoc
pprExpr

data AlignmentSpec = NaturallyAligned | Unaligned
  deriving (AlignmentSpec -> AlignmentSpec -> Bool
(AlignmentSpec -> AlignmentSpec -> Bool)
-> (AlignmentSpec -> AlignmentSpec -> Bool) -> Eq AlignmentSpec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: AlignmentSpec -> AlignmentSpec -> Bool
== :: AlignmentSpec -> AlignmentSpec -> Bool
$c/= :: AlignmentSpec -> AlignmentSpec -> Bool
/= :: AlignmentSpec -> AlignmentSpec -> Bool
Eq, Eq AlignmentSpec
Eq AlignmentSpec =>
(AlignmentSpec -> AlignmentSpec -> Ordering)
-> (AlignmentSpec -> AlignmentSpec -> Bool)
-> (AlignmentSpec -> AlignmentSpec -> Bool)
-> (AlignmentSpec -> AlignmentSpec -> Bool)
-> (AlignmentSpec -> AlignmentSpec -> Bool)
-> (AlignmentSpec -> AlignmentSpec -> AlignmentSpec)
-> (AlignmentSpec -> AlignmentSpec -> AlignmentSpec)
-> Ord AlignmentSpec
AlignmentSpec -> AlignmentSpec -> Bool
AlignmentSpec -> AlignmentSpec -> Ordering
AlignmentSpec -> AlignmentSpec -> AlignmentSpec
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: AlignmentSpec -> AlignmentSpec -> Ordering
compare :: AlignmentSpec -> AlignmentSpec -> Ordering
$c< :: AlignmentSpec -> AlignmentSpec -> Bool
< :: AlignmentSpec -> AlignmentSpec -> Bool
$c<= :: AlignmentSpec -> AlignmentSpec -> Bool
<= :: AlignmentSpec -> AlignmentSpec -> Bool
$c> :: AlignmentSpec -> AlignmentSpec -> Bool
> :: AlignmentSpec -> AlignmentSpec -> Bool
$c>= :: AlignmentSpec -> AlignmentSpec -> Bool
>= :: AlignmentSpec -> AlignmentSpec -> Bool
$cmax :: AlignmentSpec -> AlignmentSpec -> AlignmentSpec
max :: AlignmentSpec -> AlignmentSpec -> AlignmentSpec
$cmin :: AlignmentSpec -> AlignmentSpec -> AlignmentSpec
min :: AlignmentSpec -> AlignmentSpec -> AlignmentSpec
Ord, Int -> AlignmentSpec -> ShowS
[AlignmentSpec] -> ShowS
AlignmentSpec -> String
(Int -> AlignmentSpec -> ShowS)
-> (AlignmentSpec -> String)
-> ([AlignmentSpec] -> ShowS)
-> Show AlignmentSpec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> AlignmentSpec -> ShowS
showsPrec :: Int -> AlignmentSpec -> ShowS
$cshow :: AlignmentSpec -> String
show :: AlignmentSpec -> String
$cshowList :: [AlignmentSpec] -> ShowS
showList :: [AlignmentSpec] -> ShowS
Show)

-- | A stack area is either the stack slot where a variable is spilled
-- or the stack space where function arguments and results are passed.
data Area
  = Old            -- See Note [Old Area]
  | Young {-# UNPACK #-} !BlockId  -- Invariant: must be a continuation BlockId
                   -- See Note [Continuation BlockIds] in GHC.Cmm.Node.
  deriving (Area -> Area -> Bool
(Area -> Area -> Bool) -> (Area -> Area -> Bool) -> Eq Area
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Area -> Area -> Bool
== :: Area -> Area -> Bool
$c/= :: Area -> Area -> Bool
/= :: Area -> Area -> Bool
Eq, Eq Area
Eq Area =>
(Area -> Area -> Ordering)
-> (Area -> Area -> Bool)
-> (Area -> Area -> Bool)
-> (Area -> Area -> Bool)
-> (Area -> Area -> Bool)
-> (Area -> Area -> Area)
-> (Area -> Area -> Area)
-> Ord Area
Area -> Area -> Bool
Area -> Area -> Ordering
Area -> Area -> Area
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Area -> Area -> Ordering
compare :: Area -> Area -> Ordering
$c< :: Area -> Area -> Bool
< :: Area -> Area -> Bool
$c<= :: Area -> Area -> Bool
<= :: Area -> Area -> Bool
$c> :: Area -> Area -> Bool
> :: Area -> Area -> Bool
$c>= :: Area -> Area -> Bool
>= :: Area -> Area -> Bool
$cmax :: Area -> Area -> Area
max :: Area -> Area -> Area
$cmin :: Area -> Area -> Area
min :: Area -> Area -> Area
Ord, Int -> Area -> ShowS
[Area] -> ShowS
Area -> String
(Int -> Area -> ShowS)
-> (Area -> String) -> ([Area] -> ShowS) -> Show Area
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Area -> ShowS
showsPrec :: Int -> Area -> ShowS
$cshow :: Area -> String
show :: Area -> String
$cshowList :: [Area] -> ShowS
showList :: [Area] -> ShowS
Show)

instance Outputable Area where
    ppr :: Area -> SDoc
ppr Area
e = Area -> SDoc
pprArea Area
e

pprArea :: Area -> SDoc
pprArea :: Area -> SDoc
pprArea Area
Old        = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"old"
pprArea (Young BlockId
id) = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [ String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"young<", BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
id, String -> SDoc
forall doc. IsLine doc => String -> doc
text String
">" ]


{- Note [Old Area]
~~~~~~~~~~~~~~~~~~
There is a single call area 'Old', allocated at the extreme old
end of the stack frame (ie just younger than the return address)
which holds:
  * incoming (overflow) parameters,
  * outgoing (overflow) parameter to tail calls,
  * outgoing (overflow) result values
  * the update frame (if any)

Its size is the max of all these requirements.  On entry, the stack
pointer will point to the youngest incoming parameter, which is not
necessarily at the young end of the Old area.

End of note -}


{- Note [CmmStackSlot aliasing]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
When do two CmmStackSlots alias?

 - T[old+N] aliases with U[young(L)+M] for all T, U, L, N and M
 - T[old+N] aliases with U[old+M] only if the areas actually overlap

Or more informally, different Areas may overlap with each other.

An alternative semantics, that we previously had, was that different
Areas do not overlap.  The problem that lead to redefining the
semantics of stack areas is described below.

e.g. if we had

    x = Sp[old + 8]
    y = Sp[old + 16]

    Sp[young(L) + 8]  = L
    Sp[young(L) + 16] = y
    Sp[young(L) + 24] = x
    call f() returns to L

if areas semantically do not overlap, then we might optimise this to

    Sp[young(L) + 8]  = L
    Sp[young(L) + 16] = Sp[old + 8]
    Sp[young(L) + 24] = Sp[old + 16]
    call f() returns to L

and now young(L) cannot be allocated at the same place as old, and we
are doomed to use more stack.

  - old+8  conflicts with young(L)+8
  - old+16 conflicts with young(L)+16 and young(L)+8

so young(L)+8 == old+24 and we get

    Sp[-8]  = L
    Sp[-16] = Sp[8]
    Sp[-24] = Sp[0]
    Sp -= 24
    call f() returns to L

However, if areas are defined to be "possibly overlapping" in the
semantics, then we cannot commute any loads/stores of old with
young(L), and we will be able to re-use both old+8 and old+16 for
young(L).

    x = Sp[8]
    y = Sp[0]

    Sp[8] = L
    Sp[0] = y
    Sp[-8] = x
    Sp = Sp - 8
    call f() returns to L

Now, the assignments of y go away,

    x = Sp[8]
    Sp[8] = L
    Sp[-8] = x
    Sp = Sp - 8
    call f() returns to L
-}

data CmmLit
  = CmmInt !Integer  !Width
        -- Interpretation: the 2's complement representation of the value
        -- is truncated to the specified size.  This is easier than trying
        -- to keep the value within range, because we don't know whether
        -- it will be used as a signed or unsigned value (the CmmType doesn't
        -- distinguish between signed & unsigned).
  | CmmFloat  Rational !Width
  | CmmVec [CmmLit]                     -- Vector literal
  | CmmLabel    CLabel                  -- Address of label
  | CmmLabelOff CLabel !Int              -- Address of label + byte offset

        -- Due to limitations in the C backend, the following
        -- MUST ONLY be used inside the info table indicated by label2
        -- (label2 must be the info label), and label1 must be an
        -- SRT, a slow entrypoint or a large bitmap (see the Mangler)
        -- Don't use it at all unless tablesNextToCode.
        -- It is also used inside the NCG during when generating
        -- position-independent code.
  | CmmLabelDiffOff CLabel CLabel !Int !Width -- label1 - label2 + offset
        -- In an expression, the width just has the effect of MO_SS_Conv
        -- from wordWidth to the desired width.
        --
        -- In a static literal, the supported Widths depend on the
        -- architecture: wordWidth is supported on all
        -- architectures. Additionally W32 is supported on x86_64 when
        -- using the small memory model.

  | CmmBlock {-# UNPACK #-} !BlockId     -- Code label
        -- Invariant: must be a continuation BlockId
        -- See Note [Continuation BlockIds] in GHC.Cmm.Node.

  | CmmHighStackMark -- A late-bound constant that stands for the max
                     -- #bytes of stack space used during a procedure.
                     -- During the stack-layout pass, CmmHighStackMark
                     -- is replaced by a CmmInt for the actual number
                     -- of bytes used
  deriving (CmmLit -> CmmLit -> Bool
(CmmLit -> CmmLit -> Bool)
-> (CmmLit -> CmmLit -> Bool) -> Eq CmmLit
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CmmLit -> CmmLit -> Bool
== :: CmmLit -> CmmLit -> Bool
$c/= :: CmmLit -> CmmLit -> Bool
/= :: CmmLit -> CmmLit -> Bool
Eq, Int -> CmmLit -> ShowS
[CmmLit] -> ShowS
CmmLit -> String
(Int -> CmmLit -> ShowS)
-> (CmmLit -> String) -> ([CmmLit] -> ShowS) -> Show CmmLit
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> CmmLit -> ShowS
showsPrec :: Int -> CmmLit -> ShowS
$cshow :: CmmLit -> String
show :: CmmLit -> String
$cshowList :: [CmmLit] -> ShowS
showList :: [CmmLit] -> ShowS
Show)

instance OutputableP Platform CmmLit where
    pdoc :: Platform -> CmmLit -> SDoc
pdoc = Platform -> CmmLit -> SDoc
pprLit

instance Outputable CmmLit where
  ppr :: CmmLit -> SDoc
ppr (CmmInt Integer
n Width
w) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmInt" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Integer -> SDoc
forall a. Outputable a => a -> SDoc
ppr Integer
n SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w
  ppr (CmmFloat Rational
n Width
w) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmFloat" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text (Rational -> String
forall a. Show a => a -> String
show Rational
n) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
w
  ppr (CmmVec [CmmLit]
xs) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmVec" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [CmmLit] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [CmmLit]
xs
  ppr (CmmLabel CLabel
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmLabel"
  ppr (CmmLabelOff CLabel
_ Int
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmLabelOff"
  ppr (CmmLabelDiffOff CLabel
_ CLabel
_ Int
_ Width
_) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmLabelDiffOff"
  ppr (CmmBlock BlockId
blk) = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmBlock" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
blk
  ppr CmmLit
CmmHighStackMark = String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"CmmHighStackMark"

cmmExprType :: Platform -> CmmExpr -> CmmType
cmmExprType :: Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform = \case
   (CmmLit CmmLit
lit)        -> Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
lit
   (CmmLoad CmmExpr
_ CmmType
rep AlignmentSpec
_)   -> CmmType
rep
   (CmmReg CmmReg
reg)        -> Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg
   (CmmMachOp MachOp
op [CmmExpr]
args) -> Platform -> MachOp -> [CmmType] -> CmmType
machOpResultType Platform
platform MachOp
op ((CmmExpr -> CmmType) -> [CmmExpr] -> [CmmType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform) [CmmExpr]
args)
   (CmmRegOff CmmReg
reg Int
_)   -> Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg
   (CmmStackSlot Area
_ Int
_)  -> Platform -> CmmType
bWord Platform
platform -- an address
   -- Careful though: what is stored at the stack slot may be bigger than
   -- an address

cmmLitType :: Platform -> CmmLit -> CmmType
cmmLitType :: Platform -> CmmLit -> CmmType
cmmLitType Platform
platform = \case
   (CmmInt Integer
_ Width
width)     -> Width -> CmmType
cmmBits  Width
width
   (CmmFloat Rational
_ Width
width)   -> Width -> CmmType
cmmFloat Width
width
   (CmmVec [])          -> String -> CmmType
forall a. HasCallStack => String -> a
panic String
"cmmLitType: CmmVec []"
   (CmmVec (CmmLit
l:[CmmLit]
ls))      -> let ty :: CmmType
ty = Platform -> CmmLit -> CmmType
cmmLitType Platform
platform CmmLit
l
                          in if (CmmType -> Bool) -> [CmmType] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (CmmType -> CmmType -> Bool
`cmmEqType` CmmType
ty) ((CmmLit -> CmmType) -> [CmmLit] -> [CmmType]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmLit -> CmmType
cmmLitType Platform
platform) [CmmLit]
ls)
                               then Int -> CmmType -> CmmType
cmmVec (Int
1Int -> Int -> Int
forall a. Num a => a -> a -> a
+[CmmLit] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [CmmLit]
ls) CmmType
ty
                               else String -> CmmType
forall a. HasCallStack => String -> a
panic String
"cmmLitType: CmmVec"
   (CmmLabel CLabel
lbl)       -> Platform -> CLabel -> CmmType
cmmLabelType Platform
platform CLabel
lbl
   (CmmLabelOff CLabel
lbl Int
_)  -> Platform -> CLabel -> CmmType
cmmLabelType Platform
platform CLabel
lbl
   (CmmLabelDiffOff CLabel
_ CLabel
_ Int
_ Width
width) -> Width -> CmmType
cmmBits Width
width
   (CmmBlock BlockId
_)         -> Platform -> CmmType
bWord Platform
platform
   (CmmLit
CmmHighStackMark)   -> Platform -> CmmType
bWord Platform
platform

cmmLabelType :: Platform -> CLabel -> CmmType
cmmLabelType :: Platform -> CLabel -> CmmType
cmmLabelType Platform
platform CLabel
lbl
 | CLabel -> Bool
isGcPtrLabel CLabel
lbl = Platform -> CmmType
gcWord Platform
platform
 | Bool
otherwise        = Platform -> CmmType
bWord Platform
platform

cmmExprWidth :: Platform -> CmmExpr -> Width
cmmExprWidth :: Platform -> CmmExpr -> Width
cmmExprWidth Platform
platform CmmExpr
e = CmmType -> Width
typeWidth (Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
e)

-- | Returns an alignment in bytes of a CmmExpr when it's a statically
-- known integer constant, otherwise returns an alignment of 1 byte.
-- The caller is responsible for using with a sensible CmmExpr
-- argument.
cmmExprAlignment :: CmmExpr -> Alignment
cmmExprAlignment :: CmmExpr -> Alignment
cmmExprAlignment (CmmLit (CmmInt Integer
intOff Width
_)) = Int -> Alignment
alignmentOf (Integer -> Int
forall a. Num a => Integer -> a
fromInteger Integer
intOff)
cmmExprAlignment CmmExpr
_                          = Int -> Alignment
mkAlignment Int
1
--------
--- Negation for conditional branches

maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
maybeInvertCmmExpr :: CmmExpr -> Maybe CmmExpr
maybeInvertCmmExpr (CmmMachOp MachOp
op [CmmExpr]
args) = do MachOp
op' <- MachOp -> Maybe MachOp
maybeInvertComparison MachOp
op
                                            CmmExpr -> Maybe CmmExpr
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
op' [CmmExpr]
args)
maybeInvertCmmExpr CmmExpr
_ = Maybe CmmExpr
forall a. Maybe a
Nothing

---------------------------------------------------
--         CmmExpr predicates
---------------------------------------------------

isTrivialCmmExpr :: CmmExpr -> Bool
isTrivialCmmExpr :: CmmExpr -> Bool
isTrivialCmmExpr (CmmLoad CmmExpr
_ CmmType
_ AlignmentSpec
_)    = Bool
False
isTrivialCmmExpr (CmmMachOp MachOp
_ [CmmExpr]
_)    = Bool
False
isTrivialCmmExpr (CmmLit CmmLit
_)         = Bool
True
isTrivialCmmExpr (CmmReg CmmReg
_)         = Bool
True
isTrivialCmmExpr (CmmRegOff CmmReg
_ Int
_)    = Bool
True
isTrivialCmmExpr (CmmStackSlot Area
_ Int
_) = String -> Bool
forall a. HasCallStack => String -> a
panic String
"isTrivialCmmExpr CmmStackSlot"

hasNoGlobalRegs :: CmmExpr -> Bool
hasNoGlobalRegs :: CmmExpr -> Bool
hasNoGlobalRegs (CmmLoad CmmExpr
e CmmType
_ AlignmentSpec
_)            = CmmExpr -> Bool
hasNoGlobalRegs CmmExpr
e
hasNoGlobalRegs (CmmMachOp MachOp
_ [CmmExpr]
es)           = (CmmExpr -> Bool) -> [CmmExpr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all CmmExpr -> Bool
hasNoGlobalRegs [CmmExpr]
es
hasNoGlobalRegs (CmmLit CmmLit
_)                 = Bool
True
hasNoGlobalRegs (CmmReg (CmmLocal LocalReg
_))      = Bool
True
hasNoGlobalRegs (CmmRegOff (CmmLocal LocalReg
_) Int
_) = Bool
True
hasNoGlobalRegs CmmExpr
_                          = Bool
False

isLit :: CmmExpr -> Bool
isLit :: CmmExpr -> Bool
isLit (CmmLit CmmLit
_) = Bool
True
isLit CmmExpr
_          = Bool
False

isComparisonExpr :: CmmExpr -> Bool
isComparisonExpr :: CmmExpr -> Bool
isComparisonExpr (CmmMachOp MachOp
op [CmmExpr]
_) = MachOp -> Bool
isComparisonMachOp MachOp
op
isComparisonExpr CmmExpr
_                = Bool
False


-----------------------------------------------------------------------------
--    Register-use information for expressions and other types
-----------------------------------------------------------------------------

-- | Sets of registers

-- These are used for dataflow facts, and a common operation is taking
-- the union of two RegSets and then asking whether the union is the
-- same as one of the inputs.  UniqSet isn't good here, because
-- sizeUniqSet is O(n) whereas Set.size is O(1), so we use ordinary
-- Sets.

type RegSet r     = Set r
type LocalRegSet  = RegSet LocalReg
type GlobalRegSet = RegSet GlobalReg

emptyRegSet             :: RegSet r
nullRegSet              :: RegSet r -> Bool
elemRegSet              :: Ord r => r -> RegSet r -> Bool
extendRegSet            :: Ord r => RegSet r -> r -> RegSet r
deleteFromRegSet        :: Ord r => RegSet r -> r -> RegSet r
mkRegSet                :: Ord r => [r] -> RegSet r
minusRegSet, plusRegSet, timesRegSet :: Ord r => RegSet r -> RegSet r -> RegSet r
sizeRegSet              :: RegSet r -> Int
regSetToList            :: RegSet r -> [r]

emptyRegSet :: forall r. RegSet r
emptyRegSet      = Set r
forall r. RegSet r
Set.empty
nullRegSet :: forall r. RegSet r -> Bool
nullRegSet       = Set r -> Bool
forall r. RegSet r -> Bool
Set.null
elemRegSet :: forall r. Ord r => r -> RegSet r -> Bool
elemRegSet       = r -> Set r -> Bool
forall r. Ord r => r -> RegSet r -> Bool
Set.member
extendRegSet :: forall r. Ord r => RegSet r -> r -> RegSet r
extendRegSet     = (r -> RegSet r -> RegSet r) -> RegSet r -> r -> RegSet r
forall a b c. (a -> b -> c) -> b -> a -> c
flip r -> RegSet r -> RegSet r
forall a. Ord a => a -> Set a -> Set a
Set.insert
deleteFromRegSet :: forall r. Ord r => RegSet r -> r -> RegSet r
deleteFromRegSet = (r -> RegSet r -> RegSet r) -> RegSet r -> r -> RegSet r
forall a b c. (a -> b -> c) -> b -> a -> c
flip r -> RegSet r -> RegSet r
forall a. Ord a => a -> Set a -> Set a
Set.delete
mkRegSet :: forall r. Ord r => [r] -> RegSet r
mkRegSet         = [r] -> Set r
forall r. Ord r => [r] -> RegSet r
Set.fromList
minusRegSet :: forall r. Ord r => RegSet r -> RegSet r -> RegSet r
minusRegSet      = Set r -> Set r -> Set r
forall r. Ord r => RegSet r -> RegSet r -> RegSet r
Set.difference
plusRegSet :: forall r. Ord r => RegSet r -> RegSet r -> RegSet r
plusRegSet       = Set r -> Set r -> Set r
forall r. Ord r => RegSet r -> RegSet r -> RegSet r
Set.union
timesRegSet :: forall r. Ord r => RegSet r -> RegSet r -> RegSet r
timesRegSet      = Set r -> Set r -> Set r
forall r. Ord r => RegSet r -> RegSet r -> RegSet r
Set.intersection
sizeRegSet :: forall r. RegSet r -> Int
sizeRegSet       = Set r -> Int
forall r. RegSet r -> Int
Set.size
regSetToList :: forall r. RegSet r -> [r]
regSetToList     = Set r -> [r]
forall r. RegSet r -> [r]
Set.toList

class Ord r => UserOfRegs r a where
  foldRegsUsed :: Platform -> (b -> r -> b) -> b -> a -> b

foldLocalRegsUsed :: UserOfRegs LocalReg a
                  => Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed :: forall a b.
UserOfRegs LocalReg a =>
Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsUsed = Platform -> (b -> LocalReg -> b) -> b -> a -> b
forall b. Platform -> (b -> LocalReg -> b) -> b -> a -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed

class Ord r => DefinerOfRegs r a where
  foldRegsDefd :: Platform -> (b -> r -> b) -> b -> a -> b

foldLocalRegsDefd :: DefinerOfRegs LocalReg a
                  => Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsDefd :: forall a b.
DefinerOfRegs LocalReg a =>
Platform -> (b -> LocalReg -> b) -> b -> a -> b
foldLocalRegsDefd = Platform -> (b -> LocalReg -> b) -> b -> a -> b
forall b. Platform -> (b -> LocalReg -> b) -> b -> a -> b
forall r a b.
DefinerOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsDefd

instance UserOfRegs LocalReg CmmReg where
    foldRegsUsed :: forall b. Platform -> (b -> LocalReg -> b) -> b -> CmmReg -> b
foldRegsUsed Platform
_ b -> LocalReg -> b
f b
z (CmmLocal LocalReg
reg) = b -> LocalReg -> b
f b
z LocalReg
reg
    foldRegsUsed Platform
_ b -> LocalReg -> b
_ b
z (CmmGlobal GlobalReg
_)  = b
z

instance DefinerOfRegs LocalReg CmmReg where
    foldRegsDefd :: forall b. Platform -> (b -> LocalReg -> b) -> b -> CmmReg -> b
foldRegsDefd Platform
_ b -> LocalReg -> b
f b
z (CmmLocal LocalReg
reg) = b -> LocalReg -> b
f b
z LocalReg
reg
    foldRegsDefd Platform
_ b -> LocalReg -> b
_ b
z (CmmGlobal GlobalReg
_)  = b
z

instance UserOfRegs GlobalReg CmmReg where
    {-# INLINEABLE foldRegsUsed #-}
    foldRegsUsed :: forall b. Platform -> (b -> GlobalReg -> b) -> b -> CmmReg -> b
foldRegsUsed Platform
_ b -> GlobalReg -> b
_ b
z (CmmLocal LocalReg
_)    = b
z
    foldRegsUsed Platform
_ b -> GlobalReg -> b
f b
z (CmmGlobal GlobalReg
reg) = b -> GlobalReg -> b
f b
z GlobalReg
reg

instance DefinerOfRegs GlobalReg CmmReg where
    foldRegsDefd :: forall b. Platform -> (b -> GlobalReg -> b) -> b -> CmmReg -> b
foldRegsDefd Platform
_ b -> GlobalReg -> b
_ b
z (CmmLocal LocalReg
_)    = b
z
    foldRegsDefd Platform
_ b -> GlobalReg -> b
f b
z (CmmGlobal GlobalReg
reg) = b -> GlobalReg -> b
f b
z GlobalReg
reg

instance Ord r => UserOfRegs r r where
    foldRegsUsed :: forall b. Platform -> (b -> r -> b) -> b -> r -> b
foldRegsUsed Platform
_ b -> r -> b
f b
z r
r = b -> r -> b
f b
z r
r

instance Ord r => DefinerOfRegs r r where
    foldRegsDefd :: forall b. Platform -> (b -> r -> b) -> b -> r -> b
foldRegsDefd Platform
_ b -> r -> b
f b
z r
r = b -> r -> b
f b
z r
r

instance (Ord r, UserOfRegs r CmmReg) => UserOfRegs r CmmExpr where
  -- The (Ord r) in the context is necessary here
  -- See Note [Recursive superclasses] in GHC.Tc.TyCl.Instance
  {-# INLINEABLE foldRegsUsed #-}
  foldRegsUsed :: forall b. Platform -> (b -> r -> b) -> b -> CmmExpr -> b
foldRegsUsed Platform
platform b -> r -> b
f !b
z CmmExpr
e = b -> CmmExpr -> b
expr b
z CmmExpr
e
    where expr :: b -> CmmExpr -> b
expr b
z (CmmLit CmmLit
_)          = b
z
          expr b
z (CmmLoad CmmExpr
addr CmmType
_ AlignmentSpec
_)  = Platform -> (b -> r -> b) -> b -> CmmExpr -> b
forall b. Platform -> (b -> r -> b) -> b -> CmmExpr -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> r -> b
f b
z CmmExpr
addr
          expr b
z (CmmReg CmmReg
r)          = Platform -> (b -> r -> b) -> b -> CmmReg -> b
forall b. Platform -> (b -> r -> b) -> b -> CmmReg -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> r -> b
f b
z CmmReg
r
          expr b
z (CmmMachOp MachOp
_ [CmmExpr]
exprs) = Platform -> (b -> r -> b) -> b -> [CmmExpr] -> b
forall b. Platform -> (b -> r -> b) -> b -> [CmmExpr] -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> r -> b
f b
z [CmmExpr]
exprs
          expr b
z (CmmRegOff CmmReg
r Int
_)     = Platform -> (b -> r -> b) -> b -> CmmReg -> b
forall b. Platform -> (b -> r -> b) -> b -> CmmReg -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> r -> b
f b
z CmmReg
r
          expr b
z (CmmStackSlot Area
_ Int
_)  = b
z

instance UserOfRegs r a => UserOfRegs r [a] where
  foldRegsUsed :: forall b. Platform -> (b -> r -> b) -> b -> [a] -> b
foldRegsUsed Platform
platform b -> r -> b
f b
set [a]
as = (b -> a -> b) -> b -> [a] -> b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Platform -> (b -> r -> b) -> b -> a -> b
forall b. Platform -> (b -> r -> b) -> b -> a -> b
forall r a b.
UserOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsUsed Platform
platform b -> r -> b
f) b
set [a]
as
  {-# INLINABLE foldRegsUsed #-}

instance DefinerOfRegs r a => DefinerOfRegs r [a] where
  foldRegsDefd :: forall b. Platform -> (b -> r -> b) -> b -> [a] -> b
foldRegsDefd Platform
platform b -> r -> b
f b
set [a]
as = (b -> a -> b) -> b -> [a] -> b
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' (Platform -> (b -> r -> b) -> b -> a -> b
forall b. Platform -> (b -> r -> b) -> b -> a -> b
forall r a b.
DefinerOfRegs r a =>
Platform -> (b -> r -> b) -> b -> a -> b
foldRegsDefd Platform
platform b -> r -> b
f) b
set [a]
as
  {-# INLINABLE foldRegsDefd #-}

-- --------------------------------------------------------------------------
-- Pretty-printing expressions
-- --------------------------------------------------------------------------

pprExpr :: Platform -> CmmExpr -> SDoc
pprExpr :: Platform -> CmmExpr -> SDoc
pprExpr Platform
platform CmmExpr
e
    = case CmmExpr
e of
        CmmRegOff CmmReg
reg Int
i ->
                Platform -> CmmExpr -> SDoc
pprExpr Platform
platform (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 (Platform -> CmmReg -> CmmType
cmmRegType Platform
platform CmmReg
reg)
        CmmLit CmmLit
lit -> Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit
        CmmExpr
_other     -> Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform CmmExpr
e

-- Here's the precedence table from GHC.Cmm.Parser:
-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
-- %left '|'
-- %left '^'
-- %left '&'
-- %left '>>' '<<'
-- %left '-' '+'
-- %left '/' '*' '%'
-- %right '~'

-- We just cope with the common operators for now, the rest will get
-- a default conservative behaviour.

-- %nonassoc '>=' '>' '<=' '<' '!=' '=='
pprExpr1, pprExpr7, pprExpr8 :: Platform -> CmmExpr -> SDoc
pprExpr1 :: Platform -> CmmExpr -> SDoc
pprExpr1 Platform
platform (CmmMachOp MachOp
op [CmmExpr
x,CmmExpr
y])
   | Just SDoc
doc <- MachOp -> Maybe SDoc
infixMachOp1 MachOp
op
   = Platform -> CmmExpr -> SDoc
pprExpr7 Platform
platform CmmExpr
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
pprExpr7 Platform
platform CmmExpr
y
pprExpr1 Platform
platform CmmExpr
e = Platform -> CmmExpr -> SDoc
pprExpr7 Platform
platform 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
forall doc. IsLine doc => String -> doc
text String
"==")
infixMachOp1 (MO_Ne     Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"!=")
infixMachOp1 (MO_Shl    Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<<")
infixMachOp1 (MO_U_Shr  Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
">>")
infixMachOp1 (MO_U_Ge   Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
">=")
infixMachOp1 (MO_U_Le   Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<=")
infixMachOp1 (MO_U_Gt   Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'>')
infixMachOp1 (MO_U_Lt   Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'<')
infixMachOp1 MachOp
_             = Maybe SDoc
forall a. Maybe a
Nothing

-- %left '-' '+'
pprExpr7 :: Platform -> CmmExpr -> SDoc
pprExpr7 Platform
platform (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
   = Platform -> CmmExpr -> SDoc
pprExpr7 Platform
platform (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 Platform
platform (CmmMachOp MachOp
op [CmmExpr
x,CmmExpr
y])
   | Just SDoc
doc <- MachOp -> Maybe SDoc
infixMachOp7 MachOp
op
   = Platform -> CmmExpr -> SDoc
pprExpr7 Platform
platform CmmExpr
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
pprExpr8 Platform
platform CmmExpr
y
pprExpr7 Platform
platform CmmExpr
e = Platform -> CmmExpr -> SDoc
pprExpr8 Platform
platform CmmExpr
e

infixMachOp7 :: MachOp -> Maybe SDoc
infixMachOp7 (MO_Add Width
_)  = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+')
infixMachOp7 (MO_Sub Width
_)  = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'-')
infixMachOp7 MachOp
_           = Maybe SDoc
forall a. Maybe a
Nothing

-- %left '/' '*' '%'
pprExpr8 :: Platform -> CmmExpr -> SDoc
pprExpr8 Platform
platform (CmmMachOp MachOp
op [CmmExpr
x,CmmExpr
y])
   | Just SDoc
doc <- MachOp -> Maybe SDoc
infixMachOp8 MachOp
op
   = Platform -> CmmExpr -> SDoc
pprExpr8 Platform
platform CmmExpr
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
pprExpr9 Platform
platform CmmExpr
y
pprExpr8 Platform
platform CmmExpr
e = Platform -> CmmExpr -> SDoc
pprExpr9 Platform
platform CmmExpr
e

infixMachOp8 :: MachOp -> Maybe SDoc
infixMachOp8 (MO_U_Quot Width
_) = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'/')
infixMachOp8 (MO_Mul Width
_)    = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'*')
infixMachOp8 (MO_U_Rem Width
_)  = SDoc -> Maybe SDoc
forall a. a -> Maybe a
Just (Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'%')
infixMachOp8 MachOp
_             = Maybe SDoc
forall a. Maybe a
Nothing

pprExpr9 :: Platform -> CmmExpr -> SDoc
pprExpr9 :: Platform -> CmmExpr -> SDoc
pprExpr9 Platform
platform CmmExpr
e =
   case CmmExpr
e of
        CmmLit    CmmLit
lit       -> Platform -> CmmLit -> SDoc
pprLit1 Platform
platform CmmLit
lit
        CmmLoad   CmmExpr
expr CmmType
rep AlignmentSpec
align
                            -> let align_mark :: SDoc
align_mark =
                                       case AlignmentSpec
align of
                                         AlignmentSpec
NaturallyAligned -> SDoc
forall doc. IsOutput doc => doc
empty
                                         AlignmentSpec
Unaligned        -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"^"
                                in CmmType -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmType
rep SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
align_mark SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
brackets (Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
expr)
        CmmReg    CmmReg
reg       -> CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReg
reg
        CmmRegOff  CmmReg
reg Int
off  -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (CmmReg -> SDoc
forall a. Outputable a => a -> SDoc
ppr CmmReg
reg 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
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
off)
        CmmStackSlot Area
a Int
off  -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Area -> SDoc
forall a. Outputable a => a -> SDoc
ppr Area
a   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
<+> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
off)
        CmmMachOp MachOp
mop [CmmExpr]
args  -> Platform -> MachOp -> [CmmExpr] -> SDoc
genMachOp Platform
platform MachOp
mop [CmmExpr]
args

genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
genMachOp Platform
platform MachOp
mop [CmmExpr]
args
   | Just SDoc
doc <- MachOp -> Maybe SDoc
infixMachOp MachOp
mop = case [CmmExpr]
args of
        -- dyadic
        [CmmExpr
x,CmmExpr
y] -> Platform -> CmmExpr -> SDoc
pprExpr9 Platform
platform CmmExpr
x SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
pprExpr9 Platform
platform CmmExpr
y

        -- unary
        [CmmExpr
x]   -> SDoc
doc SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Platform -> CmmExpr -> SDoc
pprExpr9 Platform
platform CmmExpr
x

        [CmmExpr]
_     -> String -> SDoc -> SDoc -> SDoc
forall a. String -> SDoc -> a -> a
pprTrace String
"GHC.Cmm.Expr.genMachOp: machop with strange number of args"
                          (MachOp -> SDoc
pprMachOp MachOp
mop SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+>
                            SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma ((CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> SDoc
pprExpr Platform
platform) [CmmExpr]
args)))
                          SDoc
forall doc. IsOutput doc => doc
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
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmExpr -> SDoc
pprExpr Platform
platform (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp MachOp
mop [CmmExpr]
args))

   | Bool
otherwise = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'%' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
ppr_op SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens ([SDoc] -> SDoc
commafy ((CmmExpr -> SDoc) -> [CmmExpr] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmExpr -> SDoc
pprExpr Platform
platform) [CmmExpr]
args))
        where ppr_op :: SDoc
ppr_op = String -> SDoc
forall doc. IsLine doc => String -> doc
text ((Char -> Char) -> ShowS
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))
                -- replace spaces in (show mop) with underscores,

--
-- Unsigned ops on the word size of the machine get nice symbols.
-- All else get dumped in their ugly format.
--
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
forall doc. IsLine doc => Char -> doc
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
forall doc. IsLine doc => Char -> doc
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
forall doc. IsLine doc => Char -> doc
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
forall doc. IsLine doc => Char -> doc
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
forall doc. IsLine doc => Char -> doc
char Char
'-' -- there is no unsigned neg :)
            MachOp
_ -> Maybe SDoc
forall a. Maybe a
Nothing

-- --------------------------------------------------------------------------
-- Pretty-printing literals
--
--  To minimise line noise we adopt the convention that if the literal
--  has the natural machine word size, we do not append the type
-- --------------------------------------------------------------------------

pprLit :: Platform -> CmmLit -> SDoc
pprLit :: Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit = case CmmLit
lit of
    CmmInt Integer
i Width
rep ->
        [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hcat [ (if Integer
i Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
0 then SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens else SDoc -> SDoc
forall a. a -> a
id)(Integer -> SDoc
forall doc. IsLine doc => Integer -> doc
integer Integer
i)
             , Bool -> SDoc -> SDoc
forall doc. IsOutput doc => Bool -> doc -> doc
ppUnless (Width
rep Width -> Width -> Bool
forall a. Eq a => a -> a -> Bool
== Platform -> Width
wordWidth Platform
platform) (SDoc -> SDoc) -> SDoc -> SDoc
forall a b. (a -> b) -> a -> b
$
               SDoc
forall doc. IsLine doc => doc
space SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Width -> SDoc
forall a. Outputable a => a -> SDoc
ppr Width
rep ]

    CmmFloat Rational
f Width
rep     -> [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
hsep [ Double -> SDoc
forall doc. IsLine doc => Double -> doc
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
forall doc. IsLine doc => Char -> doc
char Char
'<' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> [SDoc] -> SDoc
commafy ((CmmLit -> SDoc) -> [CmmLit] -> [SDoc]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> CmmLit -> SDoc
pprLit Platform
platform) [CmmLit]
lits) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'>'
    CmmLabel CLabel
clbl      -> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
clbl
    CmmLabelOff CLabel
clbl Int
i -> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
clbl SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
ppr_offset Int
i
    CmmLabelDiffOff CLabel
clbl1 CLabel
clbl2 Int
i Width
_ -> Platform -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
clbl1 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 -> CLabel -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CLabel
clbl2 SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
ppr_offset Int
i
    CmmBlock BlockId
id        -> BlockId -> SDoc
forall a. Outputable a => a -> SDoc
ppr BlockId
id
    CmmLit
CmmHighStackMark -> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"<highSp>"

pprLit1 :: Platform -> CmmLit -> SDoc
pprLit1 :: Platform -> CmmLit -> SDoc
pprLit1 Platform
platform lit :: CmmLit
lit@(CmmLabelOff {}) = SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (Platform -> CmmLit -> SDoc
pprLit Platform
platform CmmLit
lit)
pprLit1 Platform
platform CmmLit
lit                  = Platform -> CmmLit -> SDoc
pprLit Platform
platform 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
forall doc. IsOutput doc => doc
empty
    | Int
iInt -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>=Int
0      = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'+' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int Int
i
    | Bool
otherwise = Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'-' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Int -> SDoc
forall doc. IsLine doc => Int -> doc
int (-Int
i)

commafy :: [SDoc] -> SDoc
commafy :: [SDoc] -> SDoc
commafy [SDoc]
xs = [SDoc] -> SDoc
forall doc. IsLine doc => [doc] -> doc
fsep ([SDoc] -> SDoc) -> [SDoc] -> SDoc
forall a b. (a -> b) -> a -> b
$ SDoc -> [SDoc] -> [SDoc]
forall doc. IsLine doc => doc -> [doc] -> [doc]
punctuate SDoc
forall doc. IsLine doc => doc
comma [SDoc]
xs