Commit 16a2f6a8 authored by nr@eecs.harvard.edu's avatar nr@eecs.harvard.edu

massive changes to add a 'zipper' representation of C--

Changes too numerous to comment on, but here is some old history that
I saved: 


Wed Aug 15 11:07:13 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * type synonyms made consistent with new Cmm types

    M ./compiler/nativeGen/MachInstrs.hs -2 +2

Mon Aug 20 19:22:14 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * pushing return info beyond cmm into codegen

    M ./compiler/codeGen/Bitmap.hs r3
    M ./compiler/codeGen/CgBindery.lhs r3
    M ./compiler/codeGen/CgCallConv.hs r3
    M ./compiler/codeGen/CgCase.lhs r3
    M ./compiler/codeGen/CgClosure.lhs r3
    M ./compiler/codeGen/CgCon.lhs r3
    M ./compiler/codeGen/CgExpr.lhs r3
    M ./compiler/codeGen/CgForeignCall.hs -6 +7 r3
    M ./compiler/codeGen/CgHeapery.lhs r3
    M ./compiler/codeGen/CgHpc.hs +1 r3
    M ./compiler/codeGen/CgInfoTbls.hs r3
    M ./compiler/codeGen/CgLetNoEscape.lhs r3
    M ./compiler/codeGen/CgMonad.lhs r3
    M ./compiler/codeGen/CgParallel.hs r3
    M ./compiler/codeGen/CgPrimOp.hs +3 r3
    M ./compiler/codeGen/CgProf.hs r3
    M ./compiler/codeGen/CgStackery.lhs r3
    M ./compiler/codeGen/CgTailCall.lhs r3
    M ./compiler/codeGen/CgTicky.hs r3
    M ./compiler/codeGen/CgUtils.hs -1 +1 r3
    M ./compiler/codeGen/ClosureInfo.lhs r3
    M ./compiler/codeGen/CodeGen.lhs r3
    M ./compiler/codeGen/SMRep.lhs r3
    M ./compiler/nativeGen/AsmCodeGen.lhs -2 +2 r1
    M ./compiler/nativeGen/MachCodeGen.hs -3 +3 r1
    M ./compiler/nativeGen/MachInstrs.hs r1
    M ./compiler/nativeGen/MachRegs.lhs r1
    M ./compiler/nativeGen/NCGMonad.hs r1
    M ./compiler/nativeGen/PositionIndependentCode.hs r1
    M ./compiler/nativeGen/PprMach.hs r1
    M ./compiler/nativeGen/RegAllocInfo.hs r1
    M ./compiler/nativeGen/RegisterAlloc.hs r1

Mon Aug 20 20:54:41 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * put CmmReturnInfo into a CmmCall (and related types)

    M ./compiler/cmm/Cmm.hs -2 +1 r3
    M ./compiler/cmm/CmmBrokenBlock.hs -13 +12 r1
    M ./compiler/cmm/CmmCPS.hs -3 +3
    M ./compiler/cmm/CmmCPSGen.hs -8 +6 r1
    M ./compiler/cmm/CmmLint.hs -1 +1
    M ./compiler/cmm/CmmLive.hs -1 +1
    M ./compiler/cmm/CmmOpt.hs -3 +3
    M ./compiler/cmm/CmmParse.y -6 +6 r3
    M ./compiler/cmm/PprC.hs -3 +3
    M ./compiler/cmm/PprCmm.hs -7 +4 r2
    M ./compiler/codeGen/CgForeignCall.hs -7 +6 r2
    M ./compiler/codeGen/CgHpc.hs -1 r1
    M ./compiler/codeGen/CgPrimOp.hs -3 r1
    M ./compiler/codeGen/CgUtils.hs -1 +1 r1
    M ./compiler/nativeGen/AsmCodeGen.lhs -2 +2
    M ./compiler/nativeGen/MachCodeGen.hs -3 +3 r1

Tue Aug 21 18:09:13 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * add call info in nativeGen

    M ./compiler/nativeGen/AsmCodeGen.lhs r1
    M ./compiler/nativeGen/MachInstrs.hs r1
    M ./compiler/nativeGen/MachRegs.lhs r1
    M ./compiler/nativeGen/NCGMonad.hs r1
    M ./compiler/nativeGen/PositionIndependentCode.hs r1
    M ./compiler/nativeGen/PprMach.hs r1
    M ./compiler/nativeGen/RegAllocInfo.hs r1

Wed Aug 22 16:41:58 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * ListGraph is now a newtype, not a synonym
  The resultant bookkeepping is unenviable, but the change
  greatly simplifies our ability to make Cmm things propertly
  Outputable for both list-graph and zipper-graph representations.

    M ./compiler/cmm/Cmm.hs -5 +3
    M ./compiler/cmm/CmmCPS.hs -2 +2
    M ./compiler/cmm/CmmCPSGen.hs -1 +1
    M ./compiler/cmm/CmmContFlowOpt.hs -3 +3
    M ./compiler/cmm/CmmCvt.hs -2 +2
    M ./compiler/cmm/CmmInfo.hs -2 +3
    M ./compiler/cmm/CmmLint.hs -1 +1
    M ./compiler/cmm/CmmOpt.hs -2 +2
    M ./compiler/cmm/PprC.hs -1 +1
    M ./compiler/cmm/PprCmm.hs -5 +8
    M ./compiler/cmm/PprCmmZ.hs -7 +1
    M ./compiler/codeGen/CgMonad.lhs -1 +1
    M ./compiler/nativeGen/AsmCodeGen.lhs -15 +15
    M ./compiler/nativeGen/MachCodeGen.hs -2 +2
    M ./compiler/nativeGen/PositionIndependentCode.hs -6 +6
    M ./compiler/nativeGen/PprMach.hs -3 +2
    M ./compiler/nativeGen/RegAllocColor.hs +1
    M ./compiler/nativeGen/RegAllocLinear.hs -4 +5
    M ./compiler/nativeGen/RegCoalesce.hs -6 +6
    M ./compiler/nativeGen/RegLiveness.hs -12 +12

