mkDefaultLabel uniq = CaseLabel uniq CaseDefault
mkStringLitLabel = StringLitLabel
-mkAsmTempLabel = AsmTempLabel
+mkAsmTempLabel :: Uniquable a => a -> CLabel
+mkAsmTempLabel a = AsmTempLabel (getUnique a)
mkModuleInitLabel :: Module -> String -> CLabel
mkModuleInitLabel mod way = ModuleInitLabel mod way
+{-# OPTIONS -Wall -fno-warn-name-shadowing -fno-warn-orphans #-}
-----------------------------------------------------------------------------
--
-- Cmm data types
--
-----------------------------------------------------------------------------
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
module Cmm (
GenCmm(..), Cmm, RawCmm,
GenCmmTop(..), CmmTop, RawCmmTop,
- ListGraph(..),
+ ListGraph(..),
+ cmmMapGraph, cmmTopMapGraph,
+ cmmMapGraphM, cmmTopMapGraphM,
CmmInfo(..), UpdateFrame(..),
CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
- GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
+ GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
CmmReturnInfo(..),
CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
CmmSafety(..),
CmmCallTarget(..),
CmmStatic(..), Section(..),
- CmmExpr(..), cmmExprRep,
+ CmmExpr(..), cmmExprRep, maybeInvertCmmExpr,
CmmReg(..), cmmRegRep,
CmmLit(..), cmmLitRep,
LocalReg(..), localRegRep, localRegGCFollow, Kind(..),
- BlockId(..), BlockEnv,
+ BlockId(..), freshBlockId,
+ BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv,
+ BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet,
GlobalReg(..), globalRegRep,
node, nodeReg, spReg, hpReg, spLimReg
) where
+-- ^ In order not to do violence to the import structure of the rest
+-- of the compiler, module Cmm re-exports a number of identifiers
+-- defined in 'CmmExpr'
+
#include "HsVersions.h"
+import CmmExpr
import MachOp
import CLabel
import ForeignCall
import SMRep
import ClosureInfo
-import Unique
-import UniqFM
+import Outputable
import FastString
import Data.Word
+import ZipCfg ( BlockId(..), freshBlockId
+ , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv
+ , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet
+ )
+
+-- A [[BlockId]] is a local label.
+-- Local labels must be unique within an entire compilation unit, not
+-- just a single top-level item, because local labels map one-to-one
+-- with assembly-language labels.
+
-----------------------------------------------------------------------------
-- Cmm, CmmTop, CmmBasicBlock
-----------------------------------------------------------------------------
-- (Cmm and RawCmm below)
-- (b) Native code, populated with data/instructions
--
+-- A second family of instances based on ZipCfg is work in progress.
+--
newtype GenCmm d h g = Cmm [GenCmmTop d h g]
-- | A top-level chunk, abstracted over the type of the contents of
data GenBasicBlock i = BasicBlock BlockId [i]
type CmmBasicBlock = GenBasicBlock CmmStmt
+instance UserOfLocalRegs i => UserOfLocalRegs (GenBasicBlock i) where
+ foldRegsUsed f set (BasicBlock _ l) = foldRegsUsed f set l
+
blockId :: GenBasicBlock i -> BlockId
-- The branch block id is that of the first block in
-- the branch, which is that branch's entry point
blockStmts :: GenBasicBlock i -> [i]
blockStmts (BasicBlock _ stmts) = stmts
+
mapBlockStmts :: (i -> i') -> GenBasicBlock i -> GenBasicBlock i'
mapBlockStmts f (BasicBlock id bs) = BasicBlock id (map f bs)
+----------------------------------------------------------------
+-- graph maps
+----------------------------------------------------------------
+
+cmmMapGraph :: (g -> g') -> GenCmm d h g -> GenCmm d h g'
+cmmTopMapGraph :: (g -> g') -> GenCmmTop d h g -> GenCmmTop d h g'
+
+cmmMapGraphM :: Monad m => (String -> g -> m g') -> GenCmm d h g -> m (GenCmm d h g')
+cmmTopMapGraphM :: Monad m => (String -> g -> m g') -> GenCmmTop d h g -> m (GenCmmTop d h g')
+
+cmmMapGraph f (Cmm tops) = Cmm $ map (cmmTopMapGraph f) tops
+cmmTopMapGraph f (CmmProc h l args g) = CmmProc h l args (f g)
+cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
+
+cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm
+cmmTopMapGraphM f (CmmProc h l args g) = f (showSDoc $ ppr l) g >>= return . CmmProc h l args
+cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds
-----------------------------------------------------------------------------
-- Info Tables
type CmmFormals = [CmmFormal]
data CmmSafety = CmmUnsafe | CmmSafe C_SRT
+-- | enable us to fold used registers over 'CmmActuals' and 'CmmHintFormals'
+instance UserOfLocalRegs a => UserOfLocalRegs (a, MachHint) where
+ foldRegsUsed f set (a, _) = foldRegsUsed f set a
+
+instance UserOfLocalRegs CmmStmt where
+ foldRegsUsed f set s = stmt s set
+ where stmt (CmmNop) = id
+ stmt (CmmComment {}) = id
+ stmt (CmmAssign _ e) = gen e
+ stmt (CmmStore e1 e2) = gen e1 . gen e2
+ stmt (CmmCall target _ es _ _) = gen target . gen es
+ stmt (CmmBranch _) = id
+ stmt (CmmCondBranch e _) = gen e
+ stmt (CmmSwitch e _) = gen e
+ stmt (CmmJump e es) = gen e . gen es
+ stmt (CmmReturn es) = gen es
+ gen a set = foldRegsUsed f set a
+
+instance UserOfLocalRegs CmmCallTarget where
+ foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
+ foldRegsUsed _ set (CmmPrim {}) = set
+
{-
Discussion
~~~~~~~~~~
non-local conditional jump is to encode it as a branch to a block that
contains a single jump. This leads to inefficient code in the back end.
+[N.B. This problem will go away when we make the transition to the
+'zipper' form of control-flow graph, in which both targets of a
+conditional jump are explicit. ---NR]
+
One possible way to fix this would be:
data CmmStat =
-- code by the backend.
-----------------------------------------------------------------------------
--- CmmExpr
--- An expression. Expressions have no side effects.
------------------------------------------------------------------------------
-
-data CmmExpr
- = CmmLit CmmLit -- Literal
- | CmmLoad CmmExpr MachRep -- Read memory location
- | CmmReg CmmReg -- Contents of register
- | CmmMachOp MachOp [CmmExpr] -- Machine operation (+, -, *, etc.)
- | CmmRegOff CmmReg Int
- -- CmmRegOff reg i
- -- ** is shorthand only, meaning **
- -- CmmMachOp (MO_S_Add rep (CmmReg reg) (CmmLit (CmmInt i rep)))
- -- where rep = cmmRegRep reg
- deriving Eq
-
-data CmmReg
- = CmmLocal LocalReg
- | CmmGlobal GlobalReg
- deriving( Eq )
-
--- | Whether a 'LocalReg' is a GC followable pointer
-data Kind = KindPtr | KindNonPtr deriving (Eq)
-
-data LocalReg
- = LocalReg
- !Unique -- ^ Identifier
- MachRep -- ^ Type
- Kind -- ^ Should the GC follow as a pointer
-
-data CmmLit
- = CmmInt Integer MachRep
- -- 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 MachRep doesn't
- -- distinguish between signed & unsigned).
- | CmmFloat Rational MachRep
- | 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 -- label1 - label2 + offset
- deriving Eq
-
-instance Eq LocalReg where
- (LocalReg u1 _ _) == (LocalReg u2 _ _) = u1 == u2
-
-instance Uniquable LocalReg where
- getUnique (LocalReg uniq _ _) = uniq
-
------------------------------------------------------------------------------
--- MachRep
------------------------------------------------------------------------------
-cmmExprRep :: CmmExpr -> MachRep
-cmmExprRep (CmmLit lit) = cmmLitRep lit
-cmmExprRep (CmmLoad _ rep) = rep
-cmmExprRep (CmmReg reg) = cmmRegRep reg
-cmmExprRep (CmmMachOp op _) = resultRepOfMachOp op
-cmmExprRep (CmmRegOff reg _) = cmmRegRep reg
-
-cmmRegRep :: CmmReg -> MachRep
-cmmRegRep (CmmLocal reg) = localRegRep reg
-cmmRegRep (CmmGlobal reg) = globalRegRep reg
-
-localRegRep :: LocalReg -> MachRep
-localRegRep (LocalReg _ rep _) = rep
-
-localRegGCFollow :: LocalReg -> Kind
-localRegGCFollow (LocalReg _ _ p) = p
-
-cmmLitRep :: CmmLit -> MachRep
-cmmLitRep (CmmInt _ rep) = rep
-cmmLitRep (CmmFloat _ rep) = rep
-cmmLitRep (CmmLabel _) = wordRep
-cmmLitRep (CmmLabelOff _ _) = wordRep
-cmmLitRep (CmmLabelDiffOff _ _ _) = wordRep
-
------------------------------------------------------------------------------
--- A local label.
-
--- Local labels must be unique within a single compilation unit.
-
-newtype BlockId = BlockId Unique
- deriving (Eq,Ord)
-
-instance Uniquable BlockId where
- getUnique (BlockId u) = u
-
-type BlockEnv a = UniqFM {- BlockId -} a
-
------------------------------------------------------------------------------
-- Static Data
-----------------------------------------------------------------------------
| CmmString [Word8]
-- string of 8-bit values only, not zero terminated.
------------------------------------------------------------------------------
--- Global STG registers
------------------------------------------------------------------------------
-
-data GlobalReg
- -- Argument and return registers
- = VanillaReg -- pointers, unboxed ints and chars
- {-# UNPACK #-} !Int -- its number
-
- | 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
-
- -- 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
- | 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:
- | 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
-
- -- 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( Eq
-#ifdef DEBUG
- , Show
-#endif
- )
-
--- convenient aliases
-spReg, hpReg, spLimReg, nodeReg :: CmmReg
-spReg = CmmGlobal Sp
-hpReg = CmmGlobal Hp
-spLimReg = CmmGlobal SpLim
-nodeReg = CmmGlobal node
-
-node :: GlobalReg
-node = VanillaReg 1
-
-globalRegRep :: GlobalReg -> MachRep
-globalRegRep (VanillaReg _) = wordRep
-globalRegRep (FloatReg _) = F32
-globalRegRep (DoubleReg _) = F64
-globalRegRep (LongReg _) = I64
-globalRegRep _ = wordRep
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
-- for details
module CmmCallConv (
import Cmm
import CmmUtils
-import PprCmm
import CLabel
import MachOp
import Constants
import StaticFlags
-import DynFlags
import Unique
import UniqSupply
import Panic
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
-mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments (ListGraph blocks)) =
+mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
case info of
-- | Code without an info table. Easy.
- CmmNonInfoTable -> [CmmProc [] entry_label arguments (ListGraph blocks)]
+ CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
let info_label = entryLblToInfoLbl entry_label
-> [CmmLit]
-> CLabel
-> CmmFormals
- -> [CmmBasicBlock]
+ -> ListGraph CmmStmt
-> [RawCmmTop]
mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
| tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
= [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
- entry_lbl args (ListGraph blocks)]
+ entry_lbl args blocks]
- | null blocks -- No actual code; only the info table is significant
+ | ListGraph [] <- blocks -- No code; only the info table is significant
= -- Use a zero place-holder in place of the
-- entry-label in the info table
[mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)]
| otherwise -- Separately emit info table (with the function entry
= -- point as first entry) and the entry code
- [CmmProc [] entry_lbl args (ListGraph blocks),
+ [CmmProc [] entry_lbl args blocks,
mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
mkSRTLit :: CLabel
| otherwise = []
type_lit = packHalfWordsCLit cl_type srt_len
+
+
+_unused :: FS.FastString -- stops a warning
+_unused = undefined
import Cmm
import CLabel
import MachOp
+import Maybe
import Outputable
import PprCmm
import Unique
Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
Right _ -> Nothing
+lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
= addLintInfo (text "in proc " <> pprCLabel lbl) $
- mapM_ lintCmmBlock blocks
-lintCmmTop _other
+ let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
+ in mapM_ (lintCmmBlock labels) blocks
+
+lintCmmTop (CmmData {})
= return ()
-lintCmmBlock (BasicBlock id stmts)
+lintCmmBlock labels (BasicBlock id stmts)
= addLintInfo (text "in basic block " <> ppr (getUnique id)) $
- mapM_ lintCmmStmt stmts
+ mapM_ (lintCmmStmt labels) stmts
-- -----------------------------------------------------------------------------
-- lintCmmExpr
cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)]
| isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0
= cmmLintDubiousWordOffset (CmmMachOp op args)
-cmmCheckMachOp op [lit@(CmmLit (CmmInt i _)), reg@(CmmReg _)]
+cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)]
= cmmCheckMachOp op [reg, lit]
cmmCheckMachOp op@(MO_U_Conv from to) args
| isFloatingRep from || isFloatingRep to
= cmmLintErr (text "unsigned conversion from/to floating rep: "
<> ppr (CmmMachOp op args))
-cmmCheckMachOp op args
+cmmCheckMachOp op _args
= return (resultRepOfMachOp op)
isWordOffsetReg (CmmGlobal Sp) = True
notNodeReg (CmmReg reg) | reg == nodeReg = False
notNodeReg _ = True
-lintCmmStmt :: CmmStmt -> CmmLint ()
-lintCmmStmt stmt@(CmmAssign reg expr) = do
- erep <- lintCmmExpr expr
- if (erep == cmmRegRep reg)
- then return ()
- else cmmLintAssignErr stmt
-lintCmmStmt (CmmStore l r) = do
- lintCmmExpr l
- lintCmmExpr r
- return ()
-lintCmmStmt (CmmCall _target _res args _ _) = mapM_ (lintCmmExpr.fst) args
-lintCmmStmt (CmmCondBranch e _id) = lintCmmExpr e >> checkCond e >> return ()
-lintCmmStmt (CmmSwitch e _branches) = do
- erep <- lintCmmExpr e
- if (erep == wordRep)
- then return ()
- else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
-lintCmmStmt (CmmJump e _args) = lintCmmExpr e >> return ()
-lintCmmStmt _other = return ()
+lintCmmStmt :: BlockSet -> CmmStmt -> CmmLint ()
+lintCmmStmt labels = lint
+ where lint (CmmNop) = return ()
+ lint (CmmComment {}) = return ()
+ lint stmt@(CmmAssign reg expr) = do
+ erep <- lintCmmExpr expr
+ if (erep == cmmRegRep reg)
+ then return ()
+ else cmmLintAssignErr stmt
+ lint (CmmStore l r) = do
+ lintCmmExpr l
+ lintCmmExpr r
+ return ()
+ lint (CmmCall target _res args _ _) =
+ lintTarget target >> mapM_ (lintCmmExpr.fst) args
+ lint (CmmCondBranch e id) = checkTarget id >> lintCmmExpr e >> checkCond e
+ lint (CmmSwitch e branches) = do
+ mapM_ checkTarget $ catMaybes branches
+ erep <- lintCmmExpr e
+ if (erep == wordRep)
+ then return ()
+ else cmmLintErr (text "switch scrutinee is not a word: " <> ppr e)
+ lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr.fst) args
+ lint (CmmReturn ress) = mapM_ (lintCmmExpr.fst) ress
+ lint (CmmBranch id) = checkTarget id
+ checkTarget id = if elemBlockSet id labels then return ()
+ else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
+
+lintTarget :: CmmCallTarget -> CmmLint ()
+lintTarget (CmmCallee e _) = lintCmmExpr e >> return ()
+lintTarget (CmmPrim {}) = return ()
+
checkCond (CmmMachOp mop _) | isComparisonMachOp mop = return ()
checkCond expr = cmmLintErr (hang (text "expression is not a conditional:") 2
#include "HsVersions.h"
import Cmm
+import CmmExpr
import CmmUtils
import CLabel
import MachOp
- if we reach the statement that uses it, inline the rhs
and delete the original assignment.
+[N.B. In the Quick C-- compiler, this optimization is achieved by a
+ combination of two dataflow passes: forward substitution (peephole
+ optimization) and dead-assignment elimination. ---NR]
+
Possible generalisations: here is an example from factorial
Fac_zdwfac_entry:
its occurrences.
-}
+countUses :: UserOfLocalRegs a => a -> UniqFM Int
+countUses a = foldRegsUsed (\m r -> addToUFM m r (count m r + 1)) emptyUFM a
+ where count m r = lookupWithDefaultUFM m (0::Int) r
+
cmmMiniInline :: [CmmBasicBlock] -> [CmmBasicBlock]
cmmMiniInline blocks = map do_inline blocks
- where
- blockUses (BasicBlock _ stmts)
- = foldr (plusUFM_C (+)) emptyUFM (map getStmtUses stmts)
-
- uses = foldr (plusUFM_C (+)) emptyUFM (map blockUses blocks)
-
- do_inline (BasicBlock id stmts)
- = BasicBlock id (cmmMiniInlineStmts uses stmts)
-
+ where do_inline (BasicBlock id stmts)
+ = BasicBlock id (cmmMiniInlineStmts (countUses blocks) stmts)
cmmMiniInlineStmts :: UniqFM Int -> [CmmStmt] -> [CmmStmt]
cmmMiniInlineStmts uses [] = []
-- and temporaries are single-assignment.
lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _ _)) rhs) : rest)
| u /= u'
- = case lookupUFM (getExprUses rhs) u of
+ = case lookupUFM (countUses rhs) u of
Just 1 -> Just (inlineStmt u expr stmt : rest)
_other -> case lookForInline u expr rest of
Nothing -> Nothing
lookForInline u expr (CmmNop : rest)
= lookForInline u expr rest
+lookForInline _ _ [] = Nothing
+
lookForInline u expr (stmt:stmts)
- = case lookupUFM (getStmtUses stmt) u of
+ = case lookupUFM (countUses stmt) u of
Just 1 | ok_to_inline -> Just (inlineStmt u expr stmt : stmts)
_other -> Nothing
where
CmmCall{} -> hasNoGlobalRegs expr
_ -> True
--- -----------------------------------------------------------------------------
--- Boring Cmm traversals for collecting usage info and substitutions.
-
-getStmtUses :: CmmStmt -> UniqFM Int
-getStmtUses (CmmAssign _ e) = getExprUses e
-getStmtUses (CmmStore e1 e2) = plusUFM_C (+) (getExprUses e1) (getExprUses e2)
-getStmtUses (CmmCall target _ es _ _)
- = plusUFM_C (+) (uses target) (getExprsUses (map fst es))
- where uses (CmmCallee e _) = getExprUses e
- uses _ = emptyUFM
-getStmtUses (CmmCondBranch e _) = getExprUses e
-getStmtUses (CmmSwitch e _) = getExprUses e
-getStmtUses (CmmJump e _) = getExprUses e
-getStmtUses _ = emptyUFM
-
-getExprUses :: CmmExpr -> UniqFM Int
-getExprUses (CmmReg (CmmLocal (LocalReg u _ _))) = unitUFM u 1
-getExprUses (CmmRegOff (CmmLocal (LocalReg u _ _)) _) = unitUFM u 1
-getExprUses (CmmLoad e _) = getExprUses e
-getExprUses (CmmMachOp _ es) = getExprsUses es
-getExprUses _other = emptyUFM
-
-getExprsUses es = foldr (plusUFM_C (+)) emptyUFM (map getExprUses es)
-
inlineStmt :: Unique -> CmmExpr -> CmmStmt -> CmmStmt
inlineStmt u a (CmmAssign r e) = CmmAssign r (inlineExpr u a e)
inlineStmt u a (CmmStore e1 e2) = CmmStore (inlineExpr u a e1) (inlineExpr u a e2)
MO_S_Shr r -> x
MO_U_Shr r -> x
MO_Ne r | isComparisonExpr x -> x
- MO_Eq r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_Eq r | Just x' <- maybeInvertCmmExpr x -> x'
MO_U_Gt r | isComparisonExpr x -> x
MO_S_Gt r | isComparisonExpr x -> x
MO_U_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
MO_S_Lt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
MO_U_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
MO_S_Ge r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
- MO_U_Le r | Just x' <- maybeInvertConditionalExpr x -> x'
- MO_S_Le r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_U_Le r | Just x' <- maybeInvertCmmExpr x -> x'
+ MO_S_Le r | Just x' <- maybeInvertCmmExpr x -> x'
other -> CmmMachOp mop args
cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
MO_U_Quot r -> x
MO_S_Rem r -> CmmLit (CmmInt 0 rep)
MO_U_Rem r -> CmmLit (CmmInt 0 rep)
- MO_Ne r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_Ne r | Just x' <- maybeInvertCmmExpr x -> x'
MO_Eq r | isComparisonExpr x -> x
- MO_U_Lt r | Just x' <- maybeInvertConditionalExpr x -> x'
- MO_S_Lt r | Just x' <- maybeInvertConditionalExpr x -> x'
+ MO_U_Lt r | Just x' <- maybeInvertCmmExpr x -> x'
+ MO_S_Lt r | Just x' <- maybeInvertCmmExpr x -> x'
MO_U_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
MO_S_Gt r | isComparisonExpr x -> CmmLit (CmmInt 0 wordRep)
MO_U_Le r | isComparisonExpr x -> CmmLit (CmmInt 1 wordRep)
isComparisonExpr (CmmMachOp op _) = isComparisonMachOp op
isComparisonExpr _other = False
-maybeInvertConditionalExpr :: CmmExpr -> Maybe CmmExpr
-maybeInvertConditionalExpr (CmmMachOp op args)
- | Just op' <- maybeInvertComparison op = Just (CmmMachOp op' args)
-maybeInvertConditionalExpr _ = Nothing
-
isPicReg (CmmReg (CmmGlobal PicBaseReg)) = True
isPicReg _ = False
+
+_unused :: FS.FastString -- stops a warning
+_unused = undefined
case convention of
-- Temporary hack so at least some functions are CmmSafe
CmmCallConv -> code (stmtC (CmmCall (CmmCallee expr convention) results args safety ret))
- _ ->
- let expr' = adjCallTarget convention expr args in
- case safety of
+ _ -> case safety of
CmmUnsafe ->
code (emitForeignCall' PlayRisky results
- (CmmCallee expr' convention) args vols NoC_SRT ret)
+ (CmmCallee expr convention) args vols NoC_SRT ret)
CmmSafe srt ->
code (emitForeignCall' (PlaySafe unused) results
- (CmmCallee expr' convention) args vols NoC_SRT ret) where
+ (CmmCallee expr convention) args vols NoC_SRT ret) where
unused = panic "not used by emitForeignCall'"
-adjCallTarget :: CCallConv -> CmmExpr -> [(CmmExpr,MachHint)] -> CmmExpr
-#ifdef mingw32_TARGET_OS
--- On Windows, we have to add the '@N' suffix to the label when making
--- a call with the stdcall calling convention.
-adjCallTarget StdCallConv (CmmLit (CmmLabel lbl)) args
- = CmmLit (CmmLabel (addLabelSize lbl (sum (map size args))))
- where size (e,_) = max wORD_SIZE (machRepByteWidth (cmmExprRep e))
- -- c.f. CgForeignCall.emitForeignCall
-#endif
-adjCallTarget _ expr _
- = expr
-
primCall
:: [ExtFCode (CmmFormal,MachHint)]
-> FastString
let ms = getMessages pst
printErrorsAndWarnings dflags ms
when (errorsFound dflags ms) $ exitWith (ExitFailure 1)
- dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (pprCmms [cmm])
+ dumpIfSet_dyn dflags Opt_D_dump_cmm "Cmm" (ppr cmm)
return (Just cmm)
where
no_module = panic "parseCmmFile: no module"
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
--
-module PprCmm (
- writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
- ) where
+module PprCmm
+ ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr, pprSection, pprStatic
+ )
+where
#include "HsVersions.h"
import Cmm
+import CmmExpr
import CmmUtils
import MachOp
import CLabel
import System.IO
import Data.Maybe
-pprCmms :: (Outputable info) => [GenCmm CmmStatic info (ListGraph CmmStmt)] -> SDoc
+pprCmms :: (Outputable info, Outputable g) => [GenCmm CmmStatic info g] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ ptext SLIT("-------------------") $$ space
-----------------------------------------------------------------------------
-instance (Outputable info) => Outputable (GenCmm CmmStatic info (ListGraph CmmStmt)) where
+instance (Outputable info, Outputable g)
+ => Outputable (GenCmm CmmStatic info g) where
ppr c = pprCmm c
instance (Outputable d, Outputable info, Outputable i)
=> Outputable (GenCmmTop d info i) where
ppr t = pprTop t
-instance Outputable i => Outputable (ListGraph i) where
+instance (Outputable instr) => Outputable (ListGraph instr) where
ppr (ListGraph blocks) = vcat (map ppr blocks)
instance (Outputable instr) => Outputable (GenBasicBlock instr) where
ppr b = pprBBlock b
-instance Outputable BlockId where
- ppr id = pprBlockId id
-
instance Outputable CmmStmt where
ppr s = pprStmt s
-----------------------------------------------------------------------------
-pprCmm :: (Outputable info) => GenCmm CmmStatic info (ListGraph CmmStmt) -> SDoc
+pprCmm :: (Outputable info, Outputable g) => GenCmm CmmStatic info g -> SDoc
pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-- --------------------------------------------------------------------------
-- Top level `procedure' blocks.
--
-pprTop :: (Outputable d, Outputable info, Outputable g)
- => GenCmmTop d info g -> SDoc
+pprTop :: (Outputable d, Outputable info, Outputable i)
+ => GenCmmTop d info i -> SDoc
-pprTop (CmmProc info lbl params graph)
+pprTop (CmmProc info lbl params graph )
= vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
, nest 8 $ lbrace <+> ppr info $$ rbrace
then empty
else parens (commafy $ map ppr results) <>
ptext SLIT(" = "),
- ptext SLIT("call"), space,
+ ptext SLIT("foreign"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
brackets (ppr safety),
Text -> section <+> doubleQuotes (ptext SLIT("text"))
Data -> section <+> doubleQuotes (ptext SLIT("data"))
ReadOnlyData -> section <+> doubleQuotes (ptext SLIT("readonly"))
+ ReadOnlyData16 -> section <+> doubleQuotes (ptext SLIT("readonly16"))
RelocatableReadOnlyData
-> section <+> doubleQuotes (ptext SLIT("relreadonly"))
UninitialisedData -> section <+> doubleQuotes (ptext SLIT("uninitialised"))
-- datatype closure table (for enumeration types)
-- to (say) PrelBase_$wTrue_closure, which is defined in code_stuff
-- Note that the closure pointers are tagged.
+
+ -- XXX comment says to put table after constructor decls, but
+ -- code appears to put it before --- NR 16 Aug 2007
; extra <-
if isEnumerationTyCon tycon then do
tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel
import VarEnv
import OrdList
import Unique
-import Util
+import Util()
import UniqSupply
-import FastString
+import FastString()
import Outputable
import Control.Monad
where (block,blocks) = flatten stmts
(CgFork fork_id stmts : ss) ->
flatten (CgFork fork_id stmts : CgStmt stmt : ss)
+ (CgStmt {} : _) -> panic "CgStmt not seen as ordinary"
flatten (s:ss) =
case s of
labelC id = emitCgStmt (CgLabel id)
newLabelC :: FCode BlockId
-newLabelC = do { id <- newUnique; return (BlockId id) }
+newLabelC = do { us <- newUniqSupply
+ ; return $ initUs_ us (freshBlockId "LabelC") }
checkedAbsC :: CmmStmt -> Code
-- Emit code, eliminating no-ops
getCmm :: Code -> FCode Cmm
-- Get all the CmmTops (there should be no stmts)
+-- Return a single Cmm which may be split from other Cmms by
+-- object splitting (at a later stage)
getCmm code
= do { state1 <- getState
; ((), state2) <- withState code (state1 { cgs_tops = nilOL })
import CgTicky
import ClosureInfo
import SMRep
-import MachOp
import Cmm
import CmmUtils
import CLabel
where
--cond1 tag = cmmULtWord tag lowCons
-- More efficient than the above?
+{-
tag_expr = cmmGetClosureType (CmmReg nodeReg)
cond1 tag = cmmEqWord tag (CmmLit (mkIntCLit 0))
cond2 tag = cmmUGtWord tag highCons
-- CONSTR
highCons = CmmLit (mkIntCLit 8)
-- CONSTR_NOCAF_STATIC (from ClosureType.h)
+-}
-untagCmmAssign (CmmAssign r cmmExpr) = CmmAssign r (cmmUntag cmmExpr)
-untagCmmAssign stmt = stmt
-
directCall sp lbl args extra_args assts = do
let
-- First chunk of args go in registers
; setRealHp vHp
}
\end{code}
+
+Some things are unused.
+\begin{code}
+_unused :: FS.FastString
+_unused = undefined
+\end{code}
-> HpcInfo
-> IO [Cmm] -- Output
+ -- N.B. returning '[Cmm]' and not 'Cmm' here makes it
+ -- possible for object splitting to split up the
+ -- pieces later.
+
codeGen dflags this_mod data_tycons imported_mods
cost_centre_info stg_binds hpc_info
= do
import Util ( split )
#endif
-import Data.Char ( isUpper, toLower )
+import Data.Char ( isUpper )
import System.IO ( hPutStrLn, stderr )
-- -----------------------------------------------------------------------------
-- debugging flags
= Opt_D_dump_cmm
+ | Opt_D_dump_cmmz
| Opt_D_dump_cps_cmm
+ | Opt_D_dump_cvt_cmm
| Opt_D_dump_asm
| Opt_D_dump_asm_native
| Opt_D_dump_asm_liveness
+ | Opt_D_dump_asm_coalesce
| Opt_D_dump_asm_regalloc
| Opt_D_dump_asm_regalloc_stages
| Opt_D_dump_asm_conflicts
| Opt_BreakOnException
| Opt_GenManifest
| Opt_EmbedManifest
+ | Opt_RunCPSZ
+ | Opt_ConvertToZipCfgAndBack
-- keeping stuff
| Opt_KeepHiDiffs
, ( "dstg-stats", NoArg (setDynFlag Opt_StgStats))
, ( "ddump-cmm", setDumpFlag Opt_D_dump_cmm)
+ , ( "ddump-cmmz", setDumpFlag Opt_D_dump_cmmz)
, ( "ddump-cps-cmm", setDumpFlag Opt_D_dump_cps_cmm)
+ , ( "ddump-cvt-cmm", setDumpFlag Opt_D_dump_cvt_cmm)
, ( "ddump-asm", setDumpFlag Opt_D_dump_asm)
, ( "ddump-asm-native", setDumpFlag Opt_D_dump_asm_native)
, ( "ddump-asm-liveness", setDumpFlag Opt_D_dump_asm_liveness)
- , ( "ddump-asm-conflicts", setDumpFlag Opt_D_dump_asm_conflicts)
+ , ( "ddump-asm-coalesce", setDumpFlag Opt_D_dump_asm_coalesce)
, ( "ddump-asm-regalloc", setDumpFlag Opt_D_dump_asm_regalloc)
+ , ( "ddump-asm-conflicts", setDumpFlag Opt_D_dump_asm_conflicts)
, ( "ddump-asm-regalloc-stages",
setDumpFlag Opt_D_dump_asm_regalloc_stages)
, ( "ddump-asm-stats", setDumpFlag Opt_D_dump_asm_stats)
( "hpc-no-auto", Opt_Hpc_No_Auto ),
( "rewrite-rules", Opt_RewriteRules ),
( "break-on-exception", Opt_BreakOnException ),
+ ( "run-cps", Opt_RunCPSZ ),
+ ( "convert-to-zipper-and-back", Opt_ConvertToZipCfgAndBack),
( "vectorise", Opt_Vectorise ),
( "regs-graph", Opt_RegsGraph),
-- Deprecated in favour of -XTemplateHaskell:
\section[GHC_Main]{Main driver for Glasgow Haskell compiler}
\begin{code}
-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module HscMain
( newHscEnv, hscCmmFile
, hscFileCheck
import CodeOutput ( outputForeignStubs )
import ByteCodeGen ( byteCodeGen, coreExprToBCOs )
import Linker ( HValue, linkExpr )
-import CoreSyn ( CoreExpr )
import CoreTidy ( tidyExpr )
import CorePrep ( corePrepExpr )
import Flattening ( flattenExpr )
#endif
import Var ( Id )
-import Module ( emptyModuleEnv, ModLocation(..) )
+import Module ( emptyModuleEnv, ModLocation(..), Module )
import RdrName ( GlobalRdrEnv, RdrName, emptyGlobalRdrEnv )
import HsSyn ( HsModule, LHsBinds, HsGroup, LIE, LImportDecl, HsDoc,
HaddockModInfo )
import PrelInfo ( wiredInThings, basicKnownKeyNames )
import MkIface ( checkOldIface, mkIface, writeIfaceFile )
import Desugar ( deSugar )
-import Flattening ( flatten )
import SimplCore ( core2core )
import TidyPgm ( tidyProgram, mkBootModDetails )
import CorePrep ( corePrepPgm )
import CoreToStg ( coreToStg )
+import StgSyn
+import CostCentre
import TyCon ( isDataTyCon )
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
+import Cmm ( Cmm )
import CmmParse ( parseCmmFile )
import CmmCPS
+import CmmCPSZ
import CmmInfo
+import CmmCvt
+import CmmTx
+import CmmContFlowOpt
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
import ParserCoreUtils
import FastString
import UniqFM ( emptyUFM )
+import UniqSupply ( initUs_ )
import Bag ( unitBag )
import Control.Monad
--------------------------------------------------------------
norecompOneShot :: NoRecomp HscStatus
-norecompOneShot old_iface
+norecompOneShot _old_iface
= do hsc_env <- gets compHscEnv
liftIO $ do
dumpIfaceStats hsc_env
norecompInteractive = norecompWorker InteractiveNoRecomp True
norecompWorker :: a -> Bool -> NoRecomp (a, ModIface, ModDetails)
-norecompWorker a isInterp old_iface
+norecompWorker a _isInterp old_iface
= do hsc_env <- gets compHscEnv
- mod_summary <- gets compModSummary
+ _mod_summary <- gets compModSummary
liftIO $ do
new_details <- {-# SCC "tcRnIface" #-}
initIfaceCheck hsc_env $
hscSimpleIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, ModGuts)
hscSimpleIface ds_result
= do hsc_env <- gets compHscEnv
- mod_summary <- gets compModSummary
+ _mod_summary <- gets compModSummary
maybe_old_iface <- gets compOldIface
liftIO $ do
details <- mkBootModDetails hsc_env ds_result
hscNormalIface :: ModGuts -> Comp (ModIface, Bool, ModDetails, CgGuts)
hscNormalIface simpl_result
= do hsc_env <- gets compHscEnv
- mod_summary <- gets compModSummary
+ _mod_summary <- gets compModSummary
maybe_old_iface <- gets compOldIface
liftIO $ do
-------------------
return (iface, details, a)
hscIgnoreIface :: (ModIface, Bool, ModDetails, a) -> Comp (ModIface, ModDetails, a)
-hscIgnoreIface (iface, no_change, details, a)
+hscIgnoreIface (iface, _no_change, details, a)
= return (iface, details, a)
-- Don't output any code.
hscNothing :: (ModIface, ModDetails, a) -> Comp (HscStatus, ModIface, ModDetails)
-hscNothing (iface, details, a)
+hscNothing (iface, details, _)
= return (HscRecomp False, iface, details)
-- Generate code and return both the new ModIface and the ModDetails.
<- {-# SCC "CoreToStg" #-}
myCoreToStg dflags this_mod prepd_binds
------------------ Code generation ------------------
- abstractC <- {-# SCC "CodeGen" #-}
+ cmms <- {-# SCC "CodeGen" #-}
codeGen dflags this_mod data_tycons
dir_imps cost_centre_info
stg_binds hpc_info
- ------------------ Convert to CPS --------------------
- --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
- continuationC <- cmmToRawCmm abstractC
+ -------- Optionally convert to and from zipper ------
+ cmms <-
+ if dopt Opt_ConvertToZipCfgAndBack dflags
+ then mapM (testCmmConversion dflags) cmms
+ else return cmms
+ ------------ Optionally convert to CPS --------------
+ cmms <-
+ if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
+ dopt Opt_RunCPSZ dflags
+ then cmmCPS dflags cmms
+ else return cmms
------------------ Code output -----------------------
- (stub_h_exists,stub_c_exists)
+ rawcmms <- cmmToRawCmm cmms
+ (_stub_h_exists, stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
- dependencies continuationC
+ dependencies rawcmms
return stub_c_exists
-hscConst :: b -> a -> Comp b
-hscConst b a = return b
-
hscInteractive :: (ModIface, ModDetails, CgGuts)
-> Comp (InteractiveStatus, ModIface, ModDetails)
-hscInteractive (iface, details, cgguts)
#ifdef GHCI
+hscInteractive (iface, details, cgguts)
= do hsc_env <- gets compHscEnv
mod_summary <- gets compModSummary
liftIO $ do
----------------- Generate byte code ------------------
comp_bc <- byteCodeGen dflags prepd_binds data_tycons mod_breaks
------------------ Create f-x-dynamic C-side stuff ---
- (istub_h_exists, istub_c_exists)
+ (_istub_h_exists, istub_c_exists)
<- outputForeignStubs dflags this_mod location foreign_stubs
return (InteractiveRecomp istub_c_exists comp_bc mod_breaks, iface, details)
#else
- = panic "GHC not compiled with interpreter"
+hscInteractive _ = panic "GHC not compiled with interpreter"
#endif
------------------------------
case maybe_cmm of
Nothing -> return False
Just cmm -> do
- --continuationC <- cmmCPS dflags [cmm] >>= cmmToRawCmm
+ cmm <- testCmmConversion dflags cmm
+ --continuationC <- cmmCPS dflags cmm >>= cmmToRawCmm
continuationC <- cmmToRawCmm [cmm]
codeOutput dflags no_mod no_loc NoStubs [] continuationC
return True
ml_hi_file = panic "hscCmmFile: no hi file",
ml_obj_file = panic "hscCmmFile: no obj file" }
+testCmmConversion :: DynFlags -> Cmm -> IO Cmm
+testCmmConversion dflags cmm =
+ do showPass dflags "CmmToCmm"
+ dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- pre-conversion" (ppr cmm)
+ --continuationC <- cmmCPS dflags abstractC >>= cmmToRawCmm
+ us <- mkSplitUniqSupply 'C'
+ let cfopts = runTx $ runCmmOpts cmmCfgOptsZ
+ let cvtm = do g <- cmmToZgraph cmm
+ return $ cfopts g
+ let zgraph = initUs_ us cvtm
+ cps_zgraph <- protoCmmCPSZ dflags zgraph
+ let chosen_graph = if dopt Opt_RunCPSZ dflags then cps_zgraph else zgraph
+ dumpIfSet_dyn dflags Opt_D_dump_cmmz "C-- Zipper Graph" (ppr chosen_graph)
+ showPass dflags "Convert from Z back to Cmm"
+ let cvt = cmmOfZgraph $ cfopts $ chosen_graph
+ dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
+ return cvt
+ -- return cmm -- don't use the conversion
myParseModule :: DynFlags -> FilePath -> Maybe StringBuffer
-> IO (Either ErrMsg (Located (HsModule RdrName)))
}}
+myCoreToStg :: DynFlags -> Module -> [CoreBind]
+ -> IO ( [(StgBinding,[(Id,[Id])])] -- output program
+ , CollectedCCs) -- cost centre info (declared and used)
+
myCoreToStg dflags this_mod prepd_binds
= do
stg_binds <- {-# SCC "Core2Stg" #-}
Nothing -> return Nothing ; -- Parse error
Just (Just (L _ (ExprStmt expr _ _)))
-> tcRnExpr hsc_env icontext expr ;
- Just other -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
+ Just _ -> do { errorMsg (hsc_dflags hsc_env) (text "not an expression:" <+> quotes (text expr)) ;
return Nothing } ;
} }
%************************************************************************
\begin{code}
+showModuleIndex :: Maybe (Int, Int) -> String
showModuleIndex Nothing = ""
showModuleIndex (Just (i,n)) = "[" ++ padded ++ " of " ++ n_str ++ "] "
where
import Cmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
-import PprCmm ( pprStmt, pprCmms, pprCmm )
+import PprCmm
import MachOp
import CLabel
import State
import UniqFM
import Unique ( Unique, getUnique )
import UniqSupply
-import FastTypes
import List ( groupBy, sortBy )
-import ErrUtils ( dumpIfSet_dyn )
import DynFlags
+#if powerpc_TARGET_ARCH
import StaticFlags ( opt_Static, opt_PIC )
+#endif
import Util
import Config ( cProjectVersion )
import Module
-- output the block, then if it has an out edge, we move the
-- destination of the out edge to the front of the list, and continue.
+-- FYI, the classic layout for basic blocks uses postorder DFS; this
+-- algorithm is implemented in cmm/ZipCfg.hs (NR 6 Sep 2007).
+
sequenceBlocks :: [NatBasicBlock] -> [NatBasicBlock]
sequenceBlocks [] = []
sequenceBlocks (entry:blocks) =
pprNatCmmTop (CmmProc info lbl params (ListGraph blocks)) =
pprSectionHeader Text $$
- (if not (null info)
- then
+ (if null info then -- blocks guaranteed not null, so label needed
+ pprLabel lbl
+ else
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
pprCLabel_asm (mkDeadStripPreventer $ entryLblToInfoLbl lbl)
<> char ':' $$
#endif
- vcat (map pprData info) $$
- pprLabel (entryLblToInfoLbl lbl)
- else empty) $$
- (case blocks of
- [] -> empty
- (BasicBlock _ instrs : rest) ->
- (if null info then pprLabel lbl else empty) $$
- -- the first block doesn't get a label:
- vcat (map pprInstr instrs) $$
- vcat (map pprBasicBlock rest)
- )
+ vcat (map pprData info) $$
+ pprLabel (entryLblToInfoLbl lbl)
+ ) $$
+ vcat (map pprBasicBlock blocks)
+ -- ^ Even the first block gets a label, because with branch-chain
+ -- elimination, it might be the target of a goto.
#if HAVE_SUBSECTIONS_VIA_SYMBOLS
-- If we are using the .subsections_via_symbols directive
-- (available on recent versions of Darwin),
projects / ghc-hetmet.git / commitdiff