summaryrefslogtreecommitdiff
path: root/compiler
diff options
context:
space:
mode:
Diffstat (limited to 'compiler')
-rw-r--r--compiler/GHC/Cmm.hs179
-rw-r--r--compiler/GHC/Cmm/CLabel.hs3
-rw-r--r--compiler/GHC/Cmm/CallConv.hs1
-rw-r--r--compiler/GHC/Cmm/Dataflow/Graph.hs4
-rw-r--r--compiler/GHC/Cmm/DebugBlock.hs3
-rw-r--r--compiler/GHC/Cmm/Expr.hs473
-rw-r--r--compiler/GHC/Cmm/Lint.hs1
-rw-r--r--compiler/GHC/Cmm/Liveness.hs1
-rw-r--r--compiler/GHC/Cmm/Node.hs219
-rw-r--r--compiler/GHC/Cmm/Ppr.hs319
-rw-r--r--compiler/GHC/Cmm/Ppr/Decl.hs172
-rw-r--r--compiler/GHC/Cmm/Ppr/Expr.hs299
-rw-r--r--compiler/GHC/Cmm/ProcPoint.hs1
-rw-r--r--compiler/GHC/Cmm/Reg.hs372
-rw-r--r--compiler/GHC/Cmm/Type.hs8
-rw-r--r--compiler/GHC/Cmm/Utils.hs46
-rw-r--r--compiler/GHC/CmmToAsm.hs1
-rw-r--r--compiler/GHC/CmmToAsm/AArch64/Ppr.hs1
-rw-r--r--compiler/GHC/CmmToAsm/CFG.hs1
-rw-r--r--compiler/GHC/CmmToAsm/PPC/CodeGen.hs5
-rw-r--r--compiler/GHC/CmmToAsm/PPC/Ppr.hs1
-rw-r--r--compiler/GHC/CmmToC.hs3
-rw-r--r--compiler/GHC/CmmToLlvm.hs1
-rw-r--r--compiler/GHC/CmmToLlvm/Base.hs1
-rw-r--r--compiler/GHC/CmmToLlvm/CodeGen.hs7
-rw-r--r--compiler/GHC/StgToCmm/Closure.hs1
-rw-r--r--compiler/GHC/StgToCmm/Expr.hs3
-rw-r--r--compiler/GHC/StgToCmm/Sequel.hs1
-rw-r--r--compiler/ghc.cabal.in4
29 files changed, 997 insertions, 1134 deletions
diff --git a/compiler/GHC/Cmm.hs b/compiler/GHC/Cmm.hs
index 4f8bdbd77a..797940c5a2 100644
--- a/compiler/GHC/Cmm.hs
+++ b/compiler/GHC/Cmm.hs
@@ -6,13 +6,13 @@
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleInstances #-}
-
+{-# LANGUAGE FlexibleContexts #-}
module GHC.Cmm (
-- * Cmm top-level datatypes
CmmProgram, CmmGroup, CmmGroupSRTs, RawCmmGroup, GenCmmGroup,
CmmDecl, CmmDeclSRTs, GenCmmDecl(..),
- CmmGraph, GenCmmGraph(..),
+ CmmGraph, GenCmmGraph(..), toBlockMap, revPostorder,
CmmBlock, RawCmmDecl,
Section(..), SectionType(..),
GenCmmStatics(..), type CmmStatics, type RawCmmStatics, CmmStatic(..),
@@ -30,10 +30,14 @@ module GHC.Cmm (
-- * Statements, expressions and types
module GHC.Cmm.Node,
module GHC.Cmm.Expr,
+
+ -- * Pretty-printing
+ pprCmms, pprCmmGroup, pprSection, pprStatic
) where
import GHC.Prelude
+import GHC.Platform
import GHC.Types.Id
import GHC.Types.CostCentre
import GHC.Cmm.CLabel
@@ -46,7 +50,10 @@ import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Label
import GHC.Utils.Outputable
+
+import Data.List (intersperse)
import Data.ByteString (ByteString)
+import qualified Data.ByteString as BS
-----------------------------------------------------------------------------
-- Cmm, GenCmm
@@ -102,6 +109,10 @@ data GenCmmDecl d h g
deriving (Functor)
+instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)
+ => OutputableP Platform (GenCmmDecl d info i) where
+ pdoc = pprTop
+
type CmmDecl = GenCmmDecl CmmStatics CmmTopInfo CmmGraph
type CmmDeclSRTs = GenCmmDecl RawCmmStatics CmmTopInfo CmmGraph
@@ -119,6 +130,26 @@ type CmmGraph = GenCmmGraph CmmNode
data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C }
type CmmBlock = Block CmmNode C C
+instance OutputableP Platform CmmGraph where
+ pdoc = pprCmmGraph
+
+toBlockMap :: CmmGraph -> LabelMap CmmBlock
+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
+
+pprCmmGraph :: Platform -> CmmGraph -> SDoc
+pprCmmGraph platform g
+ = text "{" <> text "offset"
+ $$ nest 2 (vcat $ map (pdoc platform) blocks)
+ $$ text "}"
+ where blocks = revPostorder g
+ -- revPostorder has the side-effect of discarding unreachable code,
+ -- so pretty-printed Cmm will omit any unreachable blocks. This can
+ -- sometimes be confusing.
+
+revPostorder :: CmmGraph -> [CmmBlock]
+revPostorder g = {-# SCC "revPostorder" #-}
+ revPostorderFrom (toBlockMap g) (g_entry g)
+
-----------------------------------------------------------------------------
-- Info Tables
-----------------------------------------------------------------------------
@@ -128,6 +159,14 @@ type CmmBlock = Block CmmNode C C
data CmmTopInfo = TopInfo { info_tbls :: LabelMap CmmInfoTable
, stack_info :: CmmStackInfo }
+instance OutputableP Platform CmmTopInfo where
+ pdoc = pprTopInfo
+
+pprTopInfo :: Platform -> CmmTopInfo -> SDoc
+pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
+ vcat [text "info_tbls: " <> pdoc platform info_tbl,
+ text "stack_info: " <> ppr stack_info]
+
topInfoTable :: GenCmmDecl a CmmTopInfo (GenCmmGraph n) -> Maybe CmmInfoTable
topInfoTable (CmmProc infos _ _ g) = mapLookup (g_entry g) (info_tbls infos)
topInfoTable _ = Nothing
@@ -145,6 +184,13 @@ data CmmStackInfo
-- we want to do the stack manipulation manually.
}
+instance Outputable CmmStackInfo where
+ ppr = pprStackInfo
+
+pprStackInfo :: CmmStackInfo -> SDoc
+pprStackInfo (StackInfo {arg_space=arg_space}) =
+ text "arg_space: " <> ppr arg_space
+
-- | Info table as a haskell data type
data CmmInfoTable
= CmmInfoTable {
@@ -169,6 +215,10 @@ data CmmInfoTable
-- GHC.Cmm.Info.Build.doSRTs.
} deriving Eq
+instance OutputableP Platform CmmInfoTable where
+ pdoc = pprInfoTable
+
+
data ProfilingInfo
= NoProfilingInfo
| ProfilingInfo ByteString ByteString -- closure_type, closure_desc
@@ -233,6 +283,9 @@ data CmmStatic
| CmmFileEmbed FilePath
-- ^ an embedded binary file
+instance OutputableP Platform CmmStatic where
+ pdoc = pprStatic
+
instance Outputable CmmStatic where
ppr (CmmStaticLit lit) = text "CmmStaticLit" <+> ppr lit
ppr (CmmUninitialised n) = text "CmmUninitialised" <+> ppr n
@@ -254,6 +307,9 @@ data GenCmmStatics (rawOnly :: Bool) where
-> [CmmStatic] -- The static data itself
-> GenCmmStatics a
+instance OutputableP Platform (GenCmmStatics a) where
+ pdoc = pprStatics
+
type CmmStatics = GenCmmStatics 'False
type RawCmmStatics = GenCmmStatics 'True
@@ -293,3 +349,122 @@ instance OutputableP env instr => OutputableP env (GenBasicBlock instr) where
pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
pprBBlock (BasicBlock ident stmts) =
hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
+
+-- --------------------------------------------------------------------------
+-- Pretty-printing Cmm
+-- --------------------------------------------------------------------------
+--
+-- This is where we walk over Cmm emitting an external representation,
+-- suitable for parsing, in a syntax strongly reminiscent of C--. This
+-- is the "External Core" for the Cmm layer.
+--
+-- As such, this should be a well-defined syntax: we want it to look nice.
+-- Thus, we try wherever possible to use syntax defined in [1],
+-- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
+-- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
+-- than C--'s bits8 .. bits64.
+--
+-- We try to ensure that all information available in the abstract
+-- syntax is reproduced, or reproducible, in the concrete syntax.
+-- Data that is not in printed out can be reconstructed according to
+-- conventions used in the pretty printer. There are at least two such
+-- cases:
+-- 1) if a value has wordRep type, the type is not appended in the
+-- output.
+-- 2) MachOps that operate over wordRep type are printed in a
+-- C-style, rather than as their internal MachRep name.
+--
+-- These conventions produce much more readable Cmm output.
+
+pprCmms :: (OutputableP Platform info, OutputableP Platform g)
+ => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc
+pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))
+ where
+ separator = space $$ text "-------------------" $$ space
+
+pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)
+ => Platform -> GenCmmGroup d info g -> SDoc
+pprCmmGroup platform tops
+ = vcat $ intersperse blankLine $ map (pprTop platform) tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks.
+--
+
+pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)
+ => Platform -> GenCmmDecl d info i -> SDoc
+
+pprTop platform (CmmProc info lbl live graph)
+
+ = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live
+ , nest 8 $ lbrace <+> pdoc platform info $$ rbrace
+ , nest 4 $ pdoc platform graph
+ , rbrace ]
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+-- section "data" { ... }
+--
+
+pprTop platform (CmmData section ds) =
+ (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))
+ $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- Pretty-printing info tables
+-- --------------------------------------------------------------------------
+
+pprInfoTable :: Platform -> CmmInfoTable -> SDoc
+pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
+ , cit_prof = prof_info
+ , cit_srt = srt })
+ = vcat [ text "label: " <> pdoc platform lbl
+ , text "rep: " <> ppr rep
+ , case prof_info of
+ NoProfilingInfo -> empty
+ ProfilingInfo ct cd ->
+ vcat [ text "type: " <> text (show (BS.unpack ct))
+ , text "desc: " <> text (show (BS.unpack cd)) ]
+ , text "srt: " <> pdoc platform srt ]
+
+-- --------------------------------------------------------------------------
+-- Static data.
+-- Strings are printed as C strings, and we print them as I8[],
+-- following C--
+--
+
+pprStatics :: Platform -> GenCmmStatics a -> SDoc
+pprStatics platform (CmmStatics lbl itbl ccs payload) =
+ pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload
+pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds)
+
+pprStatic :: Platform -> CmmStatic -> SDoc
+pprStatic platform s = case s of
+ CmmStaticLit lit -> nest 4 $ text "const" <+> pdoc platform lit <> semi
+ CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+ CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
+ CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path)
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Platform -> Section -> SDoc
+pprSection platform (Section t suffix) =
+ section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)
+ where
+ section = text "section"
+
+pprSectionType :: SectionType -> SDoc
+pprSectionType s = doubleQuotes $ case s of
+ Text -> text "text"
+ Data -> text "data"
+ ReadOnlyData -> text "readonly"
+ ReadOnlyData16 -> text "readonly16"
+ RelocatableReadOnlyData -> text "relreadonly"
+ UninitialisedData -> text "uninitialised"
+ InitArray -> text "initarray"
+ FiniArray -> text "finiarray"
+ CString -> text "cstring"
+ OtherSection s' -> text s'
diff --git a/compiler/GHC/Cmm/CLabel.hs b/compiler/GHC/Cmm/CLabel.hs
index 6d0870e281..adb5150f1a 100644
--- a/compiler/GHC/Cmm/CLabel.hs
+++ b/compiler/GHC/Cmm/CLabel.hs
@@ -827,6 +827,9 @@ data InfoProvEnt = InfoProvEnt
-- Position and information about the info table
deriving (Eq, Ord)
+instance OutputableP Platform InfoProvEnt where
+ pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel
+
-- Constructing Cost Center Labels
mkCCLabel :: CostCentre -> CLabel
mkCCSLabel :: CostCentreStack -> CLabel
diff --git a/compiler/GHC/Cmm/CallConv.hs b/compiler/GHC/Cmm/CallConv.hs
index ecee8d902d..a0fee0e5c6 100644
--- a/compiler/GHC/Cmm/CallConv.hs
+++ b/compiler/GHC/Cmm/CallConv.hs
@@ -12,7 +12,6 @@ import Data.List (nub)
import GHC.Cmm.Expr
import GHC.Runtime.Heap.Layout
import GHC.Cmm (Convention(..))
-import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Platform
import GHC.Platform.Profile
diff --git a/compiler/GHC/Cmm/Dataflow/Graph.hs b/compiler/GHC/Cmm/Dataflow/Graph.hs
index 953ccdabaa..0beaee7357 100644
--- a/compiler/GHC/Cmm/Dataflow/Graph.hs
+++ b/compiler/GHC/Cmm/Dataflow/Graph.hs
@@ -12,6 +12,7 @@ module GHC.Cmm.Dataflow.Graph
, NonLocal(..)
, addBlock
, bodyList
+ , bodyToBlockList
, emptyBody
, labelsDefined
, mapGraph
@@ -56,6 +57,9 @@ emptyBody = mapEmpty
bodyList :: Body' block n -> [(Label,block n C C)]
bodyList body = mapToList body
+bodyToBlockList :: Body n -> [Block n C C]
+bodyToBlockList body = mapElems body
+
addBlock
:: (NonLocal block, HasDebugCallStack)
=> block C C -> LabelMap (block C C) -> LabelMap (block C C)
diff --git a/compiler/GHC/Cmm/DebugBlock.hs b/compiler/GHC/Cmm/DebugBlock.hs
index 06c1f9aace..b4528ae301 100644
--- a/compiler/GHC/Cmm/DebugBlock.hs
+++ b/compiler/GHC/Cmm/DebugBlock.hs
@@ -43,7 +43,6 @@ import GHC.Data.FastString ( nilFS, mkFastString )
import GHC.Unit.Module
import GHC.Utils.Outputable
import GHC.Utils.Panic
-import GHC.Cmm.Ppr.Expr ( pprExpr )
import GHC.Types.SrcLoc
import GHC.Types.Tickish
import GHC.Utils.Misc ( seqList )
@@ -559,6 +558,6 @@ toUnwindExpr platform e@(CmmMachOp op [e1, e2]) =
(MO_Sub{}, u1, u2 ) -> UwMinus u1 u2
(MO_Mul{}, u1, u2 ) -> UwTimes u1 u2
_otherwise -> pprPanic "Unsupported operator in unwind expression!"
- (pprExpr platform e)
+ (pdoc platform e)
toUnwindExpr platform e
= pprPanic "Unsupported unwind expression!" (pdoc platform e)
diff --git a/compiler/GHC/Cmm/Expr.hs b/compiler/GHC/Cmm/Expr.hs
index f910e65f04..ccc94a8b92 100644
--- a/compiler/GHC/Cmm/Expr.hs
+++ b/compiler/GHC/Cmm/Expr.hs
@@ -10,6 +10,7 @@ module GHC.Cmm.Expr
, CmmReg(..), cmmRegType, cmmRegWidth
, CmmLit(..), cmmLitType
, AlignmentSpec(..)
+ -- TODO: Remove:
, LocalReg(..), localRegType
, GlobalReg(..), isArgReg, globalRegType
, spReg, hpReg, spLimReg, hpLimReg, nodeReg
@@ -26,6 +27,11 @@ module GHC.Cmm.Expr
, plusRegSet, minusRegSet, timesRegSet, sizeRegSet, nullRegSet
, regSetToList
+ , isTrivialCmmExpr
+ , hasNoGlobalRegs
+ , isLit
+ , isComparisonExpr
+
, Area(..)
, module GHC.Cmm.MachOp
, module GHC.Cmm.Type
@@ -39,12 +45,16 @@ import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm.MachOp
import GHC.Cmm.Type
+import GHC.Cmm.Reg
+import GHC.Utils.Trace (pprTrace)
import GHC.Utils.Panic (panic)
import GHC.Utils.Outputable
import GHC.Types.Unique
+import Data.Maybe
import Data.Set (Set)
import qualified Data.Set as Set
+import Numeric ( fromRat )
import GHC.Types.Basic (Alignment, mkAlignment, alignmentOf)
@@ -78,14 +88,12 @@ instance Eq CmmExpr where -- Equality ignores the types
CmmStackSlot a1 i1 == CmmStackSlot a2 i2 = a1==a2 && i1==i2
_e1 == _e2 = False
+instance OutputableP Platform CmmExpr where
+ pdoc = pprExpr
+
data AlignmentSpec = NaturallyAligned | Unaligned
deriving (Eq, Ord, Show)
-data CmmReg
- = CmmLocal {-# UNPACK #-} !LocalReg
- | CmmGlobal GlobalReg
- deriving( Eq, Ord, 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
@@ -94,6 +102,14 @@ data Area
-- See Note [Continuation BlockIds] in GHC.Cmm.Node.
deriving (Eq, Ord, Show)
+instance Outputable Area where
+ ppr e = pprArea e
+
+pprArea :: Area -> SDoc
+pprArea Old = text "old"
+pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
+
+
{- Note [Old Area]
~~~~~~~~~~~~~~~~~~
There is a single call area 'Old', allocated at the extreme old
@@ -217,6 +233,9 @@ data CmmLit
-- of bytes used
deriving (Eq, Show)
+instance OutputableP Platform CmmLit where
+ pdoc = pprLit
+
instance Outputable CmmLit where
ppr (CmmInt n w) = text "CmmInt" <+> ppr n <+> ppr w
ppr (CmmFloat n w) = text "CmmFloat" <+> text (show n) <+> ppr w
@@ -276,38 +295,34 @@ maybeInvertCmmExpr (CmmMachOp op args) = do op' <- maybeInvertComparison op
return (CmmMachOp op' args)
maybeInvertCmmExpr _ = Nothing
------------------------------------------------------------------------------
--- Local registers
------------------------------------------------------------------------------
-
-data LocalReg
- = LocalReg {-# UNPACK #-} !Unique !CmmType
- -- ^ Parameters:
- -- 1. Identifier
- -- 2. Type
- deriving Show
-
-instance Eq LocalReg where
- (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+---------------------------------------------------
+-- CmmExpr predicates
+---------------------------------------------------
--- This is non-deterministic but we do not currently support deterministic
--- code-generation. See Note [Unique Determinism and code generation]
--- See Note [No Ord for Unique]
-instance Ord LocalReg where
- compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2
+isTrivialCmmExpr :: CmmExpr -> Bool
+isTrivialCmmExpr (CmmLoad _ _ _) = False
+isTrivialCmmExpr (CmmMachOp _ _) = False
+isTrivialCmmExpr (CmmLit _) = True
+isTrivialCmmExpr (CmmReg _) = True
+isTrivialCmmExpr (CmmRegOff _ _) = True
+isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
-instance Uniquable LocalReg where
- getUnique (LocalReg uniq _) = uniq
+hasNoGlobalRegs :: CmmExpr -> Bool
+hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e
+hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es
+hasNoGlobalRegs (CmmLit _) = True
+hasNoGlobalRegs (CmmReg (CmmLocal _)) = True
+hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
+hasNoGlobalRegs _ = False
-cmmRegType :: Platform -> CmmReg -> CmmType
-cmmRegType _ (CmmLocal reg) = localRegType reg
-cmmRegType platform (CmmGlobal reg) = globalRegType platform reg
+isLit :: CmmExpr -> Bool
+isLit (CmmLit _) = True
+isLit _ = False
-cmmRegWidth :: Platform -> CmmReg -> Width
-cmmRegWidth platform = typeWidth . cmmRegType platform
+isComparisonExpr :: CmmExpr -> Bool
+isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
+isComparisonExpr _ = False
-localRegType :: LocalReg -> CmmType
-localRegType (LocalReg _ rep) = rep
-----------------------------------------------------------------------------
-- Register-use information for expressions and other types
@@ -404,241 +419,159 @@ instance DefinerOfRegs r a => DefinerOfRegs r [a] where
foldRegsDefd platform f set as = foldl' (foldRegsDefd platform f) set as
{-# INLINABLE foldRegsDefd #-}
------------------------------------------------------------------------------
--- Global STG registers
------------------------------------------------------------------------------
-
-data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
-
------------------------------------------------------------------------------
--- Global STG registers
------------------------------------------------------------------------------
-{-
-Note [Overlapping global registers]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-The backend might not faithfully implement the abstraction of the STG
-machine with independent registers for different values of type
-GlobalReg. Specifically, certain pairs of registers (r1, r2) may
-overlap in the sense that a store to r1 invalidates the value in r2,
-and vice versa.
-
-Currently this occurs only on the x86_64 architecture where FloatReg n
-and DoubleReg n are assigned the same microarchitectural register, in
-order to allow functions to receive more Float# or Double# arguments
-in registers (as opposed to on the stack).
-
-There are no specific rules about which registers might overlap with
-which other registers, but presumably it's safe to assume that nothing
-will overlap with special registers like Sp or BaseReg.
-
-Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap
-on a particular platform. The instance Eq GlobalReg is syntactic
-equality of STG registers and does not take overlap into
-account. However it is still used in UserOfRegs/DefinerOfRegs and
-there are likely still bugs there, beware!
--}
-
-data GlobalReg
- -- Argument and return registers
- = VanillaReg -- pointers, unboxed ints and chars
- {-# UNPACK #-} !Int -- its number
- VGcPtr
-
- | FloatReg -- single-precision floating-point registers
- {-# UNPACK #-} !Int -- its number
-
- | DoubleReg -- double-precision floating-point registers
- {-# UNPACK #-} !Int -- its number
-
- | LongReg -- long int registers (64-bit, really)
- {-# UNPACK #-} !Int -- its number
-
- | XmmReg -- 128-bit SIMD vector register
- {-# UNPACK #-} !Int -- its number
-
- | YmmReg -- 256-bit SIMD vector register
- {-# UNPACK #-} !Int -- its number
-
- | ZmmReg -- 512-bit SIMD vector register
- {-# UNPACK #-} !Int -- its number
-
- -- STG registers
- | Sp -- Stack ptr; points to last occupied stack location.
- | SpLim -- Stack limit
- | Hp -- Heap ptr; points to last occupied heap location.
- | HpLim -- Heap limit register
- | CCCS -- Current cost-centre stack
- | CurrentTSO -- pointer to current thread's TSO
- | CurrentNursery -- pointer to allocation area
- | HpAlloc -- allocation count for heap check failure
-
- -- We keep the address of some commonly-called
- -- functions in the register table, to keep code
- -- size down:
- | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
- | GCEnter1 -- stg_gc_enter_1
- | GCFun -- stg_gc_fun
-
- -- Base offset for the register table, used for accessing registers
- -- which do not have real registers assigned to them. This register
- -- will only appear after we have expanded GlobalReg into memory accesses
- -- (where necessary) in the native code generator.
- | BaseReg
-
- -- The register used by the platform for the C stack pointer. This is
- -- a break in the STG abstraction used exclusively to setup stack unwinding
- -- information.
- | MachSp
-
- -- The is a dummy register used to indicate to the stack unwinder where
- -- a routine would return to.
- | UnwindReturnReg
-
- -- Base Register for PIC (position-independent code) calculations
- -- Only used inside the native code generator. It's exact meaning differs
- -- from platform to platform (see module PositionIndependentCode).
- | PicBaseReg
-
- deriving( Show )
-
-instance Eq GlobalReg where
- VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
- FloatReg i == FloatReg j = i==j
- DoubleReg i == DoubleReg j = i==j
- LongReg i == LongReg j = i==j
- -- NOTE: XMM, YMM, ZMM registers actually are the same registers
- -- at least with respect to store at YMM i and then read from XMM i
- -- and similarly for ZMM etc.
- XmmReg i == XmmReg j = i==j
- YmmReg i == YmmReg j = i==j
- ZmmReg i == ZmmReg j = i==j
- Sp == Sp = True
- SpLim == SpLim = True
- Hp == Hp = True
- HpLim == HpLim = True
- CCCS == CCCS = True
- CurrentTSO == CurrentTSO = True
- CurrentNursery == CurrentNursery = True
- HpAlloc == HpAlloc = True
- EagerBlackholeInfo == EagerBlackholeInfo = True
- GCEnter1 == GCEnter1 = True
- GCFun == GCFun = True
- BaseReg == BaseReg = True
- MachSp == MachSp = True
- UnwindReturnReg == UnwindReturnReg = True
- PicBaseReg == PicBaseReg = True
- _r1 == _r2 = False
-
--- NOTE: this Ord instance affects the tuple layout in GHCi, see
--- Note [GHCi tuple layout]
-instance Ord GlobalReg where
- compare (VanillaReg i _) (VanillaReg j _) = compare i j
- -- Ignore type when seeking clashes
- compare (FloatReg i) (FloatReg j) = compare i j
- compare (DoubleReg i) (DoubleReg j) = compare i j
- compare (LongReg i) (LongReg j) = compare i j
- compare (XmmReg i) (XmmReg j) = compare i j
- compare (YmmReg i) (YmmReg j) = compare i j
- compare (ZmmReg i) (ZmmReg j) = compare i j
- compare Sp Sp = EQ
- compare SpLim SpLim = EQ
- compare Hp Hp = EQ
- compare HpLim HpLim = EQ
- compare CCCS CCCS = EQ
- compare CurrentTSO CurrentTSO = EQ
- compare CurrentNursery CurrentNursery = EQ
- compare HpAlloc HpAlloc = EQ
- compare EagerBlackholeInfo EagerBlackholeInfo = EQ
- compare GCEnter1 GCEnter1 = EQ
- compare GCFun GCFun = EQ
- compare BaseReg BaseReg = EQ
- compare MachSp MachSp = EQ
- compare UnwindReturnReg UnwindReturnReg = EQ
- compare PicBaseReg PicBaseReg = EQ
- compare (VanillaReg _ _) _ = LT
- compare _ (VanillaReg _ _) = GT
- compare (FloatReg _) _ = LT
- compare _ (FloatReg _) = GT
- compare (DoubleReg _) _ = LT
- compare _ (DoubleReg _) = GT
- compare (LongReg _) _ = LT
- compare _ (LongReg _) = GT
- compare (XmmReg _) _ = LT
- compare _ (XmmReg _) = GT
- compare (YmmReg _) _ = LT
- compare _ (YmmReg _) = GT
- compare (ZmmReg _) _ = LT
- compare _ (ZmmReg _) = GT
- compare Sp _ = LT
- compare _ Sp = GT
- compare SpLim _ = LT
- compare _ SpLim = GT
- compare Hp _ = LT
- compare _ Hp = GT
- compare HpLim _ = LT
- compare _ HpLim = GT
- compare CCCS _ = LT
- compare _ CCCS = GT
- compare CurrentTSO _ = LT
- compare _ CurrentTSO = GT
- compare CurrentNursery _ = LT
- compare _ CurrentNursery = GT
- compare HpAlloc _ = LT
- compare _ HpAlloc = GT
- compare GCEnter1 _ = LT
- compare _ GCEnter1 = GT
- compare GCFun _ = LT
- compare _ GCFun = GT
- compare BaseReg _ = LT
- compare _ BaseReg = GT
- compare MachSp _ = LT
- compare _ MachSp = GT
- compare UnwindReturnReg _ = LT
- compare _ UnwindReturnReg = GT
- compare EagerBlackholeInfo _ = LT
- compare _ EagerBlackholeInfo = GT
-
--- convenient aliases
-baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
- currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg
-baseReg = CmmGlobal BaseReg
-spReg = CmmGlobal Sp
-hpReg = CmmGlobal Hp
-hpLimReg = CmmGlobal HpLim
-spLimReg = CmmGlobal SpLim
-nodeReg = CmmGlobal node
-currentTSOReg = CmmGlobal CurrentTSO
-currentNurseryReg = CmmGlobal CurrentNursery
-hpAllocReg = CmmGlobal HpAlloc
-cccsReg = CmmGlobal CCCS
-
-node :: GlobalReg
-node = VanillaReg 1 VGcPtr
-
-globalRegType :: Platform -> GlobalReg -> CmmType
-globalRegType platform = \case
- (VanillaReg _ VGcPtr) -> gcWord platform
- (VanillaReg _ VNonGcPtr) -> bWord platform
- (FloatReg _) -> cmmFloat W32
- (DoubleReg _) -> cmmFloat W64
- (LongReg _) -> cmmBits W64
- -- TODO: improve the internal model of SIMD/vectorized registers
- -- the right design SHOULd improve handling of float and double code too.
- -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
- (XmmReg _) -> cmmVec 4 (cmmBits W32)
- (YmmReg _) -> cmmVec 8 (cmmBits W32)
- (ZmmReg _) -> cmmVec 16 (cmmBits W32)
-
- Hp -> gcWord platform -- The initialiser for all
- -- dynamically allocated closures
- _ -> bWord platform
-
-isArgReg :: GlobalReg -> Bool
-isArgReg (VanillaReg {}) = True
-isArgReg (FloatReg {}) = True
-isArgReg (DoubleReg {}) = True
-isArgReg (LongReg {}) = True
-isArgReg (XmmReg {}) = True
-isArgReg (YmmReg {}) = True
-isArgReg (ZmmReg {}) = True
-isArgReg _ = False
+-- --------------------------------------------------------------------------
+-- Pretty-printing expressions
+-- --------------------------------------------------------------------------
+
+pprExpr :: Platform -> CmmExpr -> SDoc
+pprExpr platform e
+ = case e of
+ CmmRegOff reg i ->
+ pprExpr platform (CmmMachOp (MO_Add rep)
+ [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
+ where rep = typeWidth (cmmRegType platform reg)
+ CmmLit lit -> pprLit platform lit
+ _other -> pprExpr1 platform 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 (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp1 op
+ = pprExpr7 platform x <+> doc <+> pprExpr7 platform y
+pprExpr1 platform e = pprExpr7 platform e
+
+infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
+
+infixMachOp1 (MO_Eq _) = Just (text "==")
+infixMachOp1 (MO_Ne _) = Just (text "!=")
+infixMachOp1 (MO_Shl _) = Just (text "<<")
+infixMachOp1 (MO_U_Shr _) = Just (text ">>")
+infixMachOp1 (MO_U_Ge _) = Just (text ">=")
+infixMachOp1 (MO_U_Le _) = Just (text "<=")
+infixMachOp1 (MO_U_Gt _) = Just (char '>')
+infixMachOp1 (MO_U_Lt _) = Just (char '<')
+infixMachOp1 _ = Nothing
+
+-- %left '-' '+'
+pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
+ = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
+pprExpr7 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp7 op
+ = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
+pprExpr7 platform e = pprExpr8 platform e
+
+infixMachOp7 (MO_Add _) = Just (char '+')
+infixMachOp7 (MO_Sub _) = Just (char '-')
+infixMachOp7 _ = Nothing
+
+-- %left '/' '*' '%'
+pprExpr8 platform (CmmMachOp op [x,y])
+ | Just doc <- infixMachOp8 op
+ = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
+pprExpr8 platform e = pprExpr9 platform e
+
+infixMachOp8 (MO_U_Quot _) = Just (char '/')
+infixMachOp8 (MO_Mul _) = Just (char '*')
+infixMachOp8 (MO_U_Rem _) = Just (char '%')
+infixMachOp8 _ = Nothing
+
+pprExpr9 :: Platform -> CmmExpr -> SDoc
+pprExpr9 platform e =
+ case e of
+ CmmLit lit -> pprLit1 platform lit
+ CmmLoad expr rep align
+ -> let align_mark =
+ case align of
+ NaturallyAligned -> empty
+ Unaligned -> text "^"
+ in ppr rep <> align_mark <> brackets (pdoc platform expr)
+ CmmReg reg -> ppr reg
+ CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
+ CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
+ CmmMachOp mop args -> genMachOp platform mop args
+
+genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
+genMachOp platform mop args
+ | Just doc <- infixMachOp mop = case args of
+ -- dyadic
+ [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y
+
+ -- unary
+ [x] -> doc <> pprExpr9 platform x
+
+ _ -> pprTrace "GHC.Cmm.Expr.genMachOp: machop with strange number of args"
+ (pprMachOp mop <+>
+ parens (hcat $ punctuate comma (map (pprExpr platform) args)))
+ empty
+
+ | isJust (infixMachOp1 mop)
+ || isJust (infixMachOp7 mop)
+ || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args))
+
+ | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args))
+ where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
+ (show 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 mop
+ = case mop of
+ MO_And _ -> Just $ char '&'
+ MO_Or _ -> Just $ char '|'
+ MO_Xor _ -> Just $ char '^'
+ MO_Not _ -> Just $ char '~'
+ MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
+ _ -> 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 lit = case lit of
+ CmmInt i rep ->
+ hcat [ (if i < 0 then parens else id)(integer i)
+ , ppUnless (rep == wordWidth platform) $
+ space <> dcolon <+> ppr rep ]
+
+ CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
+ CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'
+ CmmLabel clbl -> pdoc platform clbl
+ CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i
+ CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'
+ <> pdoc platform clbl2 <> ppr_offset i
+ CmmBlock id -> ppr id
+ CmmHighStackMark -> text "<highSp>"
+
+pprLit1 :: Platform -> CmmLit -> SDoc
+pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)
+pprLit1 platform lit = pprLit platform lit
+
+ppr_offset :: Int -> SDoc
+ppr_offset i
+ | i==0 = empty
+ | i>=0 = char '+' <> int i
+ | otherwise = char '-' <> int (-i)
+
+commafy :: [SDoc] -> SDoc
+commafy xs = fsep $ punctuate comma xs
diff --git a/compiler/GHC/Cmm/Lint.hs b/compiler/GHC/Cmm/Lint.hs
index e76be551f9..f1d60c133b 100644
--- a/compiler/GHC/Cmm/Lint.hs
+++ b/compiler/GHC/Cmm/Lint.hs
@@ -24,7 +24,6 @@ import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Liveness
import GHC.Cmm.Switch (switchTargetsToList)
-import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Utils.Outputable
import Control.Monad (ap, unless)
diff --git a/compiler/GHC/Cmm/Liveness.hs b/compiler/GHC/Cmm/Liveness.hs
index a1526be099..769c701c2b 100644
--- a/compiler/GHC/Cmm/Liveness.hs
+++ b/compiler/GHC/Cmm/Liveness.hs
@@ -20,7 +20,6 @@ import GHC.Prelude
import GHC.Platform
import GHC.Cmm.BlockId
import GHC.Cmm
-import GHC.Cmm.Ppr.Expr () -- For Outputable instances
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow
diff --git a/compiler/GHC/Cmm/Node.hs b/compiler/GHC/Cmm/Node.hs
index 841c726b14..117ed9747a 100644
--- a/compiler/GHC/Cmm/Node.hs
+++ b/compiler/GHC/Cmm/Node.hs
@@ -7,6 +7,7 @@
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}
+{-# LANGUAGE LambdaCase #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}
{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
@@ -28,6 +29,7 @@ module GHC.Cmm.Node (
import GHC.Prelude hiding (succ)
import GHC.Platform.Regs
+import GHC.Cmm.CLabel
import GHC.Cmm.Expr
import GHC.Cmm.Switch
import GHC.Data.FastString
@@ -36,7 +38,9 @@ import GHC.Utils.Outputable
import GHC.Runtime.Heap.Layout
import GHC.Types.Tickish (CmmTickish)
import qualified GHC.Types.Unique as U
+import GHC.Types.Basic (FunctionOrData(..))
+import GHC.Platform
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Graph
import GHC.Cmm.Dataflow.Collections
@@ -44,6 +48,7 @@ import GHC.Cmm.Dataflow.Label
import Data.Maybe
import Data.List (tails,sortBy)
import GHC.Types.Unique (nonDetCmpUnique)
+import GHC.Utils.Constants (debugIsOn)
import GHC.Utils.Misc
@@ -165,6 +170,177 @@ data CmmNode e x where
intrbl:: Bool -- whether or not the call is interruptible
} -> CmmNode O C
+instance OutputableP Platform (CmmNode e x) where
+ pdoc = pprNode
+
+pprNode :: Platform -> CmmNode e x -> SDoc
+pprNode platform node = pp_node <+> pp_debug
+ where
+ pp_node :: SDoc
+ pp_node = case node of
+ -- label:
+ CmmEntry id tscope ->
+ (sdocOption sdocSuppressUniques $ \case
+ True -> text "_lbl_"
+ False -> ppr id
+ )
+ <> colon
+ <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)
+
+ -- // text
+ CmmComment s -> text "//" <+> ftext s
+
+ -- //tick bla<...>
+ CmmTick t -> ppUnlessOption sdocSuppressTicks
+ (text "//tick" <+> ppr t)
+
+ -- unwind reg = expr;
+ CmmUnwind regs ->
+ text "unwind "
+ <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi
+
+ -- reg = expr;
+ CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi
+
+ -- rep[lv] = expr;
+ CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi
+ where
+ align_mark = case align of
+ Unaligned -> text "^"
+ NaturallyAligned -> empty
+ rep = ppr ( cmmExprType platform expr )
+
+ -- call "ccall" foo(x, y)[r1, r2];
+ -- ToDo ppr volatile
+ CmmUnsafeForeignCall target results args ->
+ hsep [ ppUnless (null results) $
+ parens (commafy $ map ppr results) <+> equals,
+ text "call",
+ pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi]
+
+ -- goto label;
+ CmmBranch ident -> text "goto" <+> ppr ident <> semi
+
+ -- if (expr) goto t; else goto f;
+ CmmCondBranch expr t f l ->
+ hsep [ text "if"
+ , parens (pdoc platform expr)
+ , case l of
+ Nothing -> empty
+ Just b -> parens (text "likely:" <+> ppr b)
+ , text "goto"
+ , ppr t <> semi
+ , text "else goto"
+ , ppr f <> semi
+ ]
+
+ CmmSwitch expr ids ->
+ hang (hsep [ text "switch"
+ , range
+ , if isTrivialCmmExpr expr
+ then pdoc platform expr
+ else parens (pdoc platform expr)
+ , text "{"
+ ])
+ 4 (vcat (map ppCase cases) $$ def) $$ rbrace
+ where
+ (cases, mbdef) = switchTargetsFallThrough ids
+ ppCase (is,l) = hsep
+ [ text "case"
+ , commafy $ map integer is
+ , text ": goto"
+ , ppr l <> semi
+ ]
+ def | Just l <- mbdef = hsep
+ [ text "default:"
+ , braces (text "goto" <+> ppr l <> semi)
+ ]
+ | otherwise = empty
+
+ range = brackets $ hsep [integer lo, text "..", integer hi]
+ where (lo,hi) = switchTargetsRange ids
+
+ CmmCall tgt k regs out res updfr_off ->
+ hcat [ text "call", space
+ , pprFun tgt, parens (interpp'SP regs), space
+ , returns <+>
+ text "args: " <> ppr out <> comma <+>
+ text "res: " <> ppr res <> comma <+>
+ text "upd: " <> ppr updfr_off
+ , semi ]
+ where pprFun f@(CmmLit _) = pdoc platform f
+ pprFun f = parens (pdoc platform f)
+
+ returns
+ | Just r <- k = text "returns to" <+> ppr r <> comma
+ | otherwise = empty
+
+ CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
+ hcat $ if i then [text "interruptible", space] else [] ++
+ [ text "foreign call", space
+ , pdoc platform t, text "(...)", space
+ , text "returns to" <+> ppr s
+ <+> text "args:" <+> parens (pdoc platform as)
+ <+> text "ress:" <+> parens (ppr rs)
+ , text "ret_args:" <+> ppr a
+ , text "ret_off:" <+> ppr u
+ , semi ]
+
+ pp_debug :: SDoc
+ pp_debug =
+ if not debugIsOn then empty
+ else case node of
+ CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
+ CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
+ CmmTick {} -> empty
+ CmmUnwind {} -> text " // CmmUnwind"
+ CmmAssign {} -> text " // CmmAssign"
+ CmmStore {} -> text " // CmmStore"
+ CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
+ CmmBranch {} -> text " // CmmBranch"
+ CmmCondBranch {} -> text " // CmmCondBranch"
+ CmmSwitch {} -> text " // CmmSwitch"
+ CmmCall {} -> text " // CmmCall"
+ CmmForeignCall {} -> text " // CmmForeignCall"
+
+ commafy :: [SDoc] -> SDoc
+ commafy xs = hsep $ punctuate comma xs
+
+instance OutputableP Platform (Block CmmNode C C) where
+ pdoc = pprBlock
+instance OutputableP Platform (Block CmmNode C O) where
+ pdoc = pprBlock
+instance OutputableP Platform (Block CmmNode O C) where
+ pdoc = pprBlock
+instance OutputableP Platform (Block CmmNode O O) where
+ pdoc = pprBlock
+
+instance OutputableP Platform (Graph CmmNode e x) where
+ pdoc = pprGraph
+
+pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
+ => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock platform block
+ = foldBlockNodesB3 ( ($$) . pdoc platform
+ , ($$) . (nest 4) . pdoc platform
+ , ($$) . (nest 4) . pdoc platform
+ )
+ block
+ empty
+
+pprGraph :: Platform -> Graph CmmNode e x -> SDoc
+pprGraph platform = \case
+ GNil -> empty
+ GUnit block -> pdoc platform block
+ GMany entry body exit ->
+ text "{"
+ $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit)
+ $$ text "}"
+ where pprMaybeO :: OutputableP Platform (Block CmmNode e x)
+ => MaybeO ex (Block CmmNode e x) -> SDoc
+ pprMaybeO NothingO = empty
+ pprMaybeO (JustO block) = pdoc platform block
+
{- Note [Foreign calls]
~~~~~~~~~~~~~~~~~~~~~~~
A CmmUnsafeForeignCall is used for *unsafe* foreign calls;
@@ -291,11 +467,25 @@ data ForeignConvention
CmmReturnInfo
deriving Eq
+instance Outputable ForeignConvention where
+ ppr = pprForeignConvention
+
+pprForeignConvention :: ForeignConvention -> SDoc
+pprForeignConvention (ForeignConvention c args res ret) =
+ doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
+
data CmmReturnInfo
= CmmMayReturn
| CmmNeverReturns
deriving ( Eq )
+instance Outputable CmmReturnInfo where
+ ppr = pprReturnInfo
+
+pprReturnInfo :: CmmReturnInfo -> SDoc
+pprReturnInfo CmmMayReturn = empty
+pprReturnInfo CmmNeverReturns = text "never returns"
+
data ForeignTarget -- The target of a foreign call
= ForeignTarget -- A foreign procedure
CmmExpr -- Its address
@@ -304,6 +494,35 @@ data ForeignTarget -- The target of a foreign call
CallishMachOp -- Which one
deriving Eq
+instance OutputableP Platform ForeignTarget where
+ pdoc = pprForeignTarget
+
+pprForeignTarget :: Platform -> ForeignTarget -> SDoc
+pprForeignTarget platform (ForeignTarget fn c) =
+ ppr c <+> ppr_target fn
+ where
+ ppr_target :: CmmExpr -> SDoc
+ ppr_target t@(CmmLit _) = pdoc platform t
+ ppr_target fn' = parens (pdoc platform fn')
+pprForeignTarget platform (PrimTarget op)
+ -- HACK: We're just using a ForeignLabel to get this printed, the label
+ -- might not really be foreign.
+ = pdoc platform
+ (CmmLabel (mkForeignLabel
+ (mkFastString (show op))
+ Nothing ForeignLabelInThisPackage IsFunction))
+
+instance Outputable Convention where
+ ppr = pprConvention
+
+pprConvention :: Convention -> SDoc
+pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
+pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
+pprConvention (NativeReturn {}) = text "<native-ret-convention>"
+pprConvention Slow = text "<slow-convention>"
+pprConvention GC = text "<gc-convention>"
+
+
foreignTargetHints :: ForeignTarget -> ([ForeignHint], [ForeignHint])
foreignTargetHints target
= ( res_hints ++ repeat NoHint
diff --git a/compiler/GHC/Cmm/Ppr.hs b/compiler/GHC/Cmm/Ppr.hs
deleted file mode 100644
index c7a1579962..0000000000
--- a/compiler/GHC/Cmm/Ppr.hs
+++ /dev/null
@@ -1,319 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE TypeFamilies #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE LambdaCase #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-----------------------------------------------------------------------------
---
--- Pretty-printing of Cmm as (a superset of) C--
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
---
--- This is where we walk over CmmNode emitting an external representation,
--- suitable for parsing, in a syntax strongly reminiscent of C--. This
--- is the "External Core" for the Cmm layer.
---
--- As such, this should be a well-defined syntax: we want it to look nice.
--- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
--- than C--'s bits8 .. bits64.
---
--- We try to ensure that all information available in the abstract
--- syntax is reproduced, or reproducible, in the concrete syntax.
--- Data that is not in printed out can be reconstructed according to
--- conventions used in the pretty printer. There are at least two such
--- cases:
--- 1) if a value has wordRep type, the type is not appended in the
--- output.
--- 2) MachOps that operate over wordRep type are printed in a
--- C-style, rather than as their internal MachRep name.
---
--- These conventions produce much more readable Cmm output.
---
--- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
-
-module GHC.Cmm.Ppr
- ( module GHC.Cmm.Ppr.Decl
- , module GHC.Cmm.Ppr.Expr
- )
-where
-
-import GHC.Prelude hiding (succ)
-
-import GHC.Platform
-import GHC.Cmm.CLabel
-import GHC.Cmm
-import GHC.Cmm.Utils
-import GHC.Cmm.Switch
-import GHC.Data.FastString
-import GHC.Utils.Outputable
-import GHC.Cmm.Ppr.Decl
-import GHC.Cmm.Ppr.Expr
-import GHC.Utils.Constants (debugIsOn)
-
-import GHC.Types.Basic
-import GHC.Cmm.Dataflow.Block
-import GHC.Cmm.Dataflow.Graph
-
--------------------------------------------------
--- Outputable instances
-instance OutputableP Platform InfoProvEnt where
- pdoc platform (InfoProvEnt clabel _ _ _ _) = pdoc platform clabel
-
-instance Outputable CmmStackInfo where
- ppr = pprStackInfo
-
-instance OutputableP Platform CmmTopInfo where
- pdoc = pprTopInfo
-
-
-instance OutputableP Platform (CmmNode e x) where
- pdoc = pprNode
-
-instance Outputable Convention where
- ppr = pprConvention
-
-instance Outputable ForeignConvention where
- ppr = pprForeignConvention
-
-instance OutputableP Platform ForeignTarget where
- pdoc = pprForeignTarget
-
-instance Outputable CmmReturnInfo where
- ppr = pprReturnInfo
-
-instance OutputableP Platform (Block CmmNode C C) where
- pdoc = pprBlock
-instance OutputableP Platform (Block CmmNode C O) where
- pdoc = pprBlock
-instance OutputableP Platform (Block CmmNode O C) where
- pdoc = pprBlock
-instance OutputableP Platform (Block CmmNode O O) where
- pdoc = pprBlock
-
-instance OutputableP Platform (Graph CmmNode e x) where
- pdoc = pprGraph
-
-instance OutputableP Platform CmmGraph where
- pdoc = pprCmmGraph
-
-----------------------------------------------------------
--- Outputting types Cmm contains
-
-pprStackInfo :: CmmStackInfo -> SDoc
-pprStackInfo (StackInfo {arg_space=arg_space}) =
- text "arg_space: " <> ppr arg_space
-
-pprTopInfo :: Platform -> CmmTopInfo -> SDoc
-pprTopInfo platform (TopInfo {info_tbls=info_tbl, stack_info=stack_info}) =
- vcat [text "info_tbls: " <> pdoc platform info_tbl,
- text "stack_info: " <> ppr stack_info]
-
-----------------------------------------------------------
--- Outputting blocks and graphs
-
-pprBlock :: IndexedCO x SDoc SDoc ~ SDoc
- => Platform -> Block CmmNode e x -> IndexedCO e SDoc SDoc
-pprBlock platform block
- = foldBlockNodesB3 ( ($$) . pdoc platform
- , ($$) . (nest 4) . pdoc platform
- , ($$) . (nest 4) . pdoc platform
- )
- block
- empty
-
-pprGraph :: Platform -> Graph CmmNode e x -> SDoc
-pprGraph platform = \case
- GNil -> empty
- GUnit block -> pdoc platform block
- GMany entry body exit ->
- text "{"
- $$ nest 2 (pprMaybeO entry $$ (vcat $ map (pdoc platform) $ bodyToBlockList body) $$ pprMaybeO exit)
- $$ text "}"
- where pprMaybeO :: OutputableP Platform (Block CmmNode e x)
- => MaybeO ex (Block CmmNode e x) -> SDoc
- pprMaybeO NothingO = empty
- pprMaybeO (JustO block) = pdoc platform block
-
-pprCmmGraph :: Platform -> CmmGraph -> SDoc
-pprCmmGraph platform g
- = text "{" <> text "offset"
- $$ nest 2 (vcat $ map (pdoc platform) blocks)
- $$ text "}"
- where blocks = revPostorder g
- -- revPostorder has the side-effect of discarding unreachable code,
- -- so pretty-printed Cmm will omit any unreachable blocks. This can
- -- sometimes be confusing.
-
----------------------------------------------
--- Outputting CmmNode and types which it contains
-
-pprConvention :: Convention -> SDoc
-pprConvention (NativeNodeCall {}) = text "<native-node-call-convention>"
-pprConvention (NativeDirectCall {}) = text "<native-direct-call-convention>"
-pprConvention (NativeReturn {}) = text "<native-ret-convention>"
-pprConvention Slow = text "<slow-convention>"
-pprConvention GC = text "<gc-convention>"
-
-pprForeignConvention :: ForeignConvention -> SDoc
-pprForeignConvention (ForeignConvention c args res ret) =
- doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res <+> ppr ret
-
-pprReturnInfo :: CmmReturnInfo -> SDoc
-pprReturnInfo CmmMayReturn = empty
-pprReturnInfo CmmNeverReturns = text "never returns"
-
-pprForeignTarget :: Platform -> ForeignTarget -> SDoc
-pprForeignTarget platform (ForeignTarget fn c) = ppr c <+> ppr_target fn
- where
- ppr_target :: CmmExpr -> SDoc
- ppr_target t@(CmmLit _) = pdoc platform t
- ppr_target fn' = parens (pdoc platform fn')
-
-pprForeignTarget platform (PrimTarget op)
- -- HACK: We're just using a ForeignLabel to get this printed, the label
- -- might not really be foreign.
- = pdoc platform
- (CmmLabel (mkForeignLabel
- (mkFastString (show op))
- Nothing ForeignLabelInThisPackage IsFunction))
-
-pprNode :: Platform -> CmmNode e x -> SDoc
-pprNode platform node = pp_node <+> pp_debug
- where
- pp_node :: SDoc
- pp_node = case node of
- -- label:
- CmmEntry id tscope ->
- (sdocOption sdocSuppressUniques $ \case
- True -> text "_lbl_"
- False -> ppr id
- )
- <> colon
- <+> ppUnlessOption sdocSuppressTicks (text "//" <+> ppr tscope)
-
- -- // text
- CmmComment s -> text "//" <+> ftext s
-
- -- //tick bla<...>
- CmmTick t -> ppUnlessOption sdocSuppressTicks
- (text "//tick" <+> ppr t)
-
- -- unwind reg = expr;
- CmmUnwind regs ->
- text "unwind "
- <> commafy (map (\(r,e) -> ppr r <+> char '=' <+> pdoc platform e) regs) <> semi
-
- -- reg = expr;
- CmmAssign reg expr -> ppr reg <+> equals <+> pdoc platform expr <> semi
-
- -- rep[lv] = expr;
- CmmStore lv expr align -> rep <> align_mark <> brackets (pdoc platform lv) <+> equals <+> pdoc platform expr <> semi
- where
- align_mark = case align of
- Unaligned -> text "^"
- NaturallyAligned -> empty
- rep = ppr ( cmmExprType platform expr )
-
- -- call "ccall" foo(x, y)[r1, r2];
- -- ToDo ppr volatile
- CmmUnsafeForeignCall target results args ->
- hsep [ ppUnless (null results) $
- parens (commafy $ map ppr results) <+> equals,
- text "call",
- pdoc platform target <> parens (commafy $ map (pdoc platform) args) <> semi]
-
- -- goto label;
- CmmBranch ident -> text "goto" <+> ppr ident <> semi
-
- -- if (expr) goto t; else goto f;
- CmmCondBranch expr t f l ->
- hsep [ text "if"
- , parens (pdoc platform expr)
- , case l of
- Nothing -> empty
- Just b -> parens (text "likely:" <+> ppr b)
- , text "goto"
- , ppr t <> semi
- , text "else goto"
- , ppr f <> semi
- ]
-
- CmmSwitch expr ids ->
- hang (hsep [ text "switch"
- , range
- , if isTrivialCmmExpr expr
- then pdoc platform expr
- else parens (pdoc platform expr)
- , text "{"
- ])
- 4 (vcat (map ppCase cases) $$ def) $$ rbrace
- where
- (cases, mbdef) = switchTargetsFallThrough ids
- ppCase (is,l) = hsep
- [ text "case"
- , commafy $ map integer is
- , text ": goto"
- , ppr l <> semi
- ]
- def | Just l <- mbdef = hsep
- [ text "default:"
- , braces (text "goto" <+> ppr l <> semi)
- ]
- | otherwise = empty
-
- range = brackets $ hsep [integer lo, text "..", integer hi]
- where (lo,hi) = switchTargetsRange ids
-
- CmmCall tgt k regs out res updfr_off ->
- hcat [ text "call", space
- , pprFun tgt, parens (interpp'SP regs), space
- , returns <+>
- text "args: " <> ppr out <> comma <+>
- text "res: " <> ppr res <> comma <+>
- text "upd: " <> ppr updfr_off
- , semi ]
- where pprFun f@(CmmLit _) = pdoc platform f
- pprFun f = parens (pdoc platform f)
-
- returns
- | Just r <- k = text "returns to" <+> ppr r <> comma
- | otherwise = empty
-
- CmmForeignCall {tgt=t, res=rs, args=as, succ=s, ret_args=a, ret_off=u, intrbl=i} ->
- hcat $ if i then [text "interruptible", space] else [] ++
- [ text "foreign call", space
- , pdoc platform t, text "(...)", space
- , text "returns to" <+> ppr s
- <+> text "args:" <+> parens (pdoc platform as)
- <+> text "ress:" <+> parens (ppr rs)
- , text "ret_args:" <+> ppr a
- , text "ret_off:" <+> ppr u
- , semi ]
-
- pp_debug :: SDoc
- pp_debug =
- if not debugIsOn then empty
- else case node of
- CmmEntry {} -> empty -- Looks terrible with text " // CmmEntry"
- CmmComment {} -> empty -- Looks also terrible with text " // CmmComment"
- CmmTick {} -> empty
- CmmUnwind {} -> text " // CmmUnwind"
- CmmAssign {} -> text " // CmmAssign"
- CmmStore {} -> text " // CmmStore"
- CmmUnsafeForeignCall {} -> text " // CmmUnsafeForeignCall"
- CmmBranch {} -> text " // CmmBranch"
- CmmCondBranch {} -> text " // CmmCondBranch"
- CmmSwitch {} -> text " // CmmSwitch"
- CmmCall {} -> text " // CmmCall"
- CmmForeignCall {} -> text " // CmmForeignCall"
-
- commafy :: [SDoc] -> SDoc
- commafy xs = hsep $ punctuate comma xs
diff --git a/compiler/GHC/Cmm/Ppr/Decl.hs b/compiler/GHC/Cmm/Ppr/Decl.hs
deleted file mode 100644
index 3b1eff78ff..0000000000
--- a/compiler/GHC/Cmm/Ppr/Decl.hs
+++ /dev/null
@@ -1,172 +0,0 @@
-{-# LANGUAGE GADTs #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-
-
-----------------------------------------------------------------------------
---
--- Pretty-printing of common Cmm types
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
---
--- This is where we walk over Cmm emitting an external representation,
--- suitable for parsing, in a syntax strongly reminiscent of C--. This
--- is the "External Core" for the Cmm layer.
---
--- As such, this should be a well-defined syntax: we want it to look nice.
--- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
--- than C--'s bits8 .. bits64.
---
--- We try to ensure that all information available in the abstract
--- syntax is reproduced, or reproducible, in the concrete syntax.
--- Data that is not in printed out can be reconstructed according to
--- conventions used in the pretty printer. There are at least two such
--- cases:
--- 1) if a value has wordRep type, the type is not appended in the
--- output.
--- 2) MachOps that operate over wordRep type are printed in a
--- C-style, rather than as their internal MachRep name.
---
--- These conventions produce much more readable Cmm output.
---
--- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
---
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module GHC.Cmm.Ppr.Decl
- ( pprCmms, pprCmmGroup, pprSection, pprStatic
- )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Cmm.Ppr.Expr
-import GHC.Cmm
-
-import GHC.Utils.Outputable
-
-import Data.List (intersperse)
-
-import qualified Data.ByteString as BS
-
-
-pprCmms :: (OutputableP Platform info, OutputableP Platform g)
- => Platform -> [GenCmmGroup RawCmmStatics info g] -> SDoc
-pprCmms platform cmms = pprCode CStyle (vcat (intersperse separator $ map (pdoc platform) cmms))
- where
- separator = space $$ text "-------------------" $$ space
-
------------------------------------------------------------------------------
-
-instance (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)
- => OutputableP Platform (GenCmmDecl d info i) where
- pdoc = pprTop
-
-instance OutputableP Platform (GenCmmStatics a) where
- pdoc = pprStatics
-
-instance OutputableP Platform CmmStatic where
- pdoc = pprStatic
-
-instance OutputableP Platform CmmInfoTable where
- pdoc = pprInfoTable
-
-
------------------------------------------------------------------------------
-
-pprCmmGroup :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform g)
- => Platform -> GenCmmGroup d info g -> SDoc
-pprCmmGroup platform tops
- = vcat $ intersperse blankLine $ map (pprTop platform) tops
-
--- --------------------------------------------------------------------------
--- Top level `procedure' blocks.
---
-pprTop :: (OutputableP Platform d, OutputableP Platform info, OutputableP Platform i)
- => Platform -> GenCmmDecl d info i -> SDoc
-
-pprTop platform (CmmProc info lbl live graph)
-
- = vcat [ pdoc platform lbl <> lparen <> rparen <+> lbrace <+> text "// " <+> ppr live
- , nest 8 $ lbrace <+> pdoc platform info $$ rbrace
- , nest 4 $ pdoc platform graph
- , rbrace ]
-
--- --------------------------------------------------------------------------
--- We follow [1], 4.5
---
--- section "data" { ... }
---
-pprTop platform (CmmData section ds) =
- (hang (pprSection platform section <+> lbrace) 4 (pdoc platform ds))
- $$ rbrace
-
--- --------------------------------------------------------------------------
--- Info tables.
-
-pprInfoTable :: Platform -> CmmInfoTable -> SDoc
-pprInfoTable platform (CmmInfoTable { cit_lbl = lbl, cit_rep = rep
- , cit_prof = prof_info
- , cit_srt = srt })
- = vcat [ text "label: " <> pdoc platform lbl
- , text "rep: " <> ppr rep
- , case prof_info of
- NoProfilingInfo -> empty
- ProfilingInfo ct cd ->
- vcat [ text "type: " <> text (show (BS.unpack ct))
- , text "desc: " <> text (show (BS.unpack cd)) ]
- , text "srt: " <> pdoc platform srt ]
-
-instance Outputable ForeignHint where
- ppr NoHint = empty
- ppr SignedHint = quotes(text "signed")
--- ppr AddrHint = quotes(text "address")
--- Temp Jan08
- ppr AddrHint = (text "PtrHint")
-
--- --------------------------------------------------------------------------
--- Static data.
--- Strings are printed as C strings, and we print them as I8[],
--- following C--
---
-
-pprStatics :: Platform -> GenCmmStatics a -> SDoc
-pprStatics platform (CmmStatics lbl itbl ccs payload) =
- pdoc platform lbl <> colon <+> pdoc platform itbl <+> ppr ccs <+> pdoc platform payload
-pprStatics platform (CmmStaticsRaw lbl ds) = vcat ((pdoc platform lbl <> colon) : map (pprStatic platform) ds)
-
-pprStatic :: Platform -> CmmStatic -> SDoc
-pprStatic platform s = case s of
- CmmStaticLit lit -> nest 4 $ text "const" <+> pprLit platform lit <> semi
- CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
- CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
- CmmFileEmbed path -> nest 4 $ text "incbin " <+> text (show path)
-
--- --------------------------------------------------------------------------
--- data sections
---
-pprSection :: Platform -> Section -> SDoc
-pprSection platform (Section t suffix) =
- section <+> doubleQuotes (pprSectionType t <+> char '.' <+> pdoc platform suffix)
- where
- section = text "section"
-
-pprSectionType :: SectionType -> SDoc
-pprSectionType s = doubleQuotes $ case s of
- Text -> text "text"
- Data -> text "data"
- ReadOnlyData -> text "readonly"
- ReadOnlyData16 -> text "readonly16"
- RelocatableReadOnlyData -> text "relreadonly"
- UninitialisedData -> text "uninitialised"
- InitArray -> text "initarray"
- FiniArray -> text "finiarray"
- CString -> text "cstring"
- OtherSection s' -> text s'
diff --git a/compiler/GHC/Cmm/Ppr/Expr.hs b/compiler/GHC/Cmm/Ppr/Expr.hs
deleted file mode 100644
index 3ef4b07af5..0000000000
--- a/compiler/GHC/Cmm/Ppr/Expr.hs
+++ /dev/null
@@ -1,299 +0,0 @@
-----------------------------------------------------------------------------
---
--- Pretty-printing of common Cmm types
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
---
--- This is where we walk over Cmm emitting an external representation,
--- suitable for parsing, in a syntax strongly reminiscent of C--. This
--- is the "External Core" for the Cmm layer.
---
--- As such, this should be a well-defined syntax: we want it to look nice.
--- Thus, we try wherever possible to use syntax defined in [1],
--- "The C-- Reference Manual", http://www.cs.tufts.edu/~nr/c--/index.html. We
--- differ slightly, in some cases. For one, we use I8 .. I64 for types, rather
--- than C--'s bits8 .. bits64.
---
--- We try to ensure that all information available in the abstract
--- syntax is reproduced, or reproducible, in the concrete syntax.
--- Data that is not in printed out can be reconstructed according to
--- conventions used in the pretty printer. There are at least two such
--- cases:
--- 1) if a value has wordRep type, the type is not appended in the
--- output.
--- 2) MachOps that operate over wordRep type are printed in a
--- C-style, rather than as their internal MachRep name.
---
--- These conventions produce much more readable Cmm output.
---
--- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
---
-{-# LANGUAGE LambdaCase #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE FlexibleInstances #-}
-
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-
-module GHC.Cmm.Ppr.Expr
- ( pprExpr, pprLit
- )
-where
-
-import GHC.Prelude
-
-import GHC.Platform
-import GHC.Cmm.Expr
-
-import GHC.Utils.Outputable
-import GHC.Utils.Trace
-
-import Data.Maybe
-import Numeric ( fromRat )
-
------------------------------------------------------------------------------
-
-instance OutputableP Platform CmmExpr where
- pdoc = pprExpr
-
-instance Outputable CmmReg where
- ppr e = pprReg e
-
-instance OutputableP Platform CmmLit where
- pdoc = pprLit
-
-instance Outputable LocalReg where
- ppr e = pprLocalReg e
-
-instance Outputable Area where
- ppr e = pprArea e
-
-instance Outputable GlobalReg where
- ppr e = pprGlobalReg e
-
-instance OutputableP env GlobalReg where
- pdoc _ = ppr
-
--- --------------------------------------------------------------------------
--- Expressions
---
-
-pprExpr :: Platform -> CmmExpr -> SDoc
-pprExpr platform e
- = case e of
- CmmRegOff reg i ->
- pprExpr platform (CmmMachOp (MO_Add rep)
- [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
- where rep = typeWidth (cmmRegType platform reg)
- CmmLit lit -> pprLit platform lit
- _other -> pprExpr1 platform 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 (CmmMachOp op [x,y])
- | Just doc <- infixMachOp1 op
- = pprExpr7 platform x <+> doc <+> pprExpr7 platform y
-pprExpr1 platform e = pprExpr7 platform e
-
-infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
-
-infixMachOp1 (MO_Eq _) = Just (text "==")
-infixMachOp1 (MO_Ne _) = Just (text "!=")
-infixMachOp1 (MO_Shl _) = Just (text "<<")
-infixMachOp1 (MO_U_Shr _) = Just (text ">>")
-infixMachOp1 (MO_U_Ge _) = Just (text ">=")
-infixMachOp1 (MO_U_Le _) = Just (text "<=")
-infixMachOp1 (MO_U_Gt _) = Just (char '>')
-infixMachOp1 (MO_U_Lt _) = Just (char '<')
-infixMachOp1 _ = Nothing
-
--- %left '-' '+'
-pprExpr7 platform (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
- = pprExpr7 platform (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
-pprExpr7 platform (CmmMachOp op [x,y])
- | Just doc <- infixMachOp7 op
- = pprExpr7 platform x <+> doc <+> pprExpr8 platform y
-pprExpr7 platform e = pprExpr8 platform e
-
-infixMachOp7 (MO_Add _) = Just (char '+')
-infixMachOp7 (MO_Sub _) = Just (char '-')
-infixMachOp7 _ = Nothing
-
--- %left '/' '*' '%'
-pprExpr8 platform (CmmMachOp op [x,y])
- | Just doc <- infixMachOp8 op
- = pprExpr8 platform x <+> doc <+> pprExpr9 platform y
-pprExpr8 platform e = pprExpr9 platform e
-
-infixMachOp8 (MO_U_Quot _) = Just (char '/')
-infixMachOp8 (MO_Mul _) = Just (char '*')
-infixMachOp8 (MO_U_Rem _) = Just (char '%')
-infixMachOp8 _ = Nothing
-
-pprExpr9 :: Platform -> CmmExpr -> SDoc
-pprExpr9 platform e =
- case e of
- CmmLit lit -> pprLit1 platform lit
- CmmLoad expr rep align
- -> let align_mark =
- case align of
- NaturallyAligned -> empty
- Unaligned -> text "^"
- in ppr rep <> align_mark <> brackets (pdoc platform expr)
- CmmReg reg -> ppr reg
- CmmRegOff reg off -> parens (ppr reg <+> char '+' <+> int off)
- CmmStackSlot a off -> parens (ppr a <+> char '+' <+> int off)
- CmmMachOp mop args -> genMachOp platform mop args
-
-genMachOp :: Platform -> MachOp -> [CmmExpr] -> SDoc
-genMachOp platform mop args
- | Just doc <- infixMachOp mop = case args of
- -- dyadic
- [x,y] -> pprExpr9 platform x <+> doc <+> pprExpr9 platform y
-
- -- unary
- [x] -> doc <> pprExpr9 platform x
-
- _ -> pprTrace "GHC.Cmm.Ppr.Expr.genMachOp: machop with strange number of args"
- (pprMachOp mop <+>
- parens (hcat $ punctuate comma (map (pprExpr platform) args)))
- empty
-
- | isJust (infixMachOp1 mop)
- || isJust (infixMachOp7 mop)
- || isJust (infixMachOp8 mop) = parens (pprExpr platform (CmmMachOp mop args))
-
- | otherwise = char '%' <> ppr_op <> parens (commafy (map (pprExpr platform) args))
- where ppr_op = text (map (\c -> if c == ' ' then '_' else c)
- (show 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 mop
- = case mop of
- MO_And _ -> Just $ char '&'
- MO_Or _ -> Just $ char '|'
- MO_Xor _ -> Just $ char '^'
- MO_Not _ -> Just $ char '~'
- MO_S_Neg _ -> Just $ char '-' -- there is no unsigned neg :)
- _ -> Nothing
-
--- --------------------------------------------------------------------------
--- 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 lit = case lit of
- CmmInt i rep ->
- hcat [ (if i < 0 then parens else id)(integer i)
- , ppUnless (rep == wordWidth platform) $
- space <> dcolon <+> ppr rep ]
-
- CmmFloat f rep -> hsep [ double (fromRat f), dcolon, ppr rep ]
- CmmVec lits -> char '<' <> commafy (map (pprLit platform) lits) <> char '>'
- CmmLabel clbl -> pdoc platform clbl
- CmmLabelOff clbl i -> pdoc platform clbl <> ppr_offset i
- CmmLabelDiffOff clbl1 clbl2 i _ -> pdoc platform clbl1 <> char '-'
- <> pdoc platform clbl2 <> ppr_offset i
- CmmBlock id -> ppr id
- CmmHighStackMark -> text "<highSp>"
-
-pprLit1 :: Platform -> CmmLit -> SDoc
-pprLit1 platform lit@(CmmLabelOff {}) = parens (pprLit platform lit)
-pprLit1 platform lit = pprLit platform lit
-
-ppr_offset :: Int -> SDoc
-ppr_offset i
- | i==0 = empty
- | i>=0 = char '+' <> int i
- | otherwise = char '-' <> int (-i)
-
--- --------------------------------------------------------------------------
--- Registers, whether local (temps) or global
---
-pprReg :: CmmReg -> SDoc
-pprReg r
- = case r of
- CmmLocal local -> pprLocalReg local
- CmmGlobal global -> pprGlobalReg global
-
---
--- We only print the type of the local reg if it isn't wordRep
---
-pprLocalReg :: LocalReg -> SDoc
-pprLocalReg (LocalReg uniq rep) =
--- = ppr rep <> char '_' <> ppr uniq
--- Temp Jan08
- char '_' <> pprUnique uniq <>
- (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
- then dcolon <> ptr <> ppr rep
- else dcolon <> ptr <> ppr rep)
- where
- pprUnique unique = sdocOption sdocSuppressUniques $ \case
- True -> text "_locVar_"
- False -> ppr unique
- ptr = empty
- --if isGcPtrType rep
- -- then doubleQuotes (text "ptr")
- -- else empty
-
--- Stack areas
-pprArea :: Area -> SDoc
-pprArea Old = text "old"
-pprArea (Young id) = hcat [ text "young<", ppr id, text ">" ]
-
--- needs to be kept in syn with 'GHC.Cmm.Expr.GlobalReg'
---
-pprGlobalReg :: GlobalReg -> SDoc
-pprGlobalReg gr
- = case gr of
- VanillaReg n _ -> char 'R' <> int n
--- Temp Jan08
--- VanillaReg n VNonGcPtr -> char 'R' <> int n
--- VanillaReg n VGcPtr -> char 'P' <> int n
- FloatReg n -> char 'F' <> int n
- DoubleReg n -> char 'D' <> int n
- LongReg n -> char 'L' <> int n
- XmmReg n -> text "XMM" <> int n
- YmmReg n -> text "YMM" <> int n
- ZmmReg n -> text "ZMM" <> int n
- Sp -> text "Sp"
- SpLim -> text "SpLim"
- Hp -> text "Hp"
- HpLim -> text "HpLim"
- MachSp -> text "MachSp"
- UnwindReturnReg-> text "UnwindReturnReg"
- CCCS -> text "CCCS"
- CurrentTSO -> text "CurrentTSO"
- CurrentNursery -> text "CurrentNursery"
- HpAlloc -> text "HpAlloc"
- EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
- GCEnter1 -> text "stg_gc_enter_1"
- GCFun -> text "stg_gc_fun"
- BaseReg -> text "BaseReg"
- PicBaseReg -> text "PicBaseReg"
-
------------------------------------------------------------------------------
-
-commafy :: [SDoc] -> SDoc
-commafy xs = fsep $ punctuate comma xs
diff --git a/compiler/GHC/Cmm/ProcPoint.hs b/compiler/GHC/Cmm/ProcPoint.hs
index 9297a25378..ccf542aff0 100644
--- a/compiler/GHC/Cmm/ProcPoint.hs
+++ b/compiler/GHC/Cmm/ProcPoint.hs
@@ -17,7 +17,6 @@ import GHC.Prelude hiding (last, unzip, succ, zip)
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
-import GHC.Cmm.Ppr () -- For Outputable instances
import GHC.Cmm.Utils
import GHC.Cmm.Info
import GHC.Cmm.Liveness
diff --git a/compiler/GHC/Cmm/Reg.hs b/compiler/GHC/Cmm/Reg.hs
new file mode 100644
index 0000000000..a37e5ce6f8
--- /dev/null
+++ b/compiler/GHC/Cmm/Reg.hs
@@ -0,0 +1,372 @@
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+
+module GHC.Cmm.Reg
+ ( -- * Cmm Registers
+ CmmReg(..)
+ , cmmRegType
+ , cmmRegWidth
+ -- * Local registers
+ , LocalReg(..)
+ , localRegType
+ -- * Global registers
+ , GlobalReg(..), isArgReg, globalRegType
+ , spReg, hpReg, spLimReg, hpLimReg, nodeReg
+ , currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg
+ , node, baseReg
+ , VGcPtr(..)
+ ) where
+
+import GHC.Prelude
+
+import GHC.Platform
+import GHC.Utils.Outputable
+import GHC.Types.Unique
+import GHC.Cmm.Type
+
+-----------------------------------------------------------------------------
+-- Cmm registers
+-----------------------------------------------------------------------------
+
+data CmmReg
+ = CmmLocal {-# UNPACK #-} !LocalReg
+ | CmmGlobal GlobalReg
+ deriving( Eq, Ord, Show )
+
+instance Outputable CmmReg where
+ ppr e = pprReg e
+
+pprReg :: CmmReg -> SDoc
+pprReg r
+ = case r of
+ CmmLocal local -> pprLocalReg local
+ CmmGlobal global -> pprGlobalReg global
+
+cmmRegType :: Platform -> CmmReg -> CmmType
+cmmRegType _ (CmmLocal reg) = localRegType reg
+cmmRegType platform (CmmGlobal reg) = globalRegType platform reg
+
+cmmRegWidth :: Platform -> CmmReg -> Width
+cmmRegWidth platform = typeWidth . cmmRegType platform
+
+
+-----------------------------------------------------------------------------
+-- Local registers
+-----------------------------------------------------------------------------
+
+data LocalReg
+ = LocalReg {-# UNPACK #-} !Unique !CmmType
+ -- ^ Parameters:
+ -- 1. Identifier
+ -- 2. Type
+ deriving Show
+
+instance Eq LocalReg where
+ (LocalReg u1 _) == (LocalReg u2 _) = u1 == u2
+
+instance Outputable LocalReg where
+ ppr e = pprLocalReg e
+
+-- This is non-deterministic but we do not currently support deterministic
+-- code-generation. See Note [Unique Determinism and code generation]
+-- See Note [No Ord for Unique]
+instance Ord LocalReg where
+ compare (LocalReg u1 _) (LocalReg u2 _) = nonDetCmpUnique u1 u2
+
+instance Uniquable LocalReg where
+ getUnique (LocalReg uniq _) = uniq
+
+localRegType :: LocalReg -> CmmType
+localRegType (LocalReg _ rep) = rep
+
+--
+-- We only print the type of the local reg if it isn't wordRep
+--
+pprLocalReg :: LocalReg -> SDoc
+pprLocalReg (LocalReg uniq rep) =
+-- = ppr rep <> char '_' <> ppr uniq
+-- Temp Jan08
+ char '_' <> pprUnique uniq <>
+ (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
+ then dcolon <> ptr <> ppr rep
+ else dcolon <> ptr <> ppr rep)
+ where
+ pprUnique unique = sdocOption sdocSuppressUniques $ \case
+ True -> text "_locVar_"
+ False -> ppr unique
+ ptr = empty
+ --if isGcPtrType rep
+ -- then doubleQuotes (text "ptr")
+ -- else empty
+
+-----------------------------------------------------------------------------
+-- Global STG registers
+-----------------------------------------------------------------------------
+{-
+Note [Overlapping global registers]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+The backend might not faithfully implement the abstraction of the STG
+machine with independent registers for different values of type
+GlobalReg. Specifically, certain pairs of registers (r1, r2) may
+overlap in the sense that a store to r1 invalidates the value in r2,
+and vice versa.
+
+Currently this occurs only on the x86_64 architecture where FloatReg n
+and DoubleReg n are assigned the same microarchitectural register, in
+order to allow functions to receive more Float# or Double# arguments
+in registers (as opposed to on the stack).
+
+There are no specific rules about which registers might overlap with
+which other registers, but presumably it's safe to assume that nothing
+will overlap with special registers like Sp or BaseReg.
+
+Use GHC.Cmm.Utils.regsOverlap to determine whether two GlobalRegs overlap
+on a particular platform. The instance Eq GlobalReg is syntactic
+equality of STG registers and does not take overlap into
+account. However it is still used in UserOfRegs/DefinerOfRegs and
+there are likely still bugs there, beware!
+-}
+
+data VGcPtr = VGcPtr | VNonGcPtr deriving( Eq, Show )
+
+data GlobalReg
+ -- Argument and return registers
+ = VanillaReg -- pointers, unboxed ints and chars
+ {-# UNPACK #-} !Int -- its number
+ VGcPtr
+
+ | FloatReg -- single-precision floating-point registers
+ {-# UNPACK #-} !Int -- its number
+
+ | DoubleReg -- double-precision floating-point registers
+ {-# UNPACK #-} !Int -- its number
+
+ | LongReg -- long int registers (64-bit, really)
+ {-# UNPACK #-} !Int -- its number
+
+ | XmmReg -- 128-bit SIMD vector register
+ {-# UNPACK #-} !Int -- its number
+
+ | YmmReg -- 256-bit SIMD vector register
+ {-# UNPACK #-} !Int -- its number
+
+ | ZmmReg -- 512-bit SIMD vector register
+ {-# UNPACK #-} !Int -- its number
+
+ -- STG registers
+ | Sp -- Stack ptr; points to last occupied stack location.
+ | SpLim -- Stack limit
+ | Hp -- Heap ptr; points to last occupied heap location.
+ | HpLim -- Heap limit register
+ | CCCS -- Current cost-centre stack
+ | CurrentTSO -- pointer to current thread's TSO
+ | CurrentNursery -- pointer to allocation area
+ | HpAlloc -- allocation count for heap check failure
+
+ -- We keep the address of some commonly-called
+ -- functions in the register table, to keep code
+ -- size down:
+ | EagerBlackholeInfo -- stg_EAGER_BLACKHOLE_info
+ | GCEnter1 -- stg_gc_enter_1
+ | GCFun -- stg_gc_fun
+
+ -- Base offset for the register table, used for accessing registers
+ -- which do not have real registers assigned to them. This register
+ -- will only appear after we have expanded GlobalReg into memory accesses
+ -- (where necessary) in the native code generator.
+ | BaseReg
+
+ -- The register used by the platform for the C stack pointer. This is
+ -- a break in the STG abstraction used exclusively to setup stack unwinding
+ -- information.
+ | MachSp
+
+ -- The is a dummy register used to indicate to the stack unwinder where
+ -- a routine would return to.
+ | UnwindReturnReg
+
+ -- Base Register for PIC (position-independent code) calculations
+ -- Only used inside the native code generator. It's exact meaning differs
+ -- from platform to platform (see module PositionIndependentCode).
+ | PicBaseReg
+
+ deriving( Show )
+
+instance Eq GlobalReg where
+ VanillaReg i _ == VanillaReg j _ = i==j -- Ignore type when seeking clashes
+ FloatReg i == FloatReg j = i==j
+ DoubleReg i == DoubleReg j = i==j
+ LongReg i == LongReg j = i==j
+ -- NOTE: XMM, YMM, ZMM registers actually are the same registers
+ -- at least with respect to store at YMM i and then read from XMM i
+ -- and similarly for ZMM etc.
+ XmmReg i == XmmReg j = i==j
+ YmmReg i == YmmReg j = i==j
+ ZmmReg i == ZmmReg j = i==j
+ Sp == Sp = True
+ SpLim == SpLim = True
+ Hp == Hp = True
+ HpLim == HpLim = True
+ CCCS == CCCS = True
+ CurrentTSO == CurrentTSO = True
+ CurrentNursery == CurrentNursery = True
+ HpAlloc == HpAlloc = True
+ EagerBlackholeInfo == EagerBlackholeInfo = True
+ GCEnter1 == GCEnter1 = True
+ GCFun == GCFun = True
+ BaseReg == BaseReg = True
+ MachSp == MachSp = True
+ UnwindReturnReg == UnwindReturnReg = True
+ PicBaseReg == PicBaseReg = True
+ _r1 == _r2 = False
+
+-- NOTE: this Ord instance affects the tuple layout in GHCi, see
+-- Note [GHCi tuple layout]
+instance Ord GlobalReg where
+ compare (VanillaReg i _) (VanillaReg j _) = compare i j
+ -- Ignore type when seeking clashes
+ compare (FloatReg i) (FloatReg j) = compare i j
+ compare (DoubleReg i) (DoubleReg j) = compare i j
+ compare (LongReg i) (LongReg j) = compare i j
+ compare (XmmReg i) (XmmReg j) = compare i j
+ compare (YmmReg i) (YmmReg j) = compare i j
+ compare (ZmmReg i) (ZmmReg j) = compare i j
+ compare Sp Sp = EQ
+ compare SpLim SpLim = EQ
+ compare Hp Hp = EQ
+ compare HpLim HpLim = EQ
+ compare CCCS CCCS = EQ
+ compare CurrentTSO CurrentTSO = EQ
+ compare CurrentNursery CurrentNursery = EQ
+ compare HpAlloc HpAlloc = EQ
+ compare EagerBlackholeInfo EagerBlackholeInfo = EQ
+ compare GCEnter1 GCEnter1 = EQ
+ compare GCFun GCFun = EQ
+ compare BaseReg BaseReg = EQ
+ compare MachSp MachSp = EQ
+ compare UnwindReturnReg UnwindReturnReg = EQ
+ compare PicBaseReg PicBaseReg = EQ
+ compare (VanillaReg _ _) _ = LT
+ compare _ (VanillaReg _ _) = GT
+ compare (FloatReg _) _ = LT
+ compare _ (FloatReg _) = GT
+ compare (DoubleReg _) _ = LT
+ compare _ (DoubleReg _) = GT
+ compare (LongReg _) _ = LT
+ compare _ (LongReg _) = GT
+ compare (XmmReg _) _ = LT
+ compare _ (XmmReg _) = GT
+ compare (YmmReg _) _ = LT
+ compare _ (YmmReg _) = GT
+ compare (ZmmReg _) _ = LT
+ compare _ (ZmmReg _) = GT
+ compare Sp _ = LT
+ compare _ Sp = GT
+ compare SpLim _ = LT
+ compare _ SpLim = GT
+ compare Hp _ = LT
+ compare _ Hp = GT
+ compare HpLim _ = LT
+ compare _ HpLim = GT
+ compare CCCS _ = LT
+ compare _ CCCS = GT
+ compare CurrentTSO _ = LT
+ compare _ CurrentTSO = GT
+ compare CurrentNursery _ = LT
+ compare _ CurrentNursery = GT
+ compare HpAlloc _ = LT
+ compare _ HpAlloc = GT
+ compare GCEnter1 _ = LT
+ compare _ GCEnter1 = GT
+ compare GCFun _ = LT
+ compare _ GCFun = GT
+ compare BaseReg _ = LT
+ compare _ BaseReg = GT
+ compare MachSp _ = LT
+ compare _ MachSp = GT
+ compare UnwindReturnReg _ = LT
+ compare _ UnwindReturnReg = GT
+ compare EagerBlackholeInfo _ = LT
+ compare _ EagerBlackholeInfo = GT
+
+instance Outputable GlobalReg where
+ ppr e = pprGlobalReg e
+
+instance OutputableP env GlobalReg where
+ pdoc _ = ppr
+
+pprGlobalReg :: GlobalReg -> SDoc
+pprGlobalReg gr
+ = case gr of
+ VanillaReg n _ -> char 'R' <> int n
+-- Temp Jan08
+-- VanillaReg n VNonGcPtr -> char 'R' <> int n
+-- VanillaReg n VGcPtr -> char 'P' <> int n
+ FloatReg n -> char 'F' <> int n
+ DoubleReg n -> char 'D' <> int n
+ LongReg n -> char 'L' <> int n
+ XmmReg n -> text "XMM" <> int n
+ YmmReg n -> text "YMM" <> int n
+ ZmmReg n -> text "ZMM" <> int n
+ Sp -> text "Sp"
+ SpLim -> text "SpLim"
+ Hp -> text "Hp"
+ HpLim -> text "HpLim"
+ MachSp -> text "MachSp"
+ UnwindReturnReg-> text "UnwindReturnReg"
+ CCCS -> text "CCCS"
+ CurrentTSO -> text "CurrentTSO"
+ CurrentNursery -> text "CurrentNursery"
+ HpAlloc -> text "HpAlloc"
+ EagerBlackholeInfo -> text "stg_EAGER_BLACKHOLE_info"
+ GCEnter1 -> text "stg_gc_enter_1"
+ GCFun -> text "stg_gc_fun"
+ BaseReg -> text "BaseReg"
+ PicBaseReg -> text "PicBaseReg"
+
+
+-- convenient aliases
+baseReg, spReg, hpReg, spLimReg, hpLimReg, nodeReg,
+ currentTSOReg, currentNurseryReg, hpAllocReg, cccsReg :: CmmReg
+baseReg = CmmGlobal BaseReg
+spReg = CmmGlobal Sp
+hpReg = CmmGlobal Hp
+hpLimReg = CmmGlobal HpLim
+spLimReg = CmmGlobal SpLim
+nodeReg = CmmGlobal node
+currentTSOReg = CmmGlobal CurrentTSO
+currentNurseryReg = CmmGlobal CurrentNursery
+hpAllocReg = CmmGlobal HpAlloc
+cccsReg = CmmGlobal CCCS
+
+node :: GlobalReg
+node = VanillaReg 1 VGcPtr
+
+globalRegType :: Platform -> GlobalReg -> CmmType
+globalRegType platform = \case
+ (VanillaReg _ VGcPtr) -> gcWord platform
+ (VanillaReg _ VNonGcPtr) -> bWord platform
+ (FloatReg _) -> cmmFloat W32
+ (DoubleReg _) -> cmmFloat W64
+ (LongReg _) -> cmmBits W64
+ -- TODO: improve the internal model of SIMD/vectorized registers
+ -- the right design SHOULd improve handling of float and double code too.
+ -- see remarks in "NOTE [SIMD Design for the future]"" in GHC.StgToCmm.Prim
+ (XmmReg _) -> cmmVec 4 (cmmBits W32)
+ (YmmReg _) -> cmmVec 8 (cmmBits W32)
+ (ZmmReg _) -> cmmVec 16 (cmmBits W32)
+
+ Hp -> gcWord platform -- The initialiser for all
+ -- dynamically allocated closures
+ _ -> bWord platform
+
+isArgReg :: GlobalReg -> Bool
+isArgReg (VanillaReg {}) = True
+isArgReg (FloatReg {}) = True
+isArgReg (DoubleReg {}) = True
+isArgReg (LongReg {}) = True
+isArgReg (XmmReg {}) = True
+isArgReg (YmmReg {}) = True
+isArgReg (ZmmReg {}) = True
+isArgReg _ = False
diff --git a/compiler/GHC/Cmm/Type.hs b/compiler/GHC/Cmm/Type.hs
index ee059caa12..ec000a3c47 100644
--- a/compiler/GHC/Cmm/Type.hs
+++ b/compiler/GHC/Cmm/Type.hs
@@ -364,6 +364,14 @@ data ForeignHint
-- Used to give extra per-argument or per-result
-- information needed by foreign calling conventions
+instance Outputable ForeignHint where
+ ppr NoHint = empty
+ ppr SignedHint = quotes(text "signed")
+-- ppr AddrHint = quotes(text "address")
+-- Temp Jan08
+ ppr AddrHint = (text "PtrHint")
+
+
-------------------------------------------------------------------------
-- These don't really belong here, but I don't know where is best to
diff --git a/compiler/GHC/Cmm/Utils.hs b/compiler/GHC/Cmm/Utils.hs
index 2060be5bda..fda3ee23f6 100644
--- a/compiler/GHC/Cmm/Utils.hs
+++ b/compiler/GHC/Cmm/Utils.hs
@@ -42,8 +42,6 @@ module GHC.Cmm.Utils(
cmmMkAssign,
- isTrivialCmmExpr, hasNoGlobalRegs, isLit, isComparisonExpr,
-
baseExpr, spExpr, hpExpr, spLimExpr, hpLimExpr,
currentTSOExpr, currentNurseryExpr, cccsExpr,
@@ -61,9 +59,9 @@ module GHC.Cmm.Utils(
modifyGraph,
ofBlockMap, toBlockMap,
- ofBlockList, toBlockList, bodyToBlockList,
+ ofBlockList, toBlockList,
toBlockListEntryFirst, toBlockListEntryFirstFalseFallthrough,
- foldlGraphBlocks, mapGraphNodes, revPostorder, mapGraphNodes1,
+ foldlGraphBlocks, mapGraphNodes, mapGraphNodes1,
-- * Ticks
blockTicks
@@ -400,36 +398,6 @@ cmmMkAssign platform expr uq =
---------------------------------------------------
--
--- CmmExpr predicates
---
----------------------------------------------------
-
-isTrivialCmmExpr :: CmmExpr -> Bool
-isTrivialCmmExpr (CmmLoad _ _ _) = False
-isTrivialCmmExpr (CmmMachOp _ _) = False
-isTrivialCmmExpr (CmmLit _) = True
-isTrivialCmmExpr (CmmReg _) = True
-isTrivialCmmExpr (CmmRegOff _ _) = True
-isTrivialCmmExpr (CmmStackSlot _ _) = panic "isTrivialCmmExpr CmmStackSlot"
-
-hasNoGlobalRegs :: CmmExpr -> Bool
-hasNoGlobalRegs (CmmLoad e _ _) = hasNoGlobalRegs e
-hasNoGlobalRegs (CmmMachOp _ es) = all hasNoGlobalRegs es
-hasNoGlobalRegs (CmmLit _) = True
-hasNoGlobalRegs (CmmReg (CmmLocal _)) = True
-hasNoGlobalRegs (CmmRegOff (CmmLocal _) _) = True
-hasNoGlobalRegs _ = False
-
-isLit :: CmmExpr -> Bool
-isLit (CmmLit _) = True
-isLit _ = False
-
-isComparisonExpr :: CmmExpr -> Bool
-isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
-isComparisonExpr _ = False
-
----------------------------------------------------
---
-- Tagging
--
---------------------------------------------------
@@ -525,9 +493,6 @@ mkLiveness platform (reg:regs)
modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n'
modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)}
-toBlockMap :: CmmGraph -> LabelMap CmmBlock
-toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
-
ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
@@ -578,9 +543,6 @@ ofBlockList entry blocks = CmmGraph { g_entry = entry
, g_graph = GMany NothingO body NothingO }
where body = foldr addBlock emptyBody blocks
-bodyToBlockList :: Body CmmNode -> [CmmBlock]
-bodyToBlockList body = mapElems body
-
mapGraphNodes :: ( CmmNode C O -> CmmNode C O
, CmmNode O O -> CmmNode O O
, CmmNode O C -> CmmNode O C)
@@ -596,10 +558,6 @@ mapGraphNodes1 f = modifyGraph (mapGraph f)
foldlGraphBlocks :: (a -> CmmBlock -> a) -> a -> CmmGraph -> a
foldlGraphBlocks k z g = mapFoldl k z $ toBlockMap g
-revPostorder :: CmmGraph -> [CmmBlock]
-revPostorder g = {-# SCC "revPostorder" #-}
- revPostorderFrom (toBlockMap g) (g_entry g)
-
-------------------------------------------------
-- Tick utilities
diff --git a/compiler/GHC/CmmToAsm.hs b/compiler/GHC/CmmToAsm.hs
index 29ec7559f6..21b68a8f01 100644
--- a/compiler/GHC/CmmToAsm.hs
+++ b/compiler/GHC/CmmToAsm.hs
@@ -116,7 +116,6 @@ import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Label
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Opt ( cmmMachOpFold )
-import GHC.Cmm.Ppr
import GHC.Cmm.CLabel
import GHC.Types.Unique.FM
diff --git a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs
index b1761a1db2..5190633448 100644
--- a/compiler/GHC/CmmToAsm/AArch64/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/AArch64/Ppr.hs
@@ -22,7 +22,6 @@ import GHC.Types.Basic (Alignment, mkAlignment, alignmentBytes)
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
-import GHC.Cmm.Ppr.Expr () -- For Outputable instances
import GHC.Types.Unique ( pprUniqueAlways, getUnique )
import GHC.Platform
diff --git a/compiler/GHC/CmmToAsm/CFG.hs b/compiler/GHC/CmmToAsm/CFG.hs
index e992116117..2d8caefcc5 100644
--- a/compiler/GHC/CmmToAsm/CFG.hs
+++ b/compiler/GHC/CmmToAsm/CFG.hs
@@ -78,7 +78,6 @@ import GHC.Utils.Panic.Plain
--import GHC.Cmm.DebugBlock
--import GHC.Data.OrdList
--import GHC.Cmm.DebugBlock.Trace
-import GHC.Cmm.Ppr () -- For Outputable instances
import Data.List (sort, nub, partition)
import Data.STRef.Strict
diff --git a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
index 844e4744da..099d10920e 100644
--- a/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
+++ b/compiler/GHC/CmmToAsm/PPC/CodeGen.hs
@@ -48,7 +48,6 @@ import GHC.Platform
-- Our intermediate code:
import GHC.Cmm.BlockId
-import GHC.Cmm.Ppr ( pprExpr )
import GHC.Cmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
@@ -395,7 +394,7 @@ iselExpr64 (CmmMachOp (MO_SS_Conv W32 W64) [expr]) = do
iselExpr64 expr
= do
platform <- getPlatform
- pprPanic "iselExpr64(powerpc)" (pprExpr platform expr)
+ pprPanic "iselExpr64(powerpc)" (pdoc platform expr)
@@ -689,7 +688,7 @@ getRegister' config platform (CmmLit lit)
`consOL` (addr_code `snocOL` LD format dst addr)
return (Any format code)
-getRegister' _ platform other = pprPanic "getRegister(ppc)" (pprExpr platform other)
+getRegister' _ platform other = pprPanic "getRegister(ppc)" (pdoc platform other)
-- extend?Rep: wrap integer expression of type `from`
-- in a conversion to `to`
diff --git a/compiler/GHC/CmmToAsm/PPC/Ppr.hs b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
index a842eef998..c0b2385b3c 100644
--- a/compiler/GHC/CmmToAsm/PPC/Ppr.hs
+++ b/compiler/GHC/CmmToAsm/PPC/Ppr.hs
@@ -34,7 +34,6 @@ import GHC.Cmm.Dataflow.Label
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
-import GHC.Cmm.Ppr.Expr () -- For Outputable instances
import GHC.Types.Unique ( pprUniqueAlways, getUnique )
import GHC.Platform
diff --git a/compiler/GHC/CmmToC.hs b/compiler/GHC/CmmToC.hs
index c9f86e9afe..1659575459 100644
--- a/compiler/GHC/CmmToC.hs
+++ b/compiler/GHC/CmmToC.hs
@@ -33,8 +33,7 @@ import GHC.CmmToAsm.CPrim
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
-import GHC.Cmm hiding (pprBBlock)
-import GHC.Cmm.Ppr () -- For Outputable instances
+import GHC.Cmm hiding (pprBBlock, pprStatic)
import GHC.Cmm.Dataflow.Block
import GHC.Cmm.Dataflow.Collections
import GHC.Cmm.Dataflow.Graph
diff --git a/compiler/GHC/CmmToLlvm.hs b/compiler/GHC/CmmToLlvm.hs
index 1833ddb74f..80a68e76e7 100644
--- a/compiler/GHC/CmmToLlvm.hs
+++ b/compiler/GHC/CmmToLlvm.hs
@@ -25,7 +25,6 @@ import GHC.CmmToLlvm.Mangler
import GHC.StgToCmm.CgUtils ( fixStgRegisters )
import GHC.Cmm
import GHC.Cmm.Dataflow.Collections
-import GHC.Cmm.Ppr
import GHC.Utils.BufHandle
import GHC.Driver.Session
diff --git a/compiler/GHC/CmmToLlvm/Base.hs b/compiler/GHC/CmmToLlvm/Base.hs
index f72411c4ec..33592092de 100644
--- a/compiler/GHC/CmmToLlvm/Base.hs
+++ b/compiler/GHC/CmmToLlvm/Base.hs
@@ -42,7 +42,6 @@ import GHC.CmmToLlvm.Regs
import GHC.CmmToLlvm.Config
import GHC.Cmm.CLabel
-import GHC.Cmm.Ppr.Expr ()
import GHC.Platform.Regs ( activeStgRegs, globalRegMaybe )
import GHC.Driver.Session
import GHC.Data.FastString
diff --git a/compiler/GHC/CmmToLlvm/CodeGen.hs b/compiler/GHC/CmmToLlvm/CodeGen.hs
index f44fe1af6e..55c6e18883 100644
--- a/compiler/GHC/CmmToLlvm/CodeGen.hs
+++ b/compiler/GHC/CmmToLlvm/CodeGen.hs
@@ -19,7 +19,6 @@ import GHC.CmmToLlvm.Regs
import GHC.Cmm.BlockId
import GHC.Cmm.CLabel
import GHC.Cmm
-import GHC.Cmm.Ppr as PprCmm
import GHC.Cmm.Utils
import GHC.Cmm.Switch
import GHC.Cmm.Dataflow.Block
@@ -1204,7 +1203,7 @@ genStore_slow addr val alignment meta = do
other ->
pprPanic "genStore: ptr not right type!"
- (PprCmm.pprExpr platform addr <+> text (
+ (pdoc platform addr <+> text (
"Size of Ptr: " ++ show (llvmPtrBits platform) ++
", Size of var: " ++ show (llvmWidthInBits platform other) ++
", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg vaddr)))
@@ -1725,7 +1724,7 @@ genMachOp_slow opt op [x, y] = case op of
-> do
-- Error. Continue anyway so we can debug the generated ll file.
let render = renderWithContext (llvmCgContext cfg)
- cmmToStr = (lines . render . PprCmm.pprExpr platform)
+ cmmToStr = (lines . render . pdoc platform)
statement $ Comment $ map fsLit $ cmmToStr x
statement $ Comment $ map fsLit $ cmmToStr y
doExprW (ty vx) $ binOp vx vy
@@ -1882,7 +1881,7 @@ genLoad_slow atomic e ty align meta = do
doExprW (cmmToLlvmType ty) (MExpr meta $ mkLoad atomic ptr align)
other -> pprPanic "exprToVar: CmmLoad expression is not right type!"
- (PprCmm.pprExpr platform e <+> text (
+ (pdoc platform e <+> text (
"Size of Ptr: " ++ show (llvmPtrBits platform) ++
", Size of var: " ++ show (llvmWidthInBits platform other) ++
", Var: " ++ renderWithContext (llvmCgContext cfg) (ppVar cfg iptr)))
diff --git a/compiler/GHC/StgToCmm/Closure.hs b/compiler/GHC/StgToCmm/Closure.hs
index 7c1b5250e4..d935bb4b99 100644
--- a/compiler/GHC/StgToCmm/Closure.hs
+++ b/compiler/GHC/StgToCmm/Closure.hs
@@ -76,7 +76,6 @@ import GHC.Stg.Syntax
import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.Utils
-import GHC.Cmm.Ppr.Expr() -- For Outputable instances
import GHC.StgToCmm.Types
import GHC.StgToCmm.Sequel
diff --git a/compiler/GHC/StgToCmm/Expr.hs b/compiler/GHC/StgToCmm/Expr.hs
index 7992e34417..9494a3c57d 100644
--- a/compiler/GHC/StgToCmm/Expr.hs
+++ b/compiler/GHC/StgToCmm/Expr.hs
@@ -38,7 +38,6 @@ import GHC.Cmm.BlockId
import GHC.Cmm hiding ( succ )
import GHC.Cmm.Info
import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG )
-import GHC.Cmm.Ppr
import GHC.Core
import GHC.Core.DataCon
import GHC.Types.ForeignCall
@@ -1021,7 +1020,7 @@ cgIdApp fun_id args = do
assertTag = whenCheckTags $ do
mod <- getModuleName
emitTagAssertion (showPprUnsafe
- (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pprExpr platform fun))
+ (text "TagCheck failed on entry in" <+> ppr mod <+> text "- value:" <> ppr fun_id <+> pdoc platform fun))
fun
EnterIt -> assert (null args) $ -- Discarding arguments
diff --git a/compiler/GHC/StgToCmm/Sequel.hs b/compiler/GHC/StgToCmm/Sequel.hs
index ac55c3620f..e799e79678 100644
--- a/compiler/GHC/StgToCmm/Sequel.hs
+++ b/compiler/GHC/StgToCmm/Sequel.hs
@@ -17,7 +17,6 @@ module GHC.StgToCmm.Sequel
import GHC.Cmm.BlockId
import GHC.Cmm
-import GHC.Cmm.Ppr()
import GHC.Types.Id
import GHC.Utils.Outputable
diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in
index 452b34cce6..dc6de716f7 100644
--- a/compiler/ghc.cabal.in
+++ b/compiler/ghc.cabal.in
@@ -208,10 +208,8 @@ Library
GHC.Cmm.Parser.Config
GHC.Cmm.Parser.Monad
GHC.Cmm.Pipeline
- GHC.Cmm.Ppr
- GHC.Cmm.Ppr.Decl
- GHC.Cmm.Ppr.Expr
GHC.Cmm.ProcPoint
+ GHC.Cmm.Reg
GHC.Cmm.Sink
GHC.Cmm.Switch
GHC.Cmm.Switch.Implement