Thu Aug 23 13:44:49 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * diagnostic assistance in case fromJust fails

    M ./compiler/nativeGen/MachCodeGen.hs -2 +5

Thu Aug 23 14:07:28 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * give every block, even the first, a label
    With branch-chain elimination, the first block of a procedure
    might be the target of a branch.  This actually happens to 
    a dozen or more procedures in the run-time system.

    M ./compiler/nativeGen/PprMach.hs -8 +3

Fri Aug 24 17:27:04 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * clean up the code in PprMach

    M ./compiler/nativeGen/PprMach.hs -16 +14

Fri Aug 24 19:35:03 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * a bunch of impedance matching to get the compiler to build, plus 
   * the plus is diagnostics for unreachable code, which required
     moving a lot of prettyprinting code

    M ./compiler/cmm/Cmm.hs -7 +5
    M ./compiler/cmm/CmmCPSZ.hs -1 +1
    M ./compiler/cmm/CmmCvt.hs -8 +8
    M ./compiler/cmm/CmmParse.y -4 +3
    M ./compiler/cmm/MkZipCfg.hs -19 +9
    M ./compiler/cmm/PprCmmZ.hs -118 +4
    M ./compiler/cmm/ZipCfg.hs -1 +13
    M ./compiler/cmm/ZipCfgCmm.hs -10 +129
    M ./compiler/main/HscMain.lhs -4 +4
    M ./compiler/nativeGen/NCGMonad.hs -2 +2
    M ./compiler/nativeGen/RegAllocInfo.hs -3 +3

Fri Aug 31 14:38:02 BST 2007  Norman Ramsey <nr@eecs.harvard.edu>
  * fix a warning about an import

    M ./compiler/nativeGen/RegAllocColor.hs -1 +1
parent 5fccc856
......@@ -325,7 +325,8 @@ mkAltLabel uniq tag = CaseLabel uniq (CaseAlt tag)
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
......@@ -6,41 +7,66 @@
--
-----------------------------------------------------------------------------
{-# 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
-----------------------------------------------------------------------------
......@@ -58,6 +84,8 @@ import Data.Word
-- (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
......@@ -101,6 +129,9 @@ type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt)
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
......@@ -109,8 +140,26 @@ blockId (BasicBlock blk_id _ ) = blk_id
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
......@@ -212,6 +261,28 @@ type CmmHintFormals = [(CmmFormal,MachHint)]
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
~~~~~~~~~~
......@@ -220,6 +291,10 @@ One possible problem with the above type is that the only way to do a
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 =
......@@ -264,104 +339,6 @@ data CmmCallTarget
CallishMachOp -- These might be implemented as inline
-- 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
-----------------------------------------------------------------------------
......@@ -387,69 +364,3 @@ data CmmStatic
| 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
......@@ -2,7 +2,7 @@
-- 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 (
......
......@@ -14,7 +14,6 @@ module CmmInfo (
import Cmm
import CmmUtils
import PprCmm
import CLabel
import MachOp
......@@ -28,7 +27,6 @@ import SMRep
import Constants
import StaticFlags
import DynFlags
import Unique
import UniqSupply
import Panic
......@@ -78,10 +76,10 @@ cmmToRawCmm cmm = do
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
......@@ -153,21 +151,21 @@ mkInfoTableAndCode :: CLabel
-> [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
......@@ -277,3 +275,7 @@ mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
| otherwise = []
type_lit = packHalfWordsCLit cl_type srt_len
_unused :: FS.FastString -- stops a warning
_unused = undefined
......@@ -22,6 +22,7 @@ module CmmLint (
import Cmm
import CLabel
import MachOp
import Maybe
import Outputable
import PprCmm
import Unique
......@@ -44,15 +45,18 @@ runCmmLint l =
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
......@@ -85,13 +89,13 @@ lintCmmExpr expr =
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
......@@ -119,25 +123,38 @@ cmmCheckWordAddress _
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
......
......@@ -22,6 +22,7 @@ module CmmOpt (
#include "HsVersions.h"
import Cmm
import CmmExpr
import CmmUtils
import CLabel
import MachOp
......@@ -52,6 +53,10 @@ once. It works as follows:
- 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:
......@@ -85,17 +90,14 @@ To inline _smi:
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 [] = []
......@@ -117,7 +119,7 @@ cmmMiniInlineStmts uses (stmt:stmts)
-- 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
......@@ -126,8 +128,10 @@ lookForInline u expr (stmt@(CmmAssign (CmmLocal (LocalReg u' _ _)) rhs) : rest)
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
......@@ -140,30 +144,6 @@ lookForInline u expr (stmt:stmts)
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)
......@@ -391,15 +371,15 @@ cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 0 _))]
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))]
......@@ -409,10 +389,10 @@ cmmMachOpFold mop args@[x, y@(CmmLit (CmmInt 1 rep))]
MO_U_Quot r -> x
MO_S_Rem r -> CmmLit (CmmInt 0 rep)