+{- BlockId module should probably go away completely, being superseded by Label -}
module BlockId
- ( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
- , BlockEnv, emptyBlockEnv, elemBlockEnv, lookupBlockEnv, extendBlockEnv
- , mkBlockEnv, mapBlockEnv
- , eltsBlockEnv, plusBlockEnv, delFromBlockEnv, blockEnvToList, lookupWithDefaultBEnv
- , isNullBEnv, sizeBEnv, foldBlockEnv, foldBlockEnv', addToBEnv_Acc
- , BlockSet, emptyBlockSet, unitBlockSet, isEmptyBlockSet
- , elemBlockSet, extendBlockSet, sizeBlockSet, unionBlockSets
- , removeBlockSet, mkBlockSet, blockSetToList, foldBlockSet
+ ( BlockId, mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet
+ , BlockSet, BlockEnv
+ , IsSet(..), setInsertList, setDeleteList, setUnions
+ , IsMap(..), mapInsertList, mapDeleteList, mapUnions
+ , emptyBlockSet, emptyBlockMap
, blockLbl, infoTblLbl, retPtLbl
) where
import CLabel
import IdInfo
-import Maybes
import Name
import Outputable
-import UniqFM
import Unique
-import UniqSet
+
+import Compiler.Hoopl hiding (Unique)
+import Compiler.Hoopl.GHC (uniqueToInt, uniqueToLbl, lblToUnique)
----------------------------------------------------------------
--- Block Ids, their environments, and their sets
compilation unit in which it appears.
-}
-data BlockId = BlockId Unique
- deriving (Eq,Ord)
+type BlockId = Label
instance Uniquable BlockId where
- getUnique (BlockId id) = id
+ getUnique label = getUnique (uniqueToInt $ lblToUnique label)
mkBlockId :: Unique -> BlockId
-mkBlockId uniq = BlockId uniq
-
-instance Show BlockId where
- show (BlockId u) = show u
+mkBlockId unique = uniqueToLbl $ intToUnique $ getKey unique
instance Outputable BlockId where
- ppr (BlockId id) = ppr id
+ ppr label = ppr (getUnique label)
retPtLbl :: BlockId -> CLabel
-retPtLbl (BlockId id) = mkReturnPtLabel id
+retPtLbl label = mkReturnPtLabel $ getUnique label
blockLbl :: BlockId -> CLabel
-blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs
+blockLbl label = mkEntryLabel (mkFCallName (getUnique label) "block") NoCafRefs
infoTblLbl :: BlockId -> CLabel
-infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs
+infoTblLbl label = mkInfoTableLabel (mkFCallName (getUnique label) "block") NoCafRefs
-- Block environments: Id blocks
-newtype BlockEnv a = BlockEnv (UniqFM {- id -} a)
+type BlockEnv a = LabelMap a
instance Outputable a => Outputable (BlockEnv a) where
- ppr (BlockEnv env) = ppr env
-
--- This is pretty horrid. There must be common patterns here that can be
--- abstracted into wrappers.
-emptyBlockEnv :: BlockEnv a
-emptyBlockEnv = BlockEnv emptyUFM
-
-isNullBEnv :: BlockEnv a -> Bool
-isNullBEnv (BlockEnv env) = isNullUFM env
-
-sizeBEnv :: BlockEnv a -> Int
-sizeBEnv (BlockEnv env) = sizeUFM env
-
-mkBlockEnv :: [(BlockId,a)] -> BlockEnv a
-mkBlockEnv = foldl (uncurry . extendBlockEnv) emptyBlockEnv
-
-eltsBlockEnv :: BlockEnv elt -> [elt]
-eltsBlockEnv (BlockEnv env) = eltsUFM env
-
-delFromBlockEnv :: BlockEnv elt -> BlockId -> BlockEnv elt
-delFromBlockEnv (BlockEnv env) (BlockId id) = BlockEnv (delFromUFM env id)
-
-lookupBlockEnv :: BlockEnv a -> BlockId -> Maybe a
-lookupBlockEnv (BlockEnv env) (BlockId id) = lookupUFM env id
-
-elemBlockEnv :: BlockEnv a -> BlockId -> Bool
-elemBlockEnv (BlockEnv env) (BlockId id) = isJust $ lookupUFM env id
-
-lookupWithDefaultBEnv :: BlockEnv a -> a -> BlockId -> a
-lookupWithDefaultBEnv env x id = lookupBlockEnv env id `orElse` x
-
-extendBlockEnv :: BlockEnv a -> BlockId -> a -> BlockEnv a
-extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x)
-
-mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b
-mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env)
-
-foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv f b (BlockEnv env) =
- foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env
+ ppr = ppr . mapToList
-foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b
-foldBlockEnv' f b (BlockEnv env) = foldUFM f b env
+emptyBlockMap :: BlockEnv a
+emptyBlockMap = mapEmpty
-plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt
-plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y)
+-- Block sets
+type BlockSet = LabelSet
-blockEnvToList :: BlockEnv elt -> [(BlockId, elt)]
-blockEnvToList (BlockEnv env) =
- map (\ (id, elt) -> (BlockId id, elt)) $ ufmToList env
-
-addToBEnv_Acc :: (elt -> elts -> elts) -- Add to existing
- -> (elt -> elts) -- New element
- -> BlockEnv elts -- old
- -> BlockId -> elt -- new
- -> BlockEnv elts -- result
-addToBEnv_Acc add new (BlockEnv old) (BlockId k) v =
- BlockEnv (addToUFM_Acc add new old k v)
- -- I believe this is only used by obsolete code.
-
-
-newtype BlockSet = BlockSet (UniqSet Unique)
instance Outputable BlockSet where
- ppr (BlockSet set) = ppr set
-
+ ppr = ppr . setElems
emptyBlockSet :: BlockSet
-emptyBlockSet = BlockSet emptyUniqSet
-
-isEmptyBlockSet :: BlockSet -> Bool
-isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s
-
-unitBlockSet :: BlockId -> BlockSet
-unitBlockSet = extendBlockSet emptyBlockSet
-
-elemBlockSet :: BlockId -> BlockSet -> Bool
-elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set
-
-extendBlockSet :: BlockSet -> BlockId -> BlockSet
-extendBlockSet (BlockSet set) (BlockId id) = BlockSet (addOneToUniqSet set id)
-
-removeBlockSet :: BlockSet -> BlockId -> BlockSet
-removeBlockSet (BlockSet set) (BlockId id) = BlockSet (delOneFromUniqSet set id)
-
-mkBlockSet :: [BlockId] -> BlockSet
-mkBlockSet = foldl extendBlockSet emptyBlockSet
-
-unionBlockSets :: BlockSet -> BlockSet -> BlockSet
-unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s')
-
-sizeBlockSet :: BlockSet -> Int
-sizeBlockSet (BlockSet set) = sizeUniqSet set
-
-blockSetToList :: BlockSet -> [BlockId]
-blockSetToList (BlockSet set) = map BlockId $ uniqSetToList set
-
-foldBlockSet :: (BlockId -> b -> b) -> b -> BlockSet -> b
-foldBlockSet f z (BlockSet set) = foldUniqSet (f . BlockId) z set
+emptyBlockSet = setEmpty
------------------------------------------------------------------------------
---
--- Cmm data types
---
--- (c) The University of Glasgow 2004-2006
---
------------------------------------------------------------------------------
-
-module Cmm (
- GenCmm(..), Cmm, RawCmm,
- GenCmmTop(..), CmmTop, RawCmmTop,
- ListGraph(..),
- cmmMapGraph, cmmTopMapGraph,
- cmmMapGraphM, cmmTopMapGraphM,
- CmmInfo(..), UpdateFrame(..),
- CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
- ProfilingInfo(..), ClosureTypeTag,
- GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
- CmmReturnInfo(..),
- CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals,
- HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals,
- CmmSafety(..),
- CmmCallTarget(..), CallishMachOp(..), pprCallishMachOp,
- ForeignHint(..), CmmHinted(..),
- CmmStatic(..), Section(..),
- module CmmExpr,
- ) where
-
-#include "HsVersions.h"
+-- Cmm representations using Hoopl's Graph CmmNode e x.
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+
+module Cmm
+ ( CmmGraph(..), CmmBlock
+ , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop
+ , CmmReplGraph, CmmFwdRewrite, CmmBwdRewrite
+
+ , lastNode, replaceLastNode, insertBetween
+ , ofBlockMap, toBlockMap, insertBlock
+ , ofBlockList, toBlockList, bodyToBlockList
+ , foldGraphBlocks, mapGraphNodes, postorderDfs
+
+ , analFwd, analBwd, analRewFwd, analRewBwd
+ , dataflowPassFwd, dataflowPassBwd
+ , module CmmNode
+ )
+where
import BlockId
-import CmmExpr
-import CLabel
-import ForeignCall
+import CmmDecl
+import CmmNode
+import OptimizationFuel as F
import SMRep
+import UniqSupply
-import ClosureInfo
-import Outputable
-import FastString
-
-import Data.Word
-
-
--- 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
------------------------------------------------------------------------------
-
--- A file is a list of top-level chunks. These may be arbitrarily
--- re-orderd during code generation.
-
--- GenCmm is abstracted over
--- d, the type of static data elements in CmmData
--- h, the static info preceding the code of a CmmProc
--- g, the control-flow graph of a CmmProc
---
--- We expect there to be two main instances of this type:
--- (a) C--, i.e. populated with various C-- constructs
--- (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
--- the basic blocks (Cmm or instructions are the likely instantiations).
-data GenCmmTop d h g
- = CmmProc -- A procedure
- h -- Extra header such as the info table
- CLabel -- Used to generate both info & entry labels
- CmmFormals -- Argument locals live on entry (C-- procedure params)
- -- XXX Odd that there are no kinds, but there you are ---NR
- g -- Control-flow graph for the procedure's code
-
- | CmmData -- Static data
- Section
- [d]
-
--- | A control-flow graph represented as a list of extended basic blocks.
-newtype ListGraph i = ListGraph [GenBasicBlock i]
- -- ^ Code, may be empty. The first block is the entry point. The
- -- order is otherwise initially unimportant, but at some point the
- -- code gen will fix the order.
-
- -- BlockIds must be unique across an entire compilation unit, since
- -- they are translated to assembly-language labels, which scope
- -- across a whole compilation unit.
-
--- | Cmm with the info table as a data type
-type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt)
-type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt)
-
--- | Cmm with the info tables converted to a list of 'CmmStatic'
-type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt)
-type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt)
-
-
--- A basic block containing a single label, at the beginning.
--- The list of basic blocks in a top-level code block may be re-ordered.
--- Fall-through is not allowed: there must be an explicit jump at the
--- end of each basic block, but the code generator might rearrange basic
--- blocks in order to turn some jumps into fallthroughs.
-
-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
-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
------------------------------------------------------------------------------
-
-data CmmInfo
- = CmmInfo
- (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check
- -- JD: NOT USED BY NEW CODE GEN
- (Maybe UpdateFrame) -- Update frame
- CmmInfoTable -- Info table
-
--- Info table as a haskell data type
-data CmmInfoTable
- = CmmInfoTable
- HasStaticClosure
- ProfilingInfo
- ClosureTypeTag -- Int
- ClosureTypeInfo
- | CmmNonInfoTable -- Procedure doesn't need an info table
-
-type HasStaticClosure = Bool
-
--- TODO: The GC target shouldn't really be part of CmmInfo
--- as it doesn't appear in the resulting info table.
--- It should be factored out.
-
-data ClosureTypeInfo
- = ConstrInfo ClosureLayout ConstrTag ConstrDescription
- | FunInfo ClosureLayout C_SRT FunArity ArgDescr SlowEntry
- | ThunkInfo ClosureLayout C_SRT
- | ThunkSelectorInfo SelectorOffset C_SRT
- | ContInfo
- [Maybe LocalReg] -- Stack layout: Just x, an item x
- -- Nothing: a 1-word gap
- -- Start of list is the *young* end
- C_SRT
-
-data CmmReturnInfo = CmmMayReturn
- | CmmNeverReturns
- deriving ( Eq )
-
--- TODO: These types may need refinement
-data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
-type ClosureTypeTag = StgHalfWord
-type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
-type ConstrTag = StgHalfWord
-type ConstrDescription = CmmLit
-type FunArity = StgHalfWord
-type SlowEntry = CmmLit
- -- We would like this to be a CLabel but
- -- for now the parser sets this to zero on an INFO_TABLE_FUN.
-type SelectorOffset = StgWord
-
--- | A frame that is to be pushed before entry to the function.
--- Used to handle 'update' frames.
-data UpdateFrame =
- UpdateFrame
- CmmExpr -- Frame header. Behaves like the target of a 'jump'.
- [CmmExpr] -- Frame remainder. Behaves like the arguments of a 'jump'.
-
------------------------------------------------------------------------------
--- CmmStmt
--- A "statement". Note that all branches are explicit: there are no
--- control transfers to computed addresses, except when transfering
--- control to a new function.
------------------------------------------------------------------------------
-
-data CmmStmt -- Old-style
- = CmmNop
- | CmmComment FastString
-
- | CmmAssign CmmReg CmmExpr -- Assign to register
-
- | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
- -- given by cmmExprType of the rhs.
-
- | CmmCall -- A call (forign, native or primitive), with
- CmmCallTarget
- HintedCmmFormals -- zero or more results
- HintedCmmActuals -- zero or more arguments
- CmmSafety -- whether to build a continuation
- CmmReturnInfo
-
- | CmmBranch BlockId -- branch to another BB in this fn
-
- | CmmCondBranch CmmExpr BlockId -- conditional branch
-
- | CmmSwitch CmmExpr [Maybe BlockId] -- Table branch
- -- The scrutinee is zero-based;
- -- zero -> first block
- -- one -> second block etc
- -- Undefined outside range, and when there's a Nothing
-
- | CmmJump CmmExpr -- Jump to another C-- function,
- HintedCmmActuals -- with these parameters. (parameters never used)
-
- | CmmReturn -- Return from a native C-- function,
- HintedCmmActuals -- with these return values. (parameters never used)
-
-type CmmActual = CmmExpr
-type CmmFormal = LocalReg
-type CmmActuals = [CmmActual]
-type CmmFormals = [CmmFormal]
-
-data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint }
- deriving( Eq )
-
-type HintedCmmActuals = [HintedCmmActual]
-type HintedCmmFormals = [HintedCmmFormal]
-type HintedCmmFormal = CmmHinted CmmFormal
-type HintedCmmActual = CmmHinted CmmActual
-
-data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible
-
--- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
-instance UserOfLocalRegs CmmStmt where
- foldRegsUsed f (set::b) s = stmt s set
- where
- stmt :: CmmStmt -> b -> b
- 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 :: UserOfLocalRegs a => a -> b -> b
- gen a set = foldRegsUsed f set a
-
-instance UserOfLocalRegs CmmCallTarget where
- foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
- foldRegsUsed _ set (CmmPrim {}) = set
-
-instance UserOfSlots CmmCallTarget where
- foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e
- foldSlotsUsed _ set (CmmPrim {}) = set
-
-instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where
- foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a)
-
-instance UserOfSlots a => UserOfSlots (CmmHinted a) where
- foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a)
-
-instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where
- foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a)
-
-{-
-Discussion
-~~~~~~~~~~
-
-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 =
- ...
- | CmmJump CmmBranchDest
- | CmmCondJump CmmExpr CmmBranchDest
- ...
-
-data CmmBranchDest
- = Local BlockId
- | NonLocal CmmExpr [LocalReg]
-
-In favour:
-
-+ one fewer constructors in CmmStmt
-+ allows both cond branch and switch to jump to non-local destinations
-
-Against:
-
-- not strictly necessary: can already encode as branch+jump
-- not always possible to implement any better in the back end
-- could do the optimisation in the back end (but then plat-specific?)
-- C-- doesn't have it
-- back-end optimisation might be more general (jump shortcutting)
-
-So we'll stick with the way it is, and add the optimisation to the NCG.
--}
-
------------------------------------------------------------------------------
--- CmmCallTarget
---
--- The target of a CmmCall.
------------------------------------------------------------------------------
-
-data CmmCallTarget
- = CmmCallee -- Call a function (foreign or native)
- CmmExpr -- literal label <=> static call
- -- other expression <=> dynamic call
- CCallConv -- The calling convention
-
- | CmmPrim -- Call a "primitive" (eg. sin, cos)
- CallishMachOp -- These might be implemented as inline
- -- code by the backend.
- deriving Eq
-
-
-data ForeignHint
- = NoHint | AddrHint | SignedHint
- deriving( Eq )
- -- Used to give extra per-argument or per-result
- -- information needed by foreign calling conventions
-
-
--- CallishMachOps tend to be implemented by foreign calls in some backends,
--- so we separate them out. In Cmm, these can only occur in a
--- statement position, in contrast to an ordinary MachOp which can occur
--- anywhere in an expression.
-data CallishMachOp
- = MO_F64_Pwr
- | MO_F64_Sin
- | MO_F64_Cos
- | MO_F64_Tan
- | MO_F64_Sinh
- | MO_F64_Cosh
- | MO_F64_Tanh
- | MO_F64_Asin
- | MO_F64_Acos
- | MO_F64_Atan
- | MO_F64_Log
- | MO_F64_Exp
- | MO_F64_Sqrt
- | MO_F32_Pwr
- | MO_F32_Sin
- | MO_F32_Cos
- | MO_F32_Tan
- | MO_F32_Sinh
- | MO_F32_Cosh
- | MO_F32_Tanh
- | MO_F32_Asin
- | MO_F32_Acos
- | MO_F32_Atan
- | MO_F32_Log
- | MO_F32_Exp
- | MO_F32_Sqrt
- | MO_WriteBarrier
- | MO_Touch -- Keep variables live (when using interior pointers)
- deriving (Eq, Show)
-
-pprCallishMachOp :: CallishMachOp -> SDoc
-pprCallishMachOp mo = text (show mo)
-
------------------------------------------------------------------------------
--- Static Data
------------------------------------------------------------------------------
-
-data Section
- = Text
- | Data
- | ReadOnlyData
- | RelocatableReadOnlyData
- | UninitialisedData
- | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned
- | OtherSection String
-
-data CmmStatic
- = CmmStaticLit CmmLit
- -- a literal value, size given by cmmLitRep of the literal.
- | CmmUninitialised Int
- -- uninitialised data, N bytes long
- | CmmAlign Int
- -- align to next N-byte boundary (N must be a power of 2).
- | CmmDataLabel CLabel
- -- label the current position in this section.
- | CmmString [Word8]
- -- string of 8-bit values only, not zero terminated.
+import Compiler.Hoopl
+import Control.Monad
+import Data.Maybe
+import Panic
+
+#include "HsVersions.h"
+-------------------------------------------------
+-- CmmBlock, CmmGraph and Cmm
+
+data CmmGraph = CmmGraph { g_entry :: BlockId, g_graph :: Graph CmmNode C C }
+type CmmBlock = Block CmmNode C C
+
+type CmmReplGraph e x = FuelUniqSM (Maybe (Graph CmmNode e x))
+type CmmFwdRewrite f = FwdRewrite FuelUniqSM CmmNode f
+type CmmBwdRewrite f = BwdRewrite FuelUniqSM CmmNode f
+
+data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff}
+data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
+type Cmm = GenCmm CmmStatic CmmTopInfo CmmGraph
+type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph
+
+-------------------------------------------------
+-- Manipulating CmmGraphs
+
+toBlockMap :: CmmGraph -> LabelMap CmmBlock
+toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body
+--toBlockMap _ = panic "Cmm.toBlockMap"
+
+ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph
+ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO}
+
+insertBlock :: CmmBlock -> LabelMap CmmBlock -> LabelMap CmmBlock
+insertBlock block map =
+ ASSERT (isNothing $ mapLookup id map)
+ mapInsert id block map
+ where id = entryLabel block
+
+toBlockList :: CmmGraph -> [CmmBlock]
+toBlockList g = mapElems $ toBlockMap g
+
+ofBlockList :: BlockId -> [CmmBlock] -> CmmGraph
+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)
+ -> CmmGraph -> CmmGraph
+mapGraphNodes funs@(mf,_,_) g =
+ ofBlockMap (entryLabel $ mf $ CmmEntry $ g_entry g) $ mapMap (blockMapNodes3 funs) $ toBlockMap g
+
+foldGraphBlocks :: (CmmBlock -> a -> a) -> a -> CmmGraph -> a
+foldGraphBlocks k z g = mapFold k z $ toBlockMap g
+
+postorderDfs :: CmmGraph -> [CmmBlock]
+postorderDfs g = postorder_dfs_from (toBlockMap g) (g_entry g)
+
+-------------------------------------------------
+-- Manipulating CmmBlocks
+
+lastNode :: CmmBlock -> CmmNode O C
+lastNode block = foldBlockNodesF3 (nothing, nothing, const) block ()
+ where nothing :: a -> b -> ()
+ nothing _ _ = ()
+
+replaceLastNode :: Block CmmNode e C -> CmmNode O C -> Block CmmNode e C
+replaceLastNode block last = blockOfNodeList (first, middle, JustC last)
+ where (first, middle, _) = blockToNodeList block
+
+----------------------------------------------------------------------
+----- Splicing between blocks
+-- Given a middle node, a block, and a successor BlockId,
+-- we can insert the middle node between the block and the successor.
+-- We return the updated block and a list of new blocks that must be added
+-- to the graph.
+-- The semantics is a bit tricky. We consider cases on the last node:
+-- o For a branch, we can just insert before the branch,
+-- but sometimes the optimizer does better if we actually insert
+-- a fresh basic block, enabling some common blockification.
+-- o For a conditional branch, switch statement, or call, we must insert
+-- a new basic block.
+-- o For a jump or return, this operation is impossible.
+
+insertBetween :: MonadUnique m => CmmBlock -> [CmmNode O O] -> BlockId -> m (CmmBlock, [CmmBlock])
+insertBetween b ms succId = insert $ lastNode b
+ where insert :: MonadUnique m => CmmNode O C -> m (CmmBlock, [CmmBlock])
+ insert (CmmBranch bid) =
+ if bid == succId then
+ do (bid', bs) <- newBlocks
+ return (replaceLastNode b (CmmBranch bid'), bs)
+ else panic "tried invalid block insertBetween"
+ insert (CmmCondBranch c t f) =
+ do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
+ (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
+ return (replaceLastNode b (CmmCondBranch c t' f'), tbs ++ fbs)
+ insert (CmmSwitch e ks) =
+ do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
+ return (replaceLastNode b (CmmSwitch e ids), join bs)
+ insert (CmmCall {}) =
+ panic "unimp: insertBetween after a call -- probably not a good idea"
+ insert (CmmForeignCall {}) =
+ panic "unimp: insertBetween after a foreign call -- probably not a good idea"
+ --insert _ = panic "Cmm.insertBetween.insert"
+
+ newBlocks :: MonadUnique m => m (BlockId, [CmmBlock])
+ newBlocks = do id <- liftM mkBlockId $ getUniqueM
+ return $ (id, [blockOfNodeList (JustC (CmmEntry id), ms, JustC (CmmBranch succId))])
+ mbNewBlocks :: MonadUnique m => Maybe BlockId -> m (Maybe BlockId, [CmmBlock])
+ mbNewBlocks (Just k) = if k == succId then liftM fstJust newBlocks
+ else return (Just k, [])
+ mbNewBlocks Nothing = return (Nothing, [])
+ fstJust (id, bs) = (Just id, bs)
+
+-------------------------------------------------
+-- Running dataflow analysis and/or rewrites
+
+-- Constructing forward and backward analysis-only pass
+analFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdPass m CmmNode f
+analBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdPass m CmmNode f
+
+analFwd lat xfer = analRewFwd lat xfer noFwdRewrite
+analBwd lat xfer = analRewBwd lat xfer noBwdRewrite
+
+-- Constructing forward and backward analysis + rewrite pass
+analRewFwd :: Monad m => DataflowLattice f -> FwdTransfer CmmNode f -> FwdRewrite m CmmNode f -> FwdPass m CmmNode f
+analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer CmmNode f -> BwdRewrite m CmmNode f -> BwdPass m CmmNode f
+
+analRewFwd lat xfer rew = FwdPass {fp_lattice = lat, fp_transfer = xfer, fp_rewrite = rew}
+analRewBwd lat xfer rew = BwdPass {bp_lattice = lat, bp_transfer = xfer, bp_rewrite = rew}
+
+-- Running forward and backward dataflow analysis + optional rewrite
+dataflowPassFwd :: CmmGraph -> [(BlockId, f)] -> FwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f)
+dataflowPassFwd (CmmGraph {g_entry=entry, g_graph=graph}) facts fwd = do
+ (graph, facts, NothingO) <- analyzeAndRewriteFwd fwd (JustC [entry]) graph (mkFactBase (fp_lattice fwd) facts)
+ return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
+
+dataflowPassBwd :: CmmGraph -> [(BlockId, f)] -> BwdPass FuelUniqSM CmmNode f -> FuelUniqSM (CmmGraph, BlockEnv f)
+dataflowPassBwd (CmmGraph {g_entry=entry, g_graph=graph}) facts bwd = do
+ (graph, facts, NothingO) <- analyzeAndRewriteBwd bwd (JustC [entry]) graph (mkFactBase (bp_lattice bwd) facts)
+ return (CmmGraph {g_entry=entry, g_graph=graph}, facts)
+++ /dev/null
-
-module CmmBrokenBlock (
- BrokenBlock(..),
- BlockEntryInfo(..),
- FinalStmt(..),
- breakBlock,
- cmmBlockFromBrokenBlock,
- blocksToBlockEnv,
- adaptBlockToFormat,
- selectContinuations,
- ContFormat,
- makeContinuationEntries
- ) where
-
-#include "HsVersions.h"
-
-import BlockId
-import Cmm
-import CmmUtils
-import CLabel
-
-import CgUtils (callerSaveVolatileRegs)
-import ClosureInfo
-
-import Maybes
-import Data.List
-import Panic
-import Unique
-
--- This module takes a 'CmmBasicBlock' which might have 'CmmCall'
--- statements in it with 'CmmSafe' set and breaks it up at each such call.
--- It also collects information about the block for later use
--- by the CPS algorithm.
-
------------------------------------------------------------------------------
--- Data structures
------------------------------------------------------------------------------
-
--- |Similar to a 'CmmBlock' with a little extra information
--- to help the CPS analysis.
-data BrokenBlock
- = BrokenBlock {
- brokenBlockId :: BlockId, -- ^ The block's label like a 'CmmBasicBlock'
- brokenBlockEntry :: BlockEntryInfo,
- -- ^ Ways this block can be entered
-
- brokenBlockStmts :: [CmmStmt],
- -- ^ Body like a CmmBasicBlock
- -- (but without the last statement)
-
- brokenBlockTargets :: [BlockId],
- -- ^ Blocks that this block could
- -- branch to either by conditional
- -- branches or via the last statement
-
- brokenBlockExit :: FinalStmt
- -- ^ The final statement of the block
- }
-
--- | How a block could be entered
--- See Note [An example of CPS conversion]
-data BlockEntryInfo
- = FunctionEntry CmmInfo CLabel CmmFormals
- -- ^ Block is the beginning of a function, parameters are:
- -- 1. Function header info
- -- 2. The function name
- -- 3. Aguments to function
- -- Only the formal parameters are live
-
- | ContinuationEntry CmmFormals C_SRT Bool
- -- ^ Return point of a function call, parameters are:
- -- 1. return values (argument to continuation)
- -- 2. SRT for the continuation's info table
- -- 3. True <=> GC block so ignore stack size
- -- Live variables, other than
- -- the return values, are on the stack
-
- | ControlEntry
- -- ^ Any other kind of block. Only entered due to control flow.
-
- -- TODO: Consider adding ProcPointEntry
- -- no return values, but some live might end up as
- -- params or possibly in the frame
-
-{- Note [An example of CPS conversion]
-
-This is NR's and SLPJ's guess about how things might work;
-it may not be consistent with the actual code (particularly
-in the matter of what's in parameters and what's on the stack).
-
-f(x,y) {
- if x>2 then goto L
- x = x+1
-L: if x>1 then y = g(y)
- else x = x+1 ;
- return( x+y )
-}
- BECOMES
-
-f(x,y) { // FunctionEntry
- if x>2 then goto L
- x = x+1
-L: // ControlEntry
- if x>1 then push x; push f1; jump g(y)
- else x=x+1; jump f2(x, y)
-}
-
-f1(y) { // ContinuationEntry
- pop x; jump f2(x, y);
-}
-
-f2(x, y) { // ProcPointEntry
- return (z+y);
-}
-
--}
-
-data ContFormat = ContFormat HintedCmmFormals C_SRT Bool
- -- ^ Arguments
- -- 1. return values (argument to continuation)
- -- 2. SRT for the continuation's info table
- -- 3. True <=> GC block so ignore stack size
- deriving (Eq)
-
--- | Final statement in a 'BlokenBlock'.
--- Constructors and arguments match those in 'Cmm',
--- but are restricted to branches, returns, jumps, calls and switches
-data FinalStmt
- = FinalBranch BlockId
- -- ^ Same as 'CmmBranch'. Target must be a ControlEntry
-
- | FinalReturn HintedCmmActuals
- -- ^ Same as 'CmmReturn'. Parameter is the return values.
-
- | FinalJump CmmExpr HintedCmmActuals
- -- ^ Same as 'CmmJump'. Parameters:
- -- 1. The function to call,
- -- 2. Arguments of the call
-
- | FinalCall BlockId CmmCallTarget HintedCmmFormals HintedCmmActuals
- C_SRT CmmReturnInfo Bool
- -- ^ Same as 'CmmCallee' followed by 'CmmGoto'. Parameters:
- -- 1. Target of the 'CmmGoto' (must be a 'ContinuationEntry')
- -- 2. The function to call
- -- 3. Results from call (redundant with ContinuationEntry)
- -- 4. Arguments to call
- -- 5. SRT for the continuation's info table
- -- 6. Does the function return?
- -- 7. True <=> GC block so ignore stack size
-
- | FinalSwitch CmmExpr [Maybe BlockId]
- -- ^ Same as a 'CmmSwitch'. Paremeters:
- -- 1. Scrutinee (zero based)
- -- 2. Targets
-
------------------------------------------------------------------------------
--- Operations for broken blocks
------------------------------------------------------------------------------
-
--- Naively breaking at *every* CmmCall leads to sub-optimal code.
--- In particular, a CmmCall followed by a CmmBranch would result
--- in a continuation that has the single CmmBranch statement in it.
--- It would be better have the CmmCall directly return to the block
--- that the branch jumps to.
---
--- This requires the target of the branch to look like the parameter
--- format that the CmmCall is expecting. If other CmmCall/CmmBranch
--- sequences go to the same place they might not be expecting the
--- same format. So this transformation uses the following solution.
--- First the blocks are broken up but none of the blocks are marked
--- as continuations yet. This is the 'breakBlock' function.
--- Second, the blocks "vote" on what other blocks need to be continuations
--- and how they should be layed out. Plurality wins, but other selection
--- methods could be selected at a later time.
--- This is the 'selectContinuations' function.
--- Finally, the blocks are upgraded to 'ContEntry' continuations
--- based on the results with the 'makeContinuationEntries' function,
--- and the blocks that didn't get the format they wanted for their
--- targets get a small adaptor block created for them by
--- the 'adaptBlockToFormat' function.
--- could be
-
-{-
-UNUSED: 2008-12-29
-
-breakProc ::
- [BlockId] -- ^ Any GC blocks that should be special
- -> [[Unique]] -- ^ An infinite list of uniques
- -- to create names of the new blocks with
- -> CmmInfo -- ^ Info table for the procedure
- -> CLabel -- ^ Name of the procedure
- -> CmmFormals -- ^ Parameters of the procedure
- -> [CmmBasicBlock] -- ^ Blocks of the procecure
- -- (First block is the entry block)
- -> [BrokenBlock]
-
-breakProc gc_block_idents uniques info ident params blocks =
- let
- (adaptor_uniques : block_uniques) = uniques
-
- broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
- broken_blocks =
- let new_blocks =
- zipWith3 (breakBlock gc_block_idents)
- block_uniques
- blocks
- (FunctionEntry info ident params :
- repeat ControlEntry)
- in (concatMap fst new_blocks, concatMap snd new_blocks)
-
- selected = selectContinuations (fst broken_blocks)
-
- in map (makeContinuationEntries selected) $
- concat $
- zipWith (adaptBlockToFormat selected)
- adaptor_uniques
- (snd broken_blocks)
--}
-
------------------------------------------------------------------------------
--- | Takes a 'CmmBasicBlock' and breaks it up into a list of 'BrokenBlock'
--- by splitting on each 'CmmCall' in the 'CmmBasicBlock'.
-
-breakBlock ::
- [BlockId] -- ^ Any GC blocks that should be special
- -> [Unique] -- ^ An infinite list of uniques
- -- to create names of the new blocks with
- -> CmmBasicBlock -- ^ Input block to break apart
- -> BlockEntryInfo -- ^ Info for the first created 'BrokenBlock'
- -> ([(BlockId, ContFormat)], [BrokenBlock])
-breakBlock gc_block_idents uniques (BasicBlock ident stmts) entry =
- breakBlock' uniques ident entry [] [] stmts
- where
- breakBlock' uniques current_id entry exits accum_stmts stmts =
- case stmts of
- [] -> panic "block doesn't end in jump, goto, return or switch"
-
- -- Last statement. Make the 'BrokenBlock'
- [CmmJump target arguments] ->
- ([],
- [BrokenBlock current_id entry accum_stmts
- exits
- (FinalJump target arguments)])
- [CmmReturn arguments] ->
- ([],
- [BrokenBlock current_id entry accum_stmts
- exits
- (FinalReturn arguments)])
- [CmmBranch target] ->
- ([],
- [BrokenBlock current_id entry accum_stmts
- (target:exits)
- (FinalBranch target)])
- [CmmSwitch expr targets] ->
- ([],
- [BrokenBlock current_id entry accum_stmts
- (mapMaybe id targets ++ exits)
- (FinalSwitch expr targets)])
-
- -- These shouldn't happen in the middle of a block.
- -- They would cause dead code.
- (CmmJump _ _:_) -> panic "jump in middle of block"
- (CmmReturn _:_) -> panic "return in middle of block"
- (CmmBranch _:_) -> panic "branch in middle of block"
- (CmmSwitch _ _:_) -> panic "switch in middle of block"
-
- -- Detect this special case to remain an inverse of
- -- 'cmmBlockFromBrokenBlock'
- [CmmCall target results arguments (CmmSafe srt) ret,
- CmmBranch next_id] ->
- ([cont_info], [block])
- where
- cont_info = (next_id,
- ContFormat results srt
- (ident `elem` gc_block_idents))
- block = do_call current_id entry accum_stmts exits next_id
- target results arguments srt ret
-
- -- Break the block on safe calls (the main job of this function)
- (CmmCall target results arguments (CmmSafe srt) ret : stmts) ->
- (cont_info : cont_infos, block : blocks)
- where
- next_id = BlockId $ head uniques
- block = do_call current_id entry accum_stmts exits next_id
- target results arguments srt ret
-
- cont_info = (next_id, -- Entry convention for the
- -- continuation of the call
- ContFormat results srt
- (ident `elem` gc_block_idents))
-
- -- Break up the part after the call
- (cont_infos, blocks) = breakBlock' (tail uniques) next_id
- ControlEntry [] [] stmts
-
- -- Unsafe calls don't need a continuation
- -- but they do need to be expanded
- (CmmCall target results arguments CmmUnsafe ret : stmts) ->
- breakBlock' remaining_uniques current_id entry exits
- (accum_stmts ++
- arg_stmts ++
- caller_save ++
- [CmmCall target results new_args CmmUnsafe ret] ++
- caller_load)
- stmts
- where
- (remaining_uniques, arg_stmts, new_args) =
- loadArgsIntoTemps uniques arguments
- (caller_save, caller_load) = callerSaveVolatileRegs (Just [])
-
- -- Default case. Just keep accumulating statements
- -- and branch targets.
- (s : stmts) ->
- breakBlock' uniques current_id entry
- (cond_branch_target s++exits)
- (accum_stmts++[s])
- stmts
-
- do_call current_id entry accum_stmts exits next_id
- target results arguments srt ret =
- BrokenBlock current_id entry accum_stmts (next_id:exits)
- (FinalCall next_id target results arguments srt ret
- (current_id `elem` gc_block_idents))
-
- cond_branch_target (CmmCondBranch _ target) = [target]
- cond_branch_target _ = []
-
------------------------------------------------------------------------------
-
-selectContinuations :: [(BlockId, ContFormat)] -> [(BlockId, ContFormat)]
-selectContinuations needed_continuations = formats
- where
- formats = map select_format format_groups
- format_groups = groupBy by_target needed_continuations
- by_target x y = fst x == fst y
-
- select_format formats = winner
- where
- winner = head $ head $ sortBy more_votes format_votes
- format_votes = groupBy by_format formats
- by_format x y = snd x == snd y
- more_votes x y = compare (length y) (length x)
- -- sort so the most votes goes *first*
- -- (thus the order of x and y is reversed)
-
-makeContinuationEntries :: [(BlockId, ContFormat)]
- -> BrokenBlock -> BrokenBlock
-makeContinuationEntries formats
- block@(BrokenBlock ident _entry stmts targets exit) =
- case lookup ident formats of
- Nothing -> block
- Just (ContFormat formals srt is_gc) ->
- BrokenBlock ident (ContinuationEntry (map hintlessCmm formals) srt is_gc)
- stmts targets exit
-
-adaptBlockToFormat :: [(BlockId, ContFormat)]
- -> Unique
- -> BrokenBlock
- -> [BrokenBlock]
-adaptBlockToFormat formats unique
- block@(BrokenBlock ident entry stmts targets
- (FinalCall next target formals
- actuals srt ret is_gc)) =
- if format_formals == formals &&
- format_srt == srt &&
- format_is_gc == is_gc
- then [block] -- Woohoo! This block got the continuation format it wanted
- else [adaptor_block, revised_block]
- -- This block didn't get the format it wanted for the
- -- continuation, so we have to build an adaptor.
- where
- (ContFormat format_formals format_srt format_is_gc) =
- maybe unknown_block id $ lookup next formats
- unknown_block = panic "unknown block in adaptBlockToFormat"
-
- revised_block = BrokenBlock ident entry stmts revised_targets revised_exit
- revised_targets = adaptor_ident : delete next targets
- revised_exit = FinalCall
- adaptor_ident -- The only part that changed
- target formals actuals srt ret is_gc
-
- adaptor_block = mk_adaptor_block adaptor_ident
- (ContinuationEntry (map hintlessCmm formals) srt is_gc) next
- adaptor_ident = BlockId unique
-
- mk_adaptor_block :: BlockId -> BlockEntryInfo -> BlockId -> BrokenBlock
- mk_adaptor_block ident entry next =
- BrokenBlock ident entry [] [next] exit
- where
- exit = FinalJump
- (CmmLit (CmmLabel (mkReturnPtLabel (getUnique next))))
- (map formal_to_actual format_formals)
-
- formal_to_actual (CmmHinted reg hint)
- = (CmmHinted (CmmReg (CmmLocal reg)) hint)
- -- TODO: Check if NoHint is right. We're
- -- jumping to a C-- function not a foreign one
- -- so it might always be right.
-adaptBlockToFormat _ _ block = [block]
-
------------------------------------------------------------------------------
--- | Convert from a BrokenBlock back to an equivalent CmmBasicBlock
--- Needed by liveness analysis
-cmmBlockFromBrokenBlock :: BrokenBlock -> CmmBasicBlock
-cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) =
- BasicBlock ident (stmts++exit_stmt)
- where
- exit_stmt =
- case exit of
- FinalBranch target -> [CmmBranch target]
- FinalReturn arguments -> [CmmReturn arguments]
- FinalJump target arguments -> [CmmJump target arguments]
- FinalSwitch expr targets -> [CmmSwitch expr targets]
- FinalCall branch_target call_target results arguments srt ret _ ->
- [CmmCall call_target results arguments (CmmSafe srt) ret,
- CmmBranch branch_target]
-
------------------------------------------------------------------------------
--- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId'
-blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock
-blocksToBlockEnv blocks = mkBlockEnv $ map (\b -> (brokenBlockId b, b)) blocks
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
+-- Todo: remove
+
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
module CmmBuildInfoTables
- ( CAFSet, CAFEnv, CmmTopForInfoTables(..), cafAnal, localCAFInfo, mkTopCAFInfo
+ ( CAFSet, CAFEnv, cafAnal, localCAFInfo, mkTopCAFInfo
, setInfoTableSRT, setInfoTableStackMap
, TopSRT, emptySRT, srtToData
, bundleCAFs
- , finishInfoTables, lowerSafeForeignCalls
- , cafTransfers, liveSlotTransfers
- , extendEnvWithSafeForeignCalls, extendEnvsForSafeForeignCalls )
+ , lowerSafeForeignCalls
+ , cafTransfers, liveSlotTransfers)
where
#include "HsVersions.h"
import Constants
import Digraph
import qualified Prelude as P
-import Prelude
+import Prelude hiding (succ)
import Util (sortLe)
import BlockId
import Bitmap
import CLabel
-import Cmm hiding (blockId)
-import CmmInfo
-import CmmProcPointZ
+import Cmm
+import CmmDecl
+import CmmExpr
import CmmStackLayout
-import CmmTx
-import DFMonad
import Module
import FastString
import ForeignCall
import IdInfo
import Data.List
import Maybes
-import MkZipCfg
-import MkZipCfgCmm hiding (CmmAGraph, CmmBlock, CmmTopZ, CmmZ, CmmGraph)
+import MkGraph as M
import Control.Monad
import Name
+import OptimizationFuel
import Outputable
import SMRep
import StgCmmClosure
import StgCmmForeign
--- import StgCmmMonad
import StgCmmUtils
import UniqSupply
-import ZipCfg hiding (zip, unzip, last)
-import qualified ZipCfg as G
-import ZipCfgCmmRep
-import ZipDataflow
+
+import Compiler.Hoopl
import Data.Map (Map)
import qualified Data.Map as Map
-- pprPanic "CallAreas must not be live across function calls" (ppr bid <+> ppr c)
slots :: SubAreaSet -- The SubAreaSet for 'bid'
- slots = expectJust "live_ptrs slots" $ lookupBlockEnv slotEnv bid
+ slots = expectJust "live_ptrs slots" $ mapLookup bid slotEnv
youngByte = expectJust "live_ptrs bid_pos" $ Map.lookup (CallArea (Young bid)) areaMap
--- Construct the stack maps for the given procedure.
-setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTopForInfoTables -> CmmTopForInfoTables
-setInfoTableStackMap _ _ t@(NoInfoTable _) = t
-setInfoTableStackMap slotEnv areaMap t@(FloatingInfoTable _ bid updfr_off) =
- updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
+-- Construct the stack maps for a procedure _if_ it needs an infotable.
+-- When wouldn't a procedure need an infotable? If it is a procpoint that
+-- is not the successor of a call.
+setInfoTableStackMap :: SlotEnv -> AreaMap -> CmmTop -> CmmTop
setInfoTableStackMap slotEnv areaMap
- t@(ProcInfoTable (CmmProc (CmmInfo _ _ _) _ _ ((_, Just updfr_off), _)) procpoints) =
- case blockSetToList procpoints of
- [bid] -> updInfo (const (live_ptrs updfr_off slotEnv areaMap bid)) id t
- _ -> panic "setInfoTableStackMap: unexpected number of procpoints"
- -- until we stop splitting the graphs at procpoints in the native path
-setInfoTableStackMap _ _ t = pprPanic "unexpected case for setInfoTableStackMap" (ppr t)
+ t@(CmmProc (TopInfo {stack_info=StackInfo {updfr_space = Just updfr_off}}) _ (CmmGraph {g_entry = eid})) =
+ updInfo (const (live_ptrs updfr_off slotEnv areaMap eid)) id t
+setInfoTableStackMap _ _ t = t
-- First, an analysis to find live CAFs.
cafLattice :: DataflowLattice CAFSet
-cafLattice = DataflowLattice "live cafs" Map.empty add False
- where add new old = if Map.size new' > Map.size old
- then aTx new'
- else noTx new'
- where new' = new `Map.union` old
-
-cafTransfers :: BackwardTransfers Middle Last CAFSet
-cafTransfers = BackwardTransfers first middle last
+cafLattice = DataflowLattice "live cafs" Map.empty add
+ where add _ (OldFact old) (NewFact new) = case old `Map.union` new of
+ new' -> (changeIf $ Map.size new' > Map.size old, new')
+
+cafTransfers :: BwdTransfer CmmNode CAFSet
+cafTransfers = mkBTransfer3 first middle last
where first _ live = live
- middle m live = foldExpDeepMiddle addCaf m live
- last l env = foldExpDeepLast addCaf l (joinOuts cafLattice env l)
+ middle m live = foldExpDeep addCaf m live
+ last l live = foldExpDeep addCaf l (joinOutFacts cafLattice l live)
addCaf e set = case e of
CmmLit (CmmLabel c) -> add c set
CmmLit (CmmLabelOff c _) -> add c set
_ -> set
add l s = if hasCAF l then Map.insert (cvtToClosureLbl l) () s else s
-type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a)
-cafAnal :: LGraph Middle Last -> FuelMonad CAFEnv
-cafAnal g = liftM zdfFpFacts (res :: CafFix ())
- where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice
- cafTransfers (fact_bot cafLattice) g
+cafAnal :: CmmGraph -> FuelUniqSM CAFEnv
+cafAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd cafLattice cafTransfers
-----------------------------------------------------------------------
-- Building the SRTs
, elt_map = Map.insert caf last (elt_map srt) }
where last = next_elt srt
-srtToData :: TopSRT -> CmmZ
+srtToData :: TopSRT -> Cmm
srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : tbl)]
where tbl = map (CmmStaticLit . CmmLabel) (reverse (rev_elts srt))
-- we make sure they're all close enough to the bottom of the table that the
-- bitmap will be able to cover all of them.
buildSRTs :: TopSRT -> Map CLabel CAFSet -> CAFSet ->
- FuelMonad (TopSRT, Maybe CmmTopZ, C_SRT)
+ FuelUniqSM (TopSRT, Maybe CmmTop, C_SRT)
buildSRTs topSRT topCAFMap cafs =
do let liftCAF lbl () z = -- get CAFs for functions without static closures
case Map.lookup lbl topCAFMap of Just cafs -> z `Map.union` cafs
-- Construct an SRT bitmap.
-- Adapted from simpleStg/SRT.lhs, which expects Id's.
procpointSRT :: CLabel -> Map CLabel Int -> [CLabel] ->
- FuelMonad (Maybe CmmTopZ, C_SRT)
+ FuelUniqSM (Maybe CmmTop, C_SRT)
procpointSRT _ _ [] =
return (Nothing, NoC_SRT)
procpointSRT top_srt top_table entries =
maxBmpSize = widthInBits wordWidth `div` 2
-- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT.
-to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT)
+to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelUniqSM (Maybe CmmTop, C_SRT)
to_SRT top_srt off len bmp
| len > maxBmpSize || bmp == [fromIntegral srt_escape]
= do id <- getUniqueM
-- keep its CAFs live.)
-- Any procedure referring to a non-static CAF c must keep live
-- any CAF that is reachable from c.
-localCAFInfo :: CAFEnv -> CmmTopZ -> Maybe (CLabel, CAFSet)
+localCAFInfo :: CAFEnv -> CmmTop -> Maybe (CLabel, CAFSet)
localCAFInfo _ (CmmData _ _) = Nothing
-localCAFInfo cafEnv (CmmProc (CmmInfo _ _ infoTbl) top_l _ (_, LGraph entry _)) =
- case infoTbl of
+localCAFInfo cafEnv (CmmProc top_info top_l (CmmGraph {g_entry=entry})) =
+ case info_tbl top_info of
CmmInfoTable False _ _ _ ->
Just (cvtToClosureLbl top_l,
- expectJust "maybeBindCAFs" $ lookupBlockEnv cafEnv entry)
+ expectJust "maybeBindCAFs" $ mapLookup entry cafEnv)
_ -> Nothing
-- Once we have the local CAF sets for some (possibly) mutually
type StackLayout = [Maybe LocalReg]
-- Bundle the CAFs used at a procpoint.
-bundleCAFs :: CAFEnv -> CmmTopForInfoTables -> (CAFSet, CmmTopForInfoTables)
-bundleCAFs cafEnv t@(ProcInfoTable _ procpoints) =
- case blockSetToList procpoints of
- [bid] -> (expectJust "bundleCAFs" (lookupBlockEnv cafEnv bid), t)
- _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
- -- until we stop splitting the graphs at procpoints in the native path
-bundleCAFs cafEnv t@(FloatingInfoTable _ bid _) =
- (expectJust "bundleCAFs " (lookupBlockEnv cafEnv bid), t)
-bundleCAFs _ t@(NoInfoTable _) = (Map.empty, t)
+bundleCAFs :: CAFEnv -> CmmTop -> (CAFSet, CmmTop)
+bundleCAFs cafEnv t@(CmmProc _ _ (CmmGraph {g_entry=entry})) =
+ (expectJust "bundleCAFs" (mapLookup entry cafEnv), t)
+bundleCAFs _ t = (Map.empty, t)
-- Construct the SRTs for the given procedure.
-setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTopForInfoTables) ->
- FuelMonad (TopSRT, [CmmTopForInfoTables])
-setInfoTableSRT topCAFMap topSRT (cafs, t@(ProcInfoTable _ procpoints)) =
- case blockSetToList procpoints of
- [_] -> setSRT cafs topCAFMap topSRT t
- _ -> panic "setInfoTableStackMap: unexpect number of procpoints"
- -- until we stop splitting the graphs at procpoints in the native path
-setInfoTableSRT topCAFMap topSRT (cafs, t@(FloatingInfoTable _ _ _)) =
+setInfoTableSRT :: Map CLabel CAFSet -> TopSRT -> (CAFSet, CmmTop) ->
+ FuelUniqSM (TopSRT, [CmmTop])
+setInfoTableSRT topCAFMap topSRT (cafs, t) =
setSRT cafs topCAFMap topSRT t
-setInfoTableSRT _ topSRT (_, t@(NoInfoTable _)) = return (topSRT, [t])
setSRT :: CAFSet -> Map CLabel CAFSet -> TopSRT ->
- CmmTopForInfoTables -> FuelMonad (TopSRT, [CmmTopForInfoTables])
+ CmmTop -> FuelUniqSM (TopSRT, [CmmTop])
setSRT cafs topCAFMap topSRT t =
do (topSRT, cafTable, srt) <- buildSRTs topSRT topCAFMap cafs
let t' = updInfo id (const srt) t
case cafTable of
- Just tbl -> return (topSRT, [t', NoInfoTable tbl])
+ Just tbl -> return (topSRT, [t', tbl])
Nothing -> return (topSRT, [t'])
-updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) ->
- CmmTopForInfoTables -> CmmTopForInfoTables
-updInfo toVars toSrt (ProcInfoTable (CmmProc info top_l top_args g) procpoints) =
- ProcInfoTable (CmmProc (updInfoTbl toVars toSrt info) top_l top_args g) procpoints
-updInfo toVars toSrt (FloatingInfoTable info bid updfr_off) =
- FloatingInfoTable (updInfoTbl toVars toSrt info) bid updfr_off
-updInfo _ _ (NoInfoTable _) = panic "can't update NoInfoTable"
-updInfo _ _ _ = panic "unexpected arg to updInfo"
-
-updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfo -> CmmInfo
-updInfoTbl toVars toSrt (CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo))
- = CmmInfo gc upd_fr (CmmInfoTable s p t typeinfo')
+updInfo :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmTop -> CmmTop
+updInfo toVars toSrt (CmmProc top_info top_l g) =
+ CmmProc (top_info {info_tbl=updInfoTbl toVars toSrt (info_tbl top_info)}) top_l g
+updInfo _ _ t = t
+
+updInfoTbl :: (StackLayout -> StackLayout) -> (C_SRT -> C_SRT) -> CmmInfoTable -> CmmInfoTable
+updInfoTbl toVars toSrt (CmmInfoTable s p t typeinfo)
+ = CmmInfoTable s p t typeinfo'
where typeinfo' = case typeinfo of
t@(ConstrInfo _ _ _) -> t
(FunInfo c s a d e) -> FunInfo c (toSrt s) a d e
(ThunkInfo c s) -> ThunkInfo c (toSrt s)
(ThunkSelectorInfo x s) -> ThunkSelectorInfo x (toSrt s)
(ContInfo v s) -> ContInfo (toVars v) (toSrt s)
-updInfoTbl _ _ t@(CmmInfo _ _ CmmNonInfoTable) = t
+updInfoTbl _ _ t@CmmNonInfoTable = t
--- Lower the CmmTopForInfoTables type down to good old CmmTopZ
--- by emitting info tables as data where necessary.
-finishInfoTables :: CmmTopForInfoTables -> IO [CmmTopZ]
-finishInfoTables (NoInfoTable t) = return [t]
-finishInfoTables (ProcInfoTable p _) = return [p]
-finishInfoTables (FloatingInfoTable (CmmInfo _ _ infotbl) bid _) =
- do uniq_supply <- mkSplitUniqSupply 'i'
- return $ mkBareInfoTable (retPtLbl bid) (uniqFromSupply uniq_supply) infotbl
-
----------------------------------------------------------------
--- Safe foreign calls:
--- Our analyses capture the dataflow facts at block boundaries, but we need
--- to extend the CAF and live-slot analyses to safe foreign calls as well,
--- which show up as middle nodes.
-extendEnvWithSafeForeignCalls ::
- BackwardTransfers Middle Last a -> BlockEnv a -> CmmGraph -> BlockEnv a
-extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g
- where block b z =
- tail (bt_last_in transfers l (lookup env)) z head
- where (head, last) = goto_end (G.unzip b)
- l = case last of LastOther l -> l
- LastExit -> panic "extendEnvs lastExit"
- tail _ z (ZFirst _) = z
- tail fact env (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
- tail (mid m fact) (extendBlockEnv env bid fact) h
- tail fact env (ZHead h m) = tail (mid m fact) env h
- lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k
- mid = bt_middle_in transfers
-
-
-extendEnvsForSafeForeignCalls :: CAFEnv -> SlotEnv -> CmmGraph -> (CAFEnv, SlotEnv)
-extendEnvsForSafeForeignCalls cafEnv slotEnv g =
- fold_blocks block (cafEnv, slotEnv) g
- where block b z =
- tail ( bt_last_in cafTransfers l (lookupFn cafEnv)
- , bt_last_in liveSlotTransfers l (lookupFn slotEnv))
- z head
- where (head, last) = goto_end (G.unzip b)
- l = case last of LastOther l -> l
- LastExit -> panic "extendEnvs lastExit"
- tail _ z (ZFirst _) = z
- tail lives@(cafs, slots) (cafEnv, slotEnv)
- (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
- let slots' = removeLiveSlotDefs slots m
- slotEnv' = extendBlockEnv slotEnv bid slots'
- cafEnv' = extendBlockEnv cafEnv bid cafs
- in tail (upd lives m) (cafEnv', slotEnv') h
- tail lives z (ZHead h m) = tail (upd lives m) z h
- lookupFn map k = expectJust "extendEnvsForSafeFCalls" $ lookupBlockEnv map k
- upd (cafs, slots) m =
- (bt_middle_in cafTransfers m cafs, bt_middle_in liveSlotTransfers m slots)
-
-- Safe foreign calls: We need to insert the code that suspends and resumes
-- the thread before and after a safe foreign call.
-- Why do we do this so late in the pipeline?
-- a procpoint. The following datatype captures the information
-- needed to generate the infotables along with the Cmm data and procedures.
-data CmmTopForInfoTables
- = NoInfoTable CmmTopZ -- must be CmmData
- | ProcInfoTable CmmTopZ BlockSet -- CmmProc; argument is its set of procpoints
- | FloatingInfoTable CmmInfo BlockId UpdFrameOffset
-instance Outputable CmmTopForInfoTables where
- ppr (NoInfoTable t) = text "NoInfoTable: " <+> ppr t
- ppr (ProcInfoTable t bids) = text "ProcInfoTable: " <+> ppr t <+> ppr bids
- ppr (FloatingInfoTable info bid upd) =
- text "FloatingInfoTable: " <+> ppr info <+> ppr bid <+> ppr upd
-
--- The `safeState' record collects the info we update while lowering the
--- safe foreign calls in the graph.
-data SafeState = State { s_blocks :: BlockEnv CmmBlock
- , s_pps :: ProcPointSet
- , s_safeCalls :: [CmmTopForInfoTables]}
-
-lowerSafeForeignCalls
- :: [[CmmTopForInfoTables]] -> CmmTopZ -> FuelMonad [[CmmTopForInfoTables]]
-lowerSafeForeignCalls rst t@(CmmData _ _) = return $ [NoInfoTable t] : rst
-lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do
- let init = return $ State emptyBlockEnv emptyBlockSet []
- let block b@(Block bid _) z = do
- state@(State {s_pps = ppset, s_blocks = blocks}) <- z
- let ppset' = if bid == entry then extendBlockSet ppset bid else ppset
- state' = state { s_pps = ppset' }
- if hasSafeForeignCall b
- then lowerSafeCallBlock state' b
- else return (state' { s_blocks = insertBlock b blocks })
- State blocks' g_procpoints safeCalls <- fold_blocks block init g
- let proc = (CmmProc info l args (off, LGraph entry blocks'))
- procTable = case off of
- (_, Just _) -> [ProcInfoTable proc g_procpoints]
- _ -> [NoInfoTable proc] -- not a successor of a call
- return $ safeCalls : procTable : rst
-
--- Check for foreign calls -- if none, then we can avoid copying the block.
-hasSafeForeignCall :: CmmBlock -> Bool
-hasSafeForeignCall (Block _ t) = tail t
- where tail (ZTail (MidForeignCall (Safe _ _ _) _ _ _) _) = True
- tail (ZTail _ t) = tail t
- tail (ZLast _) = False
-
--- Lower each safe call in the block, update the CAF and slot environments
--- to include each of those calls, and insert the new block in the blockEnv.
-lowerSafeCallBlock :: SafeState-> CmmBlock -> FuelMonad SafeState
-lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
- where (head, last) = goto_end (G.unzip b)
- tail s b@(ZBlock (ZFirst _) _) =
- do state <- s
- return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
- tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off _) _ _ _)) t) =
- do state <- s
- let state' = state
- { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
- s_safeCalls state }
- (state'', t') <- lowerSafeForeignCall state' m t
- tail (return state'') (ZBlock h t')
- tail s (ZBlock (ZHead h m) t) = tail s (ZBlock h (ZTail m t))
-
+-- JD: Why not do this while splitting procedures?
+lowerSafeForeignCalls :: AreaMap -> CmmTop -> FuelUniqSM CmmTop
+lowerSafeForeignCalls _ t@(CmmData _ _) = return t
+lowerSafeForeignCalls areaMap (CmmProc info l g@(CmmGraph {g_entry=entry})) = do
+ let block b mblocks = mblocks >>= lowerSafeCallBlock entry areaMap b
+ blocks <- foldGraphBlocks block (return mapEmpty) g
+ return $ CmmProc info l (ofBlockMap entry blocks)
+
+-- If the block ends with a safe call in the block, lower it to an unsafe
+-- call (with appropriate saves and restores before and after).
+lowerSafeCallBlock :: BlockId -> AreaMap -> CmmBlock -> BlockEnv CmmBlock
+ -> FuelUniqSM (BlockEnv CmmBlock)
+lowerSafeCallBlock entry areaMap b blocks =
+ case blockToNodeList b of
+ (JustC (CmmEntry id), m, JustC l@(CmmForeignCall {})) -> lowerSafeForeignCall entry areaMap blocks id m l
+ _ -> return $ insertBlock b blocks
-- Late in the code generator, we want to insert the code necessary
-- to lower a safe foreign call to a sequence of unsafe calls.
-lowerSafeForeignCall ::
- SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
-lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _ interruptible) _ _ _) tail = do
- let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
+lowerSafeForeignCall :: BlockId -> AreaMap -> BlockEnv CmmBlock -> BlockId -> [CmmNode O O] -> CmmNode O C
+ -> FuelUniqSM (BlockEnv CmmBlock)
+lowerSafeForeignCall entry areaMap blocks bid m
+ (CmmForeignCall {tgt=tgt, res=rs, args=as, succ=succ, updfr = updfr_off, intrbl = intrbl}) =
+ do let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
-- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection
id <- newTemp bWord
new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
- let (caller_save, caller_load) = callerSaveVolatileRegs
+ let (caller_save, caller_load) = callerSaveVolatileRegs
load_tso <- newTemp gcWord -- TODO FIXME NOW
- let suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
- resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
- suspend = mkStore (CmmReg spReg) (CmmLit (CmmBlock infotable)) <*>
- saveThreadState <*>
- caller_save <*>
+ load_stack <- newTemp gcWord -- TODO FIXME NOW
+ let (<**>) = (M.<*>)
+ let suspendThread = foreignLbl "suspendThread"
+ resumeThread = foreignLbl "resumeThread"
+ foreignLbl name = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit name)))
+ suspend = saveThreadState <**>
+ caller_save <**>
mkUnsafeCall (ForeignTarget suspendThread
- (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
- -- XXX Not sure if the size of the CmmInt is correct
- [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum interruptible)) wordWidth)]
- resume = mkUnsafeCall (ForeignTarget resumeThread
- (ForeignConvention CCallConv [AddrHint] [AddrHint]))
- [new_base] [CmmReg (CmmLocal id)] <*>
- -- Assign the result to BaseReg: we
- -- might now have a different Capability!
- mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <*>
- caller_load <*>
- loadThreadState load_tso
- Graph tail' blocks' <-
- liftUniq (graphOfAGraph (suspend <*> mkMiddle m <*> resume <*> mkZTail tail))
- return (state {s_blocks = s_blocks state `plusBlockEnv` blocks'}, tail')
-lowerSafeForeignCall _ _ _ = panic "lowerSafeForeignCall was passed something else"
+ (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
+ [id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum intrbl)) wordWidth)]
+ midCall = mkUnsafeCall tgt rs as
+ resume = mkUnsafeCall (ForeignTarget resumeThread
+ (ForeignConvention CCallConv [AddrHint] [AddrHint]))
+ [new_base] [CmmReg (CmmLocal id)] <**>
+ -- Assign the result to BaseReg: we
+ -- might now have a different Capability!
+ mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)) <**>
+ caller_load <**>
+ loadThreadState load_tso load_stack
+ -- We have to save the return value on the stack because its next use
+ -- may appear in a different procedure due to procpoint splitting...
+ saveRetVals = foldl (<**>) emptyAGraph $ map (M.mkMiddle . spill) rs
+ spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
+ regSlot r@(LocalReg _ _) = CmmRegOff (CmmGlobal Sp) (sp_off - offset)
+ where offset = w + expectJust "lowerForeign" (Map.lookup (RegSlot r) areaMap)
+ sp_off = wORD_SIZE + expectJust "lowerForeign" (Map.lookup (CallArea area) areaMap)
+ area = if succ == entry then Old else Young succ
+ w = widthInBytes $ typeWidth $ localRegType r
+ -- Note: The successor must be a procpoint, and we have already split,
+ -- so we use a jump, not a branch.
+ succLbl = CmmLit (CmmLabel (infoTblLbl succ))
+ jump = CmmCall { cml_target = succLbl, cml_cont = Nothing
+ , cml_args = widthInBytes wordWidth ,cml_ret_args = 0
+ , cml_ret_off = updfr_off}
+ graph' <- liftUniq $ labelAGraph bid $ catAGraphs (map M.mkMiddle m) <**>
+ suspend <**> midCall <**>
+ resume <**> saveRetVals <**> M.mkLast jump
+ return $ blocks `mapUnion` toBlockMap graph'
+lowerSafeForeignCall _ _ _ _ _ _ = panic "lowerSafeForeignCall was passed something else"
+{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+-- Norman likes local bindings
+-- If this module lives on I'd like to get rid of this flag in due course
module CmmCPS (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
- cmmCPS
+ -- Well, sort of.
+ protoCmmCPS
) where
-#include "HsVersions.h"
-
-import BlockId
+import CLabel
import Cmm
-import CmmLint
-import PprCmm
-
-import CmmLive
-import CmmBrokenBlock
+import CmmDecl
+import CmmBuildInfoTables
+import CmmCommonBlockElim
import CmmProcPoint
-import CmmCallConv
-import CmmCPSGen
-import CmmUtils
-
-import ClosureInfo
-import CLabel
-import SMRep
-import Constants
+import CmmSpillReload
+import CmmStackLayout
+import OptimizationFuel
import DynFlags
import ErrUtils
-import Maybes
-import Outputable
-import UniqSupply
-import UniqSet
-import Unique
-
+import HscTypes
+import Data.Maybe
import Control.Monad
+import Data.Map (Map)
+import qualified Data.Map as Map
+import Outputable
+import StaticFlags
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
-cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
- -> [Cmm] -- ^ Input C-- with Proceedures
- -> IO [Cmm] -- ^ Output CPS transformed C--
-cmmCPS dflags cmm_with_calls
- = do { when (dopt Opt_DoCmmLinting dflags) $
- do showPass dflags "CmmLint"
- case firstJusts $ map cmmLint cmm_with_calls of
- Just err -> do printDump err
- ghcExit dflags 1
- Nothing -> return ()
- ; showPass dflags "CPS"
-
- -- TODO: more lint checking
- -- check for use of branches to non-existant blocks
- -- check for use of Sp, SpLim, R1, R2, etc.
-
- ; uniqSupply <- mkSplitUniqSupply 'p'
- ; let supplies = listSplitUniqSupply uniqSupply
- ; let cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls
-
- ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm)
-
- -- TODO: add option to dump Cmm to file
-
- ; return cpsd_cmm }
-
-
------------------------------------------------------------------------------
--- |CPS a single CmmTop (proceedure)
--- Only 'CmmProc' are transformed 'CmmData' will be left alone.
------------------------------------------------------------------------------
-
-doCpsProc :: UniqSupply -> Cmm -> Cmm
-doCpsProc s (Cmm c)
- = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
-
-cpsProc :: UniqSupply
- -> CmmTop -- ^Input procedure
- -> [CmmTop] -- ^Output procedures;
- -- a single input procedure is converted to
- -- multiple output procedures
-
--- Data blocks don't need to be CPS transformed
-cpsProc _ proc@(CmmData _ _) = [proc]
-
--- Empty functions just don't work with the CPS algorithm, but
--- they don't need the transformation anyway so just output them directly
-cpsProc _ proc@(CmmProc _ _ _ (ListGraph []))
- = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
-
--- CPS transform for those procs that actually need it
--- The plan is this:
---
--- * Introduce a stack-check block as the first block
--- * The first blocks gets a FunctionEntry; the rest are ControlEntry
--- * Now break each block into a bunch of blocks (at call sites);
--- all but the first will be ContinuationEntry
---
-cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs
- where
- -- We need to be generating uniques for several things.
- -- We could make this function monadic to handle that
- -- but since there is no other reason to make it monadic,
- -- we instead will just split them all up right here.
- (uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
- uniques :: [[Unique]]
- uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
- (stack_check_block_unique:stack_use_unique:adaptor_uniques) :
- block_uniques = uniques
- proc_uniques = map (map (map uniqsFromSupply . listSplitUniqSupply) . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
-
- stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegType spReg))
- stack_check_block_id = BlockId stack_check_block_unique
- stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
-
- forced_blocks = stack_check_block : blocks
-
- CmmInfo maybe_gc_block_id update_frame _ = info
-
- -- Break the block at each function call.
- -- The part after the function call will have to become a continuation.
- broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
- broken_blocks =
- (\x -> (concatMap fst x, concatMap snd x)) $
- zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
- block_uniques
- forced_blocks
- (FunctionEntry info ident params :
- repeat ControlEntry)
-
- f' = selectContinuations (fst broken_blocks)
- broken_blocks' = map (makeContinuationEntries f') $
- concat $
- zipWith (adaptBlockToFormat f')
- adaptor_uniques
- (snd broken_blocks)
-
- -- Calculate live variables for each broken block.
- --
- -- Nothing can be live on entry to the first block
- -- so we could take the tail, but for now we wont
- -- to help future proof the code.
- live :: BlockEntryLiveness
- live = cmmLiveness $ map cmmBlockFromBrokenBlock broken_blocks'
-
- -- Calculate which blocks must be made into full fledged procedures.
- proc_points :: UniqSet BlockId
- proc_points = calculateProcPoints broken_blocks'
-
- -- Construct a map so we can lookup a broken block by its 'BlockId'.
- block_env :: BlockEnv BrokenBlock
- block_env = blocksToBlockEnv broken_blocks'
-
- -- Group the blocks into continuations based on the set of proc-points.
- continuations :: [Continuation (Either C_SRT CmmInfo)]
- continuations = map (gatherBlocksIntoContinuation live proc_points block_env)
- (uniqSetToList proc_points)
-
- -- Select the stack format on entry to each continuation.
- -- Return the max stack offset and an association list
- --
- -- This is an association list instead of a UniqFM because
- -- CLabel's don't have a 'Uniqueable' instance.
- formats :: [(CLabel, -- key
- (CmmFormals, -- arguments
- Maybe CLabel, -- label in top slot
- [Maybe LocalReg]))] -- slots
- formats = selectContinuationFormat live continuations
-
- -- Do a little meta-processing on the stack formats such as
- -- getting the individual frame sizes and the maximum frame size
- formats' :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
- formats'@(_, _, format_list) = processFormats formats update_frame continuations
-
- -- Update the info table data on the continuations with
- -- the selected stack formats.
- continuations' :: [Continuation CmmInfo]
- continuations' = map (applyContinuationFormat format_list) continuations
-
- -- Do the actual CPS transform.
- cps_procs :: [CmmTop]
- cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
-
-make_stack_check :: BlockId -> CmmInfo -> CmmReg -> BlockId
- -> GenBasicBlock CmmStmt
-make_stack_check stack_check_block_id info stack_use next_block_id =
- BasicBlock stack_check_block_id $
- check_stmts ++ [CmmBranch next_block_id]
- where
- check_stmts =
- case info of
- -- If we are given a stack check handler,
- -- then great, well check the stack.
- CmmInfo (Just gc_block) _ _
- -> [CmmCondBranch
- (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
- [CmmReg stack_use, CmmReg spLimReg])
- gc_block]
- -- If we aren't given a stack check handler,
- -- then humph! we just won't check the stack for them.
- CmmInfo Nothing _ _
- -> []
------------------------------------------------------------------------------
-
-collectNonProcPointTargets ::
- UniqSet BlockId -> BlockEnv BrokenBlock
- -> UniqSet BlockId -> [BlockId] -> UniqSet BlockId
-collectNonProcPointTargets proc_points blocks current_targets new_blocks =
- if sizeUniqSet current_targets == sizeUniqSet new_targets
- then current_targets
- else foldl
- (collectNonProcPointTargets proc_points blocks)
- new_targets
- (map (:[]) targets)
- where
- blocks' = map (lookupWithDefaultBEnv blocks (panic "TODO")) new_blocks
- targets =
- -- Note the subtlety that since the extra branch after a call
- -- will always be to a block that is a proc-point,
- -- this subtraction will always remove that case
- uniqSetToList $ (unionManyUniqSets $ map (mkUniqSet . brokenBlockTargets) blocks')
- `minusUniqSet` proc_points
- -- TODO: remove redundant uniqSetToList
- new_targets = current_targets `unionUniqSets` (mkUniqSet targets)
-
--- TODO: insert proc point code here
--- * Branches and switches to proc points may cause new blocks to be created
--- (or proc points could leave behind phantom blocks that just jump to them)
--- * Proc points might get some live variables passed as arguments
-
-gatherBlocksIntoContinuation ::
- BlockEntryLiveness -> UniqSet BlockId -> BlockEnv BrokenBlock
- -> BlockId -> Continuation (Either C_SRT CmmInfo)
-gatherBlocksIntoContinuation live proc_points blocks start =
- Continuation info_table clabel params is_gc_cont body
- where
- children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) [start]) `minusUniqSet` (unitUniqSet start)
- start_block = lookupWithDefaultBEnv blocks unknown_block start
- children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children)
- unknown_block :: a -- Used at more than one type
- unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
- body = start_block : children_blocks
-
- -- We can't properly annotate the continuation's stack parameters
- -- at this point because this is before stack selection
- -- but we want to keep the C_SRT around so we use 'Either'.
- info_table = case start_block_entry of
- FunctionEntry info _ _ -> Right info
- ContinuationEntry _ srt _ -> Left srt
- ControlEntry -> Right (CmmInfo Nothing Nothing CmmNonInfoTable)
-
- is_gc_cont = case start_block_entry of
- FunctionEntry _ _ _ -> False
- ContinuationEntry _ _ gc_cont -> gc_cont
- ControlEntry -> False
-
- start_block_entry = brokenBlockEntry start_block
- clabel = case start_block_entry of
- FunctionEntry _ label _ -> label
- _ -> mkReturnPtLabel $ getUnique start
- params = case start_block_entry of
- FunctionEntry _ _ args -> args
- ContinuationEntry args _ _ -> args
- ControlEntry ->
- uniqSetToList $
- lookupWithDefaultBEnv live unknown_block start
- -- it's a proc-point, pass lives in parameter registers
-
---------------------------------------------------------------------------------
--- For now just select the continuation orders in the order they are in the set with no gaps
-
-selectContinuationFormat :: BlockEnv CmmLive
- -> [Continuation (Either C_SRT CmmInfo)]
- -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
-selectContinuationFormat live continuations =
- map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
- where
- -- User written continuations
- selectContinuationFormat' (Continuation
- (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format _))))
- label formals _ _) =
- (formals, Just label, format)
- -- Either user written non-continuation code
- -- or CPS generated proc-points
- selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
- (formals, Nothing, [])
- -- CPS generated continuations
- selectContinuationFormat' (Continuation (Left _) label formals _ blocks) =
- -- TODO: assumes the first block is the entry block
- let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
- in (formals,
- Just label,
- map Just $ uniqSetToList $
- lookupWithDefaultBEnv live unknown_block ident)
-
- unknown_block = panic "unknown BlockId in selectContinuationFormat"
-
-processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
- -> Maybe UpdateFrame
- -> [Continuation (Either C_SRT CmmInfo)]
- -> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
-processFormats formats update_frame continuations =
- (max_size + update_frame_size, update_frame_size, formats')
- where
- max_size = maximum $
- 0 : map (continuationMaxStack formats') continuations
- formats' = map make_format formats
- make_format (label, (formals, top, stack)) =
- (label,
- ContinuationFormat {
- continuation_formals = formals,
- continuation_label = top,
- continuation_frame_size = stack_size stack +
- if isJust top
- then label_size
- else 0,
- continuation_stack = stack })
-
- update_frame_size = case update_frame of
- Nothing -> 0
- (Just (UpdateFrame _ args))
- -> label_size + update_size args
-
- update_size [] = 0
- update_size (expr:exprs) = width + update_size exprs
- where
- width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
- -- TODO: it would be better if we had a machRepWordWidth
-
- -- TODO: get rid of "+ 1" etc.
- label_size = 1 :: WordOff
-
- stack_size [] = 0
- stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
- stack_size (Just reg:formats) = width + stack_size formats
- where
- width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
- -- TODO: it would be better if we had a machRepWordWidth
-
-continuationMaxStack :: [(CLabel, ContinuationFormat)]
- -> Continuation a
- -> WordOff
-continuationMaxStack _ (Continuation _ _ _ True _) = 0
-continuationMaxStack formats (Continuation _ label _ False blocks) =
- max_arg_size + continuation_frame_size stack_format
- where
- stack_format = maybe unknown_format id $ lookup label formats
- unknown_format = panic "Unknown format in continuationMaxStack"
-
- max_arg_size = maximum $ 0 : map block_max_arg_size blocks
-
- block_max_arg_size block =
- maximum (final_arg_size (brokenBlockExit block) :
- map stmt_arg_size (brokenBlockStmts block))
-
- final_arg_size (FinalReturn args) =
- argumentsSize (cmmExprType . hintlessCmm) args
- final_arg_size (FinalJump _ args) =
- argumentsSize (cmmExprType . hintlessCmm) args
- final_arg_size (FinalCall _ _ _ _ _ _ True) = 0
- final_arg_size (FinalCall next _ _ args _ _ False) =
- -- We have to account for the stack used when we build a frame
- -- for the *next* continuation from *this* continuation
- argumentsSize (cmmExprType . hintlessCmm) args +
- continuation_frame_size next_format
- where
- next_format = maybe unknown_format id $ lookup next' formats
- next' = mkReturnPtLabel $ getUnique next
-
- final_arg_size _ = 0
-
- stmt_arg_size (CmmJump _ args) =
- argumentsSize (cmmExprType . hintlessCmm) args
- stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
- panic "Safe call in processFormats"
- stmt_arg_size (CmmReturn _) =
- panic "CmmReturn in processFormats"
- stmt_arg_size _ = 0
-
------------------------------------------------------------------------------
-applyContinuationFormat :: [(CLabel, ContinuationFormat)]
- -> Continuation (Either C_SRT CmmInfo)
- -> Continuation CmmInfo
-
--- User written continuations
-applyContinuationFormat formats
- (Continuation (Right (CmmInfo gc update_frame
- (CmmInfoTable clos prof tag (ContInfo _ srt))))
- label formals is_gc blocks) =
- Continuation (CmmInfo gc update_frame (CmmInfoTable clos prof tag (ContInfo format srt)))
- label formals is_gc blocks
- where
- format = continuation_stack $ maybe unknown_block id $ lookup label formats
- unknown_block = panic "unknown BlockId in applyContinuationFormat"
-
--- Either user written non-continuation code or CPS generated proc-point
-applyContinuationFormat _ (Continuation
- (Right info) label formals is_gc blocks) =
- Continuation info label formals is_gc blocks
-
--- CPS generated continuations
-applyContinuationFormat formats (Continuation
- (Left srt) label formals is_gc blocks) =
- Continuation (CmmInfo gc Nothing (CmmInfoTable undefined prof tag (ContInfo (continuation_stack $ format) srt)))
- label formals is_gc blocks
- where
- gc = Nothing -- Generated continuations never need a stack check
- -- TODO prof: this is the same as the current implementation
- -- but I think it could be improved
- prof = ProfilingInfo zeroCLit zeroCLit
- tag = rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
- format = maybe unknown_block id $ lookup label formats
- unknown_block = panic "unknown BlockId in applyContinuationFormat"
-
+-- There are two complications here:
+-- 1. We need to compile the procedures in two stages because we need
+-- an analysis of the procedures to tell us what CAFs they use.
+-- The first stage returns a map from procedure labels to CAFs,
+-- along with a closure that will compute SRTs and attach them to
+-- the compiled procedures.
+-- The second stage is to combine the CAF information into a top-level
+-- CAF environment mapping non-static closures to the CAFs they keep live,
+-- then pass that environment to the closures returned in the first
+-- stage of compilation.
+-- 2. We need to thread the module's SRT around when the SRT tables
+-- are computed for each procedure.
+-- The SRT needs to be threaded because it is grown lazily.
+protoCmmCPS :: HscEnv -- Compilation env including
+ -- dynamic flags: -dcmm-lint -ddump-cps-cmm
+ -> (TopSRT, [Cmm]) -- SRT table and accumulating list of compiled procs
+ -> Cmm -- Input C-- with Procedures
+ -> IO (TopSRT, [Cmm]) -- Output CPS transformed C--
+protoCmmCPS hsc_env (topSRT, rst) (Cmm tops) =
+ do let dflags = hsc_dflags hsc_env
+ showPass dflags "CPSZ"
+ (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
+ let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
+ (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
+ let cmms = Cmm (reverse (concat tops))
+ dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
+ return (topSRT, cmms : rst)
+
+{- [Note global fuel]
+~~~~~~~~~~~~~~~~~~~~~
+The identity and the last pass are stored in
+mutable reference cells in an 'HscEnv' and are
+global to one compiler session.
+-}
+
+cpsTop :: HscEnv -> CmmTop -> IO ([(CLabel, CAFSet)], [(CAFSet, CmmTop)])
+cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, p)])
+cpsTop hsc_env (CmmProc h@(TopInfo {stack_info=StackInfo {arg_space=entry_off}}) l g) =
+ do
+ -- Why bother doing it this early?
+ -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+ -- (dualLivenessWithInsertion callPPs) g
+ -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
+ -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+ -- (removeDeadAssignmentsAndReloads callPPs) g
+ dump Opt_D_dump_cmmz "Pre common block elimination" g
+ g <- return $ elimCommonBlocks g
+ dump Opt_D_dump_cmmz "Post common block elimination" g
+
+ -- Any work storing block Labels must be performed _after_ elimCommonBlocks
+
+ ----------- Proc points -------------------
+ let callPPs = callProcPoints g
+ procPoints <- run $ minimalProcPointSet callPPs g
+ g <- run $ addProcPointProtocols callPPs procPoints g
+ dump Opt_D_dump_cmmz "Post Proc Points Added" g
+
+ ----------- Spills and reloads -------------------
+ g <-
+ -- pprTrace "pre Spills" (ppr g) $
+ dual_rewrite Opt_D_dump_cmmz "spills and reloads"
+ (dualLivenessWithInsertion procPoints) g
+ -- Insert spills at defns; reloads at return points
+ g <-
+ -- pprTrace "pre insertLateReloads" (ppr g) $
+ run $ insertLateReloads g -- Duplicate reloads just before uses
+ dump Opt_D_dump_cmmz "Post late reloads" g
+ g <-
+ -- pprTrace "post insertLateReloads" (ppr g) $
+ dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
+ (removeDeadAssignmentsAndReloads procPoints) g
+ -- Remove redundant reloads (and any other redundant asst)
+
+ ----------- Debug only: add code to put zero in dead stack slots----
+ -- Debugging: stubbing slots on death can cause crashes early
+ g <- -- trace "post dead-assign elim" $
+ if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
+
+
+ --------------- Stack layout ----------------
+ slotEnv <- run $ liveSlotAnal g
+ mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
+ let areaMap = layout procPoints slotEnv entry_off g
+ mbpprTrace "areaMap" (ppr areaMap) $ return ()
+
+ ------------ Manifest the stack pointer --------
+ g <- run $ manifestSP areaMap entry_off g
+ dump Opt_D_dump_cmmz "after manifestSP" g
+ -- UGH... manifestSP can require updates to the procPointMap.
+ -- We can probably do something quicker here for the update...
+
+ ------------- Split into separate procedures ------------
+ procPointMap <- run $ procPointAnalysis procPoints g
+ dump Opt_D_dump_cmmz "procpoint map" procPointMap
+ gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
+ (CmmProc h l g)
+ mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
+
+ ------------- More CAFs and foreign calls ------------
+ cafEnv <- run $ cafAnal g
+ let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
+ mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
+
+ gs <- run $ mapM (lowerSafeForeignCalls areaMap) gs
+ mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
+
+ -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
+ let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
+ mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
+ let gs'' = map (bundleCAFs cafEnv) gs'
+ mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
+ return (localCAFs, gs'')
+ where dflags = hsc_dflags hsc_env
+ mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
+ dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
+
+ run = runFuelIO (hsc_OptFuel hsc_env)
+
+ dual_rewrite flag txt pass g =
+ do dump flag ("Pre " ++ txt) g
+ g <- run $ pass g
+ dump flag ("Post " ++ txt) $ g
+ return g
+
+-- This probably belongs in CmmBuildInfoTables?
+-- We're just finishing the job here: once we know what CAFs are defined
+-- in non-static closures, we can build the SRTs.
+toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTop]])
+ -> [(CAFSet, CmmTop)] -> IO (TopSRT, [[CmmTop]])
+toTops hsc_env topCAFEnv (topSRT, tops) gs =
+ do let setSRT (topSRT, rst) g =
+ do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
+ return (topSRT, gs : rst)
+ (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
+ return (topSRT, concat gs' : tops)
+++ /dev/null
-module CmmCPSGen (
- -- | Converts continuations into full proceedures.
- -- The main work of the CPS transform that everything else is setting-up.
- continuationToProc,
- Continuation(..), continuationLabel,
- ContinuationFormat(..),
-) where
-
-import BlockId
-import Cmm
-import CLabel
-import CmmBrokenBlock -- Data types only
-import CmmUtils
-import CmmCallConv
-import ClosureInfo
-
-import CgProf
-import CgUtils
-import CgInfoTbls
-import SMRep
-import ForeignCall
-
-import Module
-import Constants
-import StaticFlags
-import Unique
-import Data.Maybe
-import FastString
-
-import Panic
-
--- The format for the call to a continuation
--- The fst is the arguments that must be passed to the continuation
--- by the continuation's caller.
--- The snd is the live values that must be saved on stack.
--- A Nothing indicates an ignored slot.
--- The head of each list is the stack top or the first parameter.
-
--- The format for live values for a particular continuation
--- All on stack for now.
--- Head element is the top of the stack (or just under the header).
--- Nothing means an empty slot.
--- Future possibilities include callee save registers (i.e. passing slots in register)
--- and heap memory (not sure if that's usefull at all though, but it may
--- be worth exploring the design space).
-
-continuationLabel :: Continuation (Either C_SRT CmmInfo) -> CLabel
-continuationLabel (Continuation _ l _ _ _) = l
-data Continuation info =
- Continuation
- info -- Left <=> Continuation created by the CPS
- -- Right <=> Function or Proc point
- CLabel -- Used to generate both info & entry labels
- CmmFormals -- Argument locals live on entry (C-- procedure params)
- Bool -- True <=> GC block so ignore stack size
- [BrokenBlock] -- Code, may be empty. The first block is
- -- the entry point. The order is otherwise initially
- -- unimportant, but at some point the code gen will
- -- fix the order.
-
- -- the BlockId of the first block does not give rise
- -- to a label. To jump to the first block in a Proc,
- -- use the appropriate CLabel.
-
-data ContinuationFormat
- = ContinuationFormat {
- continuation_formals :: CmmFormals,
- continuation_label :: Maybe CLabel, -- The label occupying the top slot
- continuation_frame_size :: WordOff, -- Total frame size in words (not including arguments)
- continuation_stack :: [Maybe LocalReg] -- local reg offsets from stack top
- }
-
--- A block can be a continuation of a call
--- A block can be a continuation of another block (w/ or w/o joins)
--- A block can be an entry to a function
-
------------------------------------------------------------------------------
-continuationToProc :: (WordOff, WordOff, [(CLabel, ContinuationFormat)])
- -> CmmReg
- -> [[[Unique]]]
- -> Continuation CmmInfo
- -> CmmTop
-continuationToProc (max_stack, update_frame_size, formats) stack_use uniques
- (Continuation info label formals _ blocks) =
- CmmProc info label formals (ListGraph blocks')
- where
- blocks' = concat $ zipWith3 continuationToProc' uniques blocks
- (True : repeat False)
- curr_format = maybe unknown_block id $ lookup label formats
- unknown_block = panic "unknown BlockId in continuationToProc"
- curr_stack = continuation_frame_size curr_format
- arg_stack = argumentsSize localRegType formals
-
- param_stmts :: [CmmStmt]
- param_stmts = function_entry curr_format
-
- gc_stmts :: [CmmStmt]
- gc_stmts =
- assign_gc_stack_use stack_use arg_stack (max_stack - curr_stack)
-
- update_stmts :: [CmmStmt]
- update_stmts =
- case info of
- CmmInfo _ (Just (UpdateFrame target args)) _ ->
- pack_frame curr_stack update_frame_size (Just target) (map Just args) ++
- adjust_sp_reg (curr_stack - update_frame_size)
- CmmInfo _ Nothing _ -> []
-
- continuationToProc' :: [[Unique]]
- -> BrokenBlock
- -> Bool
- -> [CmmBasicBlock]
- continuationToProc' uniques (BrokenBlock ident entry stmts _ exit) is_entry =
- prefix_blocks ++ [BasicBlock ident fixed_main_stmts] ++ concat new_blocks
- where
- prefix_blocks =
- if is_entry
- then [BasicBlock
- (BlockId prefix_unique)
- (param_stmts ++ [CmmBranch ident])]
- else []
-
- (prefix_unique : call_uniques) : new_block_uniques = uniques
- toCLabel = mkReturnPtLabel . getUnique
-
- block_for_branch :: Unique -> BlockId -> (BlockId, [CmmBasicBlock])
- block_for_branch unique next
- -- branches to the current function don't have to jump
- | (mkReturnPtLabel $ getUnique next) == label
- = (next, [])
-
- -- branches to any other function have to jump
- | (Just cont_format) <- lookup (toCLabel next) formats
- = let
- new_next = BlockId unique
- cont_stack = continuation_frame_size cont_format
- arguments = map formal_to_actual (continuation_formals cont_format)
- in (new_next,
- [BasicBlock new_next $
- pack_continuation curr_format cont_format ++
- tail_call (curr_stack - cont_stack)
- (CmmLit $ CmmLabel $ toCLabel next)
- arguments])
-
- -- branches to blocks in the current function don't have to jump
- | otherwise
- = (next, [])
-
- -- Wrapper for block_for_branch for when the target
- -- is inside a 'Maybe'.
- block_for_branch' :: Unique -> Maybe BlockId -> (Maybe BlockId, [CmmBasicBlock])
- block_for_branch' _ Nothing = (Nothing, [])
- block_for_branch' unique (Just next) = (Just new_next, new_blocks)
- where (new_next, new_blocks) = block_for_branch unique next
-
- -- If the target of a switch, branch or cond branch becomes a proc point
- -- then we have to make a new block what will then *jump* to the original target.
- proc_point_fix unique (CmmCondBranch test target)
- = (CmmCondBranch test new_target, new_blocks)
- where (new_target, new_blocks) = block_for_branch (head unique) target
- proc_point_fix unique (CmmSwitch test targets)
- = (CmmSwitch test new_targets, concat new_blocks)
- where (new_targets, new_blocks) =
- unzip $ zipWith block_for_branch' unique targets
- proc_point_fix unique (CmmBranch target)
- = (CmmBranch new_target, new_blocks)
- where (new_target, new_blocks) = block_for_branch (head unique) target
- proc_point_fix _ other = (other, [])
-
- (fixed_main_stmts, new_blocks) = unzip $ zipWith proc_point_fix new_block_uniques main_stmts
- main_stmts =
- case entry of
- FunctionEntry _ _ _ ->
- -- The statements for an update frame must come /after/
- -- the GC check that was added at the beginning of the
- -- CPS pass. So we have do edit the statements a bit.
- -- This depends on the knowledge that the statements in
- -- the first block are only the GC check. That's
- -- fragile but it works for now.
- gc_stmts ++ stmts ++ update_stmts ++ postfix_stmts
- ControlEntry -> stmts ++ postfix_stmts
- ContinuationEntry _ _ _ -> stmts ++ postfix_stmts
- postfix_stmts = case exit of
- -- Branches and switches may get modified by proc_point_fix
- FinalBranch next -> [CmmBranch next]
- FinalSwitch expr targets -> [CmmSwitch expr targets]
-
- -- A return is a tail call to the stack top
- FinalReturn arguments ->
- tail_call curr_stack
- (entryCode (CmmLoad (CmmReg spReg) bWord))
- arguments
-
- -- A tail call
- FinalJump target arguments ->
- tail_call curr_stack target arguments
-
- -- A regular Cmm function call
- FinalCall next (CmmCallee target CmmCallConv)
- _ arguments _ _ _ ->
- pack_continuation curr_format cont_format ++
- tail_call (curr_stack - cont_stack)
- target arguments
- where
- cont_format = maybe unknown_block id $
- lookup (mkReturnPtLabel $ getUnique next) formats
- cont_stack = continuation_frame_size cont_format
-
- -- A safe foreign call
- FinalCall _ (CmmCallee target conv)
- results arguments _ _ _ ->
- target_stmts ++
- foreignCall call_uniques' (CmmCallee new_target conv)
- results arguments
- where
- (call_uniques', target_stmts, new_target) =
- maybeAssignTemp call_uniques target
-
- -- A safe prim call
- FinalCall _ (CmmPrim target)
- results arguments _ _ _ ->
- foreignCall call_uniques (CmmPrim target)
- results arguments
-
-formal_to_actual :: LocalReg -> CmmHinted CmmExpr
-formal_to_actual reg = CmmHinted (CmmReg (CmmLocal reg)) NoHint
-
-foreignCall :: [Unique] -> CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> [CmmStmt]
-foreignCall uniques call results arguments =
- arg_stmts ++
- saveThreadState ++
- caller_save ++
- [CmmCall (CmmCallee suspendThread CCallConv)
- [ CmmHinted id AddrHint ]
- [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
- -- XXX: allow for interruptible suspension
- , CmmHinted (CmmLit (CmmInt 0 wordWidth)) NoHint ]
- CmmUnsafe
- CmmMayReturn,
- CmmCall call results new_args CmmUnsafe CmmMayReturn,
- CmmCall (CmmCallee resumeThread CCallConv)
- [ CmmHinted new_base AddrHint ]
- [ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
- CmmUnsafe
- CmmMayReturn,
- -- Assign the result to BaseReg: we
- -- might now have a different Capability!
- CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))] ++
- caller_load ++
- loadThreadState tso_unique ++
- [CmmJump (CmmReg spReg) (map (formal_to_actual . hintlessCmm) results)]
- where
- (_, arg_stmts, new_args) =
- loadArgsIntoTemps argument_uniques arguments
- (caller_save, caller_load) =
- callerSaveVolatileRegs (Just [{-only system regs-}])
- new_base = LocalReg base_unique (cmmRegType (CmmGlobal BaseReg))
- id = LocalReg id_unique bWord
- tso_unique : base_unique : id_unique : argument_uniques = uniques
-
--- -----------------------------------------------------------------------------
--- Save/restore the thread state in the TSO
-
-suspendThread, resumeThread :: CmmExpr
-suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
-resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
-
--- This stuff can't be done in suspendThread/resumeThread, because it
--- refers to global registers which aren't available in the C world.
-
-saveThreadState :: [CmmStmt]
-saveThreadState =
- -- CurrentTSO->sp = Sp;
- [CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp,
- closeNursery] ++
- -- and save the current cost centre stack in the TSO when profiling:
- if opt_SccProfilingOn
- then [CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS]
- else []
-
- -- CurrentNursery->free = Hp+1;
-closeNursery :: CmmStmt
-closeNursery = CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
-
-loadThreadState :: Unique -> [CmmStmt]
-loadThreadState tso_unique =
- [
- -- tso = CurrentTSO;
- CmmAssign (CmmLocal tso) stgCurrentTSO,
- -- Sp = tso->sp;
- CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
- bWord),
- -- SpLim = tso->stack + RESERVED_STACK_WORDS;
- CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
- rESERVED_STACK_WORDS)
- ] ++
- openNursery ++
- -- and load the current cost centre stack from the TSO when profiling:
- if opt_SccProfilingOn
- then [CmmStore curCCSAddr
- (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord)]
- else []
- where tso = LocalReg tso_unique bWord -- TODO FIXME NOW
-
-
-openNursery :: [CmmStmt]
-openNursery = [
- -- Hp = CurrentNursery->free - 1;
- CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)),
-
- -- HpLim = CurrentNursery->start +
- -- CurrentNursery->blocks*BLOCK_SIZE_W - 1;
- CmmAssign hpLim
- (cmmOffsetExpr
- (CmmLoad nursery_bdescr_start bWord)
- (cmmOffset
- (CmmMachOp mo_wordMul [
- CmmMachOp (MO_SS_Conv W32 wordWidth)
- [CmmLoad nursery_bdescr_blocks b32],
- CmmLit (mkIntCLit bLOCK_SIZE)
- ])
- (-1)
- )
- )
- ]
-
-
-nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
-nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
-nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
-nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
-
-tso_SP, tso_STACK, tso_CCCS :: ByteOff
-tso_SP = tsoFieldB undefined --oFFSET_StgTSO_sp
-tso_STACK = tsoFieldB undefined --oFFSET_StgTSO_stack
-tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
-
--- The TSO struct has a variable header, and an optional StgTSOProfInfo in
--- the middle. The fields we're interested in are after the StgTSOProfInfo.
-tsoFieldB :: ByteOff -> ByteOff
-tsoFieldB off
- | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
- | otherwise = off + fixedHdrSize * wORD_SIZE
-
-tsoProfFieldB :: ByteOff -> ByteOff
-tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
-
-stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
-stgSp = CmmReg sp
-stgHp = CmmReg hp
-stgCurrentTSO = CmmReg currentTSO
-stgCurrentNursery = CmmReg currentNursery
-
-sp, spLim, hp, hpLim, currentTSO, currentNursery :: CmmReg
-sp = CmmGlobal Sp
-spLim = CmmGlobal SpLim
-hp = CmmGlobal Hp
-hpLim = CmmGlobal HpLim
-currentTSO = CmmGlobal CurrentTSO
-currentNursery = CmmGlobal CurrentNursery
-
------------------------------------------------------------------------------
--- Functions that generate CmmStmt sequences
--- for packing/unpacking continuations
--- and entering/exiting functions
-
-tail_call :: WordOff -> CmmExpr -> HintedCmmActuals -> [CmmStmt]
-tail_call spRel target arguments
- = store_arguments ++ adjust_sp_reg spRel ++ jump where
- store_arguments =
- [stack_put spRel expr offset
- | ((CmmHinted expr _), StackParam offset) <- argument_formats] ++
- [global_put expr global
- | ((CmmHinted expr _), RegisterParam global) <- argument_formats]
- jump = [CmmJump target arguments]
-
- argument_formats = assignArguments (cmmExprType . hintlessCmm) arguments
-
-adjust_sp_reg :: Int -> [CmmStmt]
-adjust_sp_reg spRel =
- if spRel == 0
- then []
- else [CmmAssign spReg (CmmRegOff spReg (spRel*wORD_SIZE))]
-
-assign_gc_stack_use :: CmmReg -> Int -> Int -> [CmmStmt]
-assign_gc_stack_use stack_use arg_stack max_frame_size =
- if max_frame_size > arg_stack
- then [CmmAssign stack_use (CmmRegOff spReg (-max_frame_size*wORD_SIZE))]
- else [CmmAssign stack_use (CmmReg spLimReg)]
- -- Trick the optimizer into eliminating the branch for us
-
-{-
-UNUSED 2008-12-29
-
-gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
-gc_stack_check gc_block max_frame_size
- = check_stack_limit where
- check_stack_limit = [
- CmmCondBranch
- (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
- [CmmRegOff spReg (-max_frame_size*wORD_SIZE),
- CmmReg spLimReg])
- gc_block]
--}
-
-pack_continuation :: ContinuationFormat -- ^ The current format
- -> ContinuationFormat -- ^ The return point format
- -> [CmmStmt]
-pack_continuation (ContinuationFormat _ curr_id curr_frame_size _)
- (ContinuationFormat _ cont_id cont_frame_size live_regs)
- = pack_frame curr_frame_size cont_frame_size maybe_header continuation_args
- where
- continuation_args = map (maybe Nothing (Just . CmmReg . CmmLocal))
- live_regs
- needs_header_set =
- case (curr_id, cont_id) of
- (Just x, Just y) -> x /= y
- _ -> isJust cont_id
-
- maybe_header = if needs_header_set
- then maybe Nothing (Just . CmmLit . CmmLabel . entryLblToInfoLbl) cont_id
- else Nothing
-
-pack_frame :: WordOff -- ^ Current frame size
- -> WordOff -- ^ Next frame size
- -> Maybe CmmExpr -- ^ Next frame header if any
- -> [Maybe CmmExpr] -- ^ Next frame data
- -> [CmmStmt]
-pack_frame curr_frame_size next_frame_size next_frame_header frame_args =
- store_live_values ++ set_stack_header
- where
- -- TODO: only save variables when actually needed
- -- (may be handled by latter pass)
- store_live_values =
- [stack_put spRel expr offset
- | (expr, offset) <- cont_offsets]
- set_stack_header =
- case next_frame_header of
- Nothing -> []
- Just expr -> [stack_put spRel expr 0]
-
- -- TODO: factor with function_entry and CmmInfo.hs(?)
- cont_offsets = mkOffsets label_size frame_args
-
- label_size = 1 :: WordOff
-
- mkOffsets _ [] = []
- mkOffsets size (Nothing:exprs) = mkOffsets (size+1) exprs
- mkOffsets size (Just expr:exprs) = (expr, size):mkOffsets (size + width) exprs
- where
- width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
- -- TODO: it would be better if we had a machRepWordWidth
-
- spRel = curr_frame_size - next_frame_size
-
-
--- Lazy adjustment of stack headers assumes all blocks
--- that could branch to eachother (i.e. control blocks)
--- have the same stack format (this causes a problem
--- only for proc-point).
-function_entry :: ContinuationFormat -> [CmmStmt]
-function_entry (ContinuationFormat formals _ _ live_regs)
- = load_live_values ++ load_args where
- -- TODO: only save variables when actually needed
- -- (may be handled by latter pass)
- load_live_values =
- [stack_get 0 reg offset
- | (reg, offset) <- curr_offsets]
- load_args =
- [stack_get 0 reg offset
- | (reg, StackParam offset) <- argument_formats] ++
- [global_get reg global
- | (reg, RegisterParam global) <- argument_formats]
-
- argument_formats = assignArguments (localRegType) formals
-
- -- TODO: eliminate copy/paste with pack_continuation
- curr_offsets = mkOffsets label_size live_regs
-
- label_size = 1 :: WordOff
-
- mkOffsets _ [] = []
- mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
- mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
- where
- width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
- -- TODO: it would be better if we had a machRepWordWidth
-
------------------------------------------------------------------------------
--- Section: Stack and argument register puts and gets
------------------------------------------------------------------------------
--- TODO: document
-
--- |Construct a 'CmmStmt' that will save a value on the stack
-stack_put :: WordOff -- ^ Offset from the real 'Sp' that 'offset'
- -- is relative to (added to offset)
- -> CmmExpr -- ^ What to store onto the stack
- -> WordOff -- ^ Where on the stack to store it
- -- (positive <=> higher addresses)
- -> CmmStmt
-stack_put spRel expr offset =
- CmmStore (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) expr
-
---------------------------------
--- |Construct a
-stack_get :: WordOff
- -> LocalReg
- -> WordOff
- -> CmmStmt
-stack_get spRel reg offset =
- CmmAssign (CmmLocal reg)
- (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
- (localRegType reg))
-global_put :: CmmExpr -> GlobalReg -> CmmStmt
-global_put expr global = CmmAssign (CmmGlobal global) expr
-global_get :: LocalReg -> GlobalReg -> CmmStmt
-global_get reg global = CmmAssign (CmmLocal reg) (CmmReg (CmmGlobal global))
+++ /dev/null
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
--- Norman likes local bindings
--- If this module lives on I'd like to get rid of this flag in due course
-
-module CmmCPSZ (
- -- | Converts C-- with full proceedures and parameters
- -- to a CPS transformed C-- with the stack made manifest.
- -- Well, sort of.
- protoCmmCPSZ
-) where
-
-import CLabel
-import Cmm
-import CmmBuildInfoTables
-import CmmCommonBlockElimZ
-import CmmProcPointZ
-import CmmSpillReload
-import CmmStackLayout
-import DFMonad
-import PprCmmZ()
-import ZipCfgCmmRep
-
-import DynFlags
-import ErrUtils
-import HscTypes
-import Data.Maybe
-import Control.Monad
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Outputable
-import StaticFlags
-
------------------------------------------------------------------------------
--- |Top level driver for the CPS pass
------------------------------------------------------------------------------
--- There are two complications here:
--- 1. We need to compile the procedures in two stages because we need
--- an analysis of the procedures to tell us what CAFs they use.
--- The first stage returns a map from procedure labels to CAFs,
--- along with a closure that will compute SRTs and attach them to
--- the compiled procedures.
--- The second stage is to combine the CAF information into a top-level
--- CAF environment mapping non-static closures to the CAFs they keep live,
--- then pass that environment to the closures returned in the first
--- stage of compilation.
--- 2. We need to thread the module's SRT around when the SRT tables
--- are computed for each procedure.
--- The SRT needs to be threaded because it is grown lazily.
-protoCmmCPSZ :: HscEnv -- Compilation env including
- -- dynamic flags: -dcmm-lint -ddump-cps-cmm
- -> (TopSRT, [CmmZ]) -- SRT table and accumulating list of compiled procs
- -> CmmZ -- Input C-- with Procedures
- -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C--
-protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) =
- do let dflags = hsc_dflags hsc_env
- showPass dflags "CPSZ"
- (cafEnvs, tops) <- liftM unzip $ mapM (cpsTop hsc_env) tops
- let topCAFEnv = mkTopCAFInfo (concat cafEnvs)
- (topSRT, tops) <- foldM (toTops hsc_env topCAFEnv) (topSRT, []) tops
- -- (topSRT, tops) <- foldM (\ z f -> f topCAFEnv z) (topSRT, []) toTops
- let cmms = Cmm (reverse (concat tops))
- dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr cmms)
- return (topSRT, cmms : rst)
-
-{- [Note global fuel]
-~~~~~~~~~~~~~~~~~~~~~
-The identity and the last pass are stored in
-mutable reference cells in an 'HscEnv' and are
-global to one compiler session.
--}
-
-cpsTop :: HscEnv -> CmmTopZ ->
- IO ([(CLabel, CAFSet)],
- [(CAFSet, CmmTopForInfoTables)])
-cpsTop _ p@(CmmData {}) = return ([], [(Map.empty, NoInfoTable p)])
-cpsTop hsc_env (CmmProc h l args (stackInfo@(entry_off, _), g)) =
- do
- dump Opt_D_dump_cmmz "Pre Proc Points Added" g
- let callPPs = callProcPoints g
- -- Why bother doing it this early?
- -- g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
- -- (dualLivenessWithInsertion callPPs) g
- -- g <- run $ insertLateReloads g -- Duplicate reloads just before uses
- -- g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
- -- (removeDeadAssignmentsAndReloads callPPs) g
- dump Opt_D_dump_cmmz "Pre common block elimination" g
- g <- return $ elimCommonBlocks g
- dump Opt_D_dump_cmmz "Post common block elimination" g
-
- ----------- Proc points -------------------
- procPoints <- run $ minimalProcPointSet callPPs g
- g <- run $ addProcPointProtocols callPPs procPoints g
- dump Opt_D_dump_cmmz "Post Proc Points Added" g
-
- ----------- Spills and reloads -------------------
- g <-
- -- pprTrace "pre Spills" (ppr g) $
- dual_rewrite Opt_D_dump_cmmz "spills and reloads"
- (dualLivenessWithInsertion procPoints) g
- -- Insert spills at defns; reloads at return points
- g <-
- -- pprTrace "pre insertLateReloads" (ppr g) $
- run $ insertLateReloads g -- Duplicate reloads just before uses
- dump Opt_D_dump_cmmz "Post late reloads" g
- g <-
- -- pprTrace "post insertLateReloads" (ppr g) $
- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination"
- (removeDeadAssignmentsAndReloads procPoints) g
- -- Remove redundant reloads (and any other redundant asst)
-
- ----------- Debug only: add code to put zero in dead stack slots----
- -- Debugging: stubbing slots on death can cause crashes early
- g <-
- -- trace "post dead-assign elim" $
- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g
-
-
- --------------- Stack layout ----------------
- slotEnv <- run $ liveSlotAnal g
- mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return ()
- -- cafEnv <- -- trace "post liveSlotAnal" $ run $ cafAnal g
- -- (cafEnv, slotEnv) <-
- -- -- trace "post print cafAnal" $
- -- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g
- slotEnv <- return $ extendEnvWithSafeForeignCalls liveSlotTransfers slotEnv g
- mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return ()
- let areaMap = layout procPoints slotEnv entry_off g
- mbpprTrace "areaMap" (ppr areaMap) $ return ()
-
- ------------ Manifest the the stack pointer --------
- g <- run $ manifestSP areaMap entry_off g
- dump Opt_D_dump_cmmz "after manifestSP" g
- -- UGH... manifestSP can require updates to the procPointMap.
- -- We can probably do something quicker here for the update...
-
- ------------- Split into separate procedures ------------
- procPointMap <- run $ procPointAnalysis procPoints g
- dump Opt_D_dump_cmmz "procpoint map" procPointMap
- gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap
- (CmmProc h l args (stackInfo, g))
- mapM_ (dump Opt_D_dump_cmmz "after splitting") gs
-
- ------------- More CAFs and foreign calls ------------
- cafEnv <- run $ cafAnal g
- cafEnv <- return $ extendEnvWithSafeForeignCalls cafTransfers cafEnv g
- let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs
- mbpprTrace "localCAFs" (ppr localCAFs) $ return ()
-
- gs <- liftM concat $ run $ foldM lowerSafeForeignCalls [] gs
- mapM_ (dump Opt_D_dump_cmmz "after lowerSafeForeignCalls") gs
-
- -- NO MORE GRAPH TRANSFORMATION AFTER HERE -- JUST MAKING INFOTABLES
- let gs' = map (setInfoTableStackMap slotEnv areaMap) gs
- mapM_ (dump Opt_D_dump_cmmz "after setInfoTableStackMap") gs'
- let gs'' = map (bundleCAFs cafEnv) gs'
- mapM_ (dump Opt_D_dump_cmmz "after bundleCAFs") gs''
- return (localCAFs, gs'')
- where dflags = hsc_dflags hsc_env
- mbpprTrace x y z = if dopt Opt_D_dump_cmmz dflags then pprTrace x y z else z
- dump f txt g = dumpIfSet_dyn dflags f txt (ppr g)
-
- run :: FuelMonad a -> IO a
- run = runFuelIO (hsc_OptFuel hsc_env)
-
- dual_rewrite flag txt pass g =
- do dump flag ("Pre " ++ txt) g
- g <- run $ pass g
- dump flag ("Post " ++ txt) $ g
- return g
-
--- This probably belongs in CmmBuildInfoTables?
--- We're just finishing the job here: once we know what CAFs are defined
--- in non-static closures, we can build the SRTs.
-toTops :: HscEnv -> Map CLabel CAFSet -> (TopSRT, [[CmmTopZ]])
- -> [(CAFSet, CmmTopForInfoTables)] -> IO (TopSRT, [[CmmTopZ]])
-
-toTops hsc_env topCAFEnv (topSRT, tops) gs =
- do let setSRT (topSRT, rst) g =
- do (topSRT, gs) <- setInfoTableSRT topCAFEnv topSRT g
- return (topSRT, gs : rst)
- (topSRT, gs') <- runFuelIO (hsc_OptFuel hsc_env) $ foldM setSRT (topSRT, []) gs
- gs' <- mapM finishInfoTables (concat gs')
- return (topSRT, concat gs' : tops)
#include "HsVersions.h"
-import Cmm
+import CmmExpr
import SMRep
-import ZipCfgCmmRep (Convention(..))
+import Cmm (Convention(..))
+import PprCmm ()
import Constants
import qualified Data.List as L
-module CmmCommonBlockElimZ
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+-- ToDo: remove
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
+module CmmCommonBlockElim
( elimCommonBlocks
)
where
import BlockId
+import Cmm
import CmmExpr
-import Prelude hiding (iterate, zip, unzip)
-import ZipCfg
-import ZipCfgCmmRep
+import Prelude hiding (iterate, succ, unzip, zip)
+import Compiler.Hoopl
import Data.Bits
import qualified Data.List as List
import Data.Word
elimCommonBlocks :: CmmGraph -> CmmGraph
elimCommonBlocks g =
upd_graph g . snd $ iterate common_block reset hashed_blocks
- (emptyUFM, emptyBlockEnv)
- where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorder_dfs g))
+ (emptyUFM, mapEmpty)
+ where hashed_blocks = map (\b -> (hash_block b, b)) (reverse (postorderDfs g))
reset (_, subst) = (emptyUFM, subst)
-- Iterate over the blocks until convergence
common_block (bmap, subst) (hash, b) =
case lookupUFM bmap hash of
Just bs -> case (List.find (eqBlockBodyWith (eqBid subst) b) bs,
- lookupBlockEnv subst bid) of
- (Just b', Nothing) -> addSubst b'
- (Just b', Just b'') | blockId b' /= b'' -> addSubst b'
+ mapLookup bid subst) of
+ (Just b', Nothing) -> addSubst b'
+ (Just b', Just b'') | entryLabel b' /= b'' -> addSubst b'
_ -> (False, (addToUFM bmap hash (b : bs), subst))
Nothing -> (False, (addToUFM bmap hash [b], subst))
- where bid = blockId b
- addSubst b' = my_trace "found new common block" (ppr (blockId b')) $
- (True, (bmap, extendBlockEnv subst bid (blockId b')))
+ where bid = entryLabel b
+ addSubst b' = my_trace "found new common block" (ppr (entryLabel b')) $
+ (True, (bmap, mapInsert bid (entryLabel b') subst))
-- Given the map ``subst'' from BlockId -> BlockId, we rewrite the graph.
upd_graph :: CmmGraph -> BidMap -> CmmGraph
-upd_graph g subst = map_nodes id middle last g
- where middle = mapExpDeepMiddle exp
- last l = last' (mapExpDeepLast exp l)
- last' (LastBranch bid) = LastBranch $ sub bid
- last' (LastCondBranch p t f) = cond p (sub t) (sub f)
- last' (LastCall t (Just bid) args res u) = LastCall t (Just $ sub bid) args res u
- last' l@(LastCall _ Nothing _ _ _) = l
- last' (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs
- cond p t f = if t == f then LastBranch t else LastCondBranch p t f
+upd_graph g subst = mapGraphNodes (id, middle, last) g
+ where middle = mapExpDeep exp
+ last l = last' (mapExpDeep exp l)
+ last' :: CmmNode O C -> CmmNode O C
+ last' (CmmBranch bid) = CmmBranch $ sub bid
+ last' (CmmCondBranch p t f) = cond p (sub t) (sub f)
+ last' (CmmCall t (Just bid) a r o) = CmmCall t (Just $ sub bid) a r o
+ last' l@(CmmCall _ Nothing _ _ _) = l
+ last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (sub bid) u i
+ last' (CmmSwitch e bs) = CmmSwitch e $ map (liftM sub) bs
+ cond p t f = if t == f then CmmBranch t else CmmCondBranch p t f
exp (CmmStackSlot (CallArea (Young id)) off) =
CmmStackSlot (CallArea (Young (sub id))) off
exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id))
-- The hashing is a bit arbitrary (the numbers are completely arbitrary),
-- but it should be fast and good enough.
hash_block :: CmmBlock -> Int
-hash_block (Block _ t) =
- fromIntegral (hash_tail t (0 :: Word32) .&. (0x7fffffff :: Word32))
+hash_block block =
+ fromIntegral (foldBlockNodesB3 (hash_fst, hash_mid, hash_lst) block (0 :: Word32) .&. (0x7fffffff :: Word32))
-- UniqFM doesn't like negative Ints
- where hash_mid (MidComment (FastString u _ _ _ _)) = cvt u
- hash_mid (MidAssign r e) = hash_reg r + hash_e e
- hash_mid (MidStore e e') = hash_e e + hash_e e'
- hash_mid (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as
+ where hash_fst _ h = h
+ hash_mid m h = hash_node m + h `shiftL` 1
+ hash_lst m h = hash_node m + h `shiftL` 1
+
+ hash_node :: CmmNode O x -> Word32
+ hash_node (CmmComment (FastString u _ _ _ _)) = cvt u
+ hash_node (CmmAssign r e) = hash_reg r + hash_e e
+ hash_node (CmmStore e e') = hash_e e + hash_e e'
+ hash_node (CmmUnsafeForeignCall t _ as) = hash_tgt t + hash_list hash_e as
+ hash_node (CmmBranch _) = 23 -- would be great to hash these properly
+ hash_node (CmmCondBranch p _ _) = hash_e p
+ hash_node (CmmCall e _ _ _ _) = hash_e e
+ hash_node (CmmForeignCall t _ _ _ _ _) = hash_tgt t
+ hash_node (CmmSwitch e _) = hash_e e
+
hash_reg :: CmmReg -> Word32
- hash_reg (CmmLocal l) = hash_local l
+ hash_reg (CmmLocal _) = 117
hash_reg (CmmGlobal _) = 19
- hash_local (LocalReg _ _) = 117
+
hash_e :: CmmExpr -> Word32
hash_e (CmmLit l) = hash_lit l
hash_e (CmmLoad e _) = 67 + hash_e e
hash_e (CmmReg r) = hash_reg r
- hash_e (CmmMachOp _ es) = hash_lst hash_e es -- pessimal - no operator check
+ hash_e (CmmMachOp _ es) = hash_list hash_e es -- pessimal - no operator check
hash_e (CmmRegOff r i) = hash_reg r + cvt i
hash_e (CmmStackSlot _ _) = 13
+
hash_lit :: CmmLit -> Word32
hash_lit (CmmInt i _) = fromInteger i
hash_lit (CmmFloat r _) = truncate r
hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i
hash_lit (CmmBlock _) = 191 -- ugh
hash_lit (CmmHighStackMark) = cvt 313
+
hash_tgt (ForeignTarget e _) = hash_e e
hash_tgt (PrimTarget _) = 31 -- lots of these
- hash_lst f = foldl (\z x -> f x + z) (0::Word32)
- hash_last (LastBranch _) = 23 -- would be great to hash these properly
- hash_last (LastCondBranch p _ _) = hash_e p
- hash_last (LastCall e _ _ _ _) = hash_e e
- hash_last (LastSwitch e _) = hash_e e
- hash_tail (ZLast LastExit) v = 29 + v `shiftL` 1
- hash_tail (ZLast (LastOther l)) v = hash_last l + (v `shiftL` 1)
- hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v `shiftL` 1))
+
+ hash_list f = foldl (\z x -> f x + z) (0::Word32)
+
cvt = fromInteger . toInteger
-- Utilities: equality and substitution on the graph.
eqBid :: BidMap -> BlockId -> BlockId -> Bool
eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid'
lookupBid :: BidMap -> BlockId -> BlockId
-lookupBid subst bid = case lookupBlockEnv subst bid of
+lookupBid subst bid = case mapLookup bid subst of
Just bid -> lookupBid subst bid
Nothing -> bid
-- Equality on the body of a block, modulo a function mapping block IDs to block IDs.
eqBlockBodyWith :: (BlockId -> BlockId -> Bool) -> CmmBlock -> CmmBlock -> Bool
-eqBlockBodyWith eqBid (Block _ t) (Block _ t') = eqTailWith eqBid t t'
-
-type CmmTail = ZTail Middle Last
-eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool
-eqTailWith eqBid (ZTail m t) (ZTail m' t') = m == m' && eqTailWith eqBid t t'
-eqTailWith _ (ZLast LastExit) (ZLast LastExit) = True
-eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid l l'
-eqTailWith _ _ _ = False
-
-eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool
-eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2
-eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) =
+eqBlockBodyWith eqBid block block' = middles == middles' && eqLastWith eqBid last last'
+ where (_, middles , JustC last :: MaybeC C (CmmNode O C)) = blockToNodeList block
+ (_, middles', JustC last' :: MaybeC C (CmmNode O C)) = blockToNodeList block'
+
+eqLastWith :: (BlockId -> BlockId -> Bool) -> CmmNode O C -> CmmNode O C -> Bool
+eqLastWith eqBid (CmmBranch bid1) (CmmBranch bid2) = eqBid bid1 bid2
+eqLastWith eqBid (CmmCondBranch c1 t1 f1) (CmmCondBranch c2 t2 f2) =
c1 == c2 && eqBid t1 t2 && eqBid f1 f2
-eqLastWith eqBid (LastCall t1 c1 a1 r1 u1) (LastCall t2 c2 a2 r2 u2) =
+eqLastWith eqBid (CmmCall t1 c1 a1 r1 u1) (CmmCall t2 c2 a2 r2 u2) =
t1 == t2 && eqMaybeWith eqBid c1 c2 && a1 == a2 && r1 == r2 && u1 == u2
-eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) =
- e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2
+eqLastWith eqBid (CmmSwitch e1 bs1) (CmmSwitch e2 bs2) =
+ e1 == e2 && eqListWith (eqMaybeWith eqBid) bs1 bs2
eqLastWith _ _ _ = False
-eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
-eqLstWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
+eqListWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool
+eqListWith eltEq es es' = all (uncurry eltEq) (List.zip es es')
eqMaybeWith :: (a -> b -> Bool) -> Maybe a -> Maybe b -> Bool
eqMaybeWith eltEq (Just e) (Just e') = eltEq e e'
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations -fno-warn-incomplete-patterns #-}
module CmmContFlowOpt
- ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ
- , branchChainElimZ, removeUnreachableBlocksZ, predMap
- , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs
+ ( runCmmOpts, oldCmmCfgOpts, cmmCfgOpts
+ , branchChainElim, removeUnreachableBlocks, predMap
+ , replaceLabels, replaceBranches, runCmmContFlowOpts
)
where
import BlockId
import Cmm
-import CmmTx
-import qualified ZipCfg as G
-import ZipCfg
-import ZipCfgCmmRep
+import CmmDecl
+import CmmExpr
+import qualified OldCmm as Old
import Maybes
+import Compiler.Hoopl
import Control.Monad
import Outputable
-import Prelude hiding (unzip, zip)
+import Prelude hiding (succ, unzip, zip)
import Util
------------------------------------
-runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ]
-runCmmContFlowOptsZs prog
- = [ runTx (runCmmOpts cmmCfgOptsZ) cmm_top
- | cmm_top <- prog ]
-
-cmmCfgOpts :: Tx (ListGraph CmmStmt)
-cmmCfgOptsZ :: Tx (a, CmmGraph)
-
-cmmCfgOpts = branchChainElim -- boring, but will get more exciting later
-cmmCfgOptsZ g =
- optGraph
- (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g
+runCmmContFlowOpts :: Cmm -> Cmm
+runCmmContFlowOpts prog = runCmmOpts cmmCfgOpts prog
+
+oldCmmCfgOpts :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
+cmmCfgOpts :: CmmGraph -> CmmGraph
+
+oldCmmCfgOpts = oldBranchChainElim -- boring, but will get more exciting later
+cmmCfgOpts =
+ removeUnreachableBlocks . blockConcat . branchChainElim
-- Here branchChainElim can ultimately be replaced
-- with a more exciting combination of optimisations
-runCmmOpts :: Tx g -> Tx (GenCmm d h g)
+runCmmOpts :: (g -> g) -> GenCmm d h g -> GenCmm d h g
-- Lifts a transformer on a single graph to one on the whole program
runCmmOpts opt = mapProcs (optProc opt)
-optProc :: Tx g -> Tx (GenCmmTop d h g)
-optProc _ top@(CmmData {}) = noTx top
-optProc opt (CmmProc info lbl formals g) =
- fmap (CmmProc info lbl formals) (opt g)
-
-optGraph :: Tx g -> Tx (a, g)
-optGraph opt (a, g) = fmap (\g' -> (a, g')) (opt g)
+optProc :: (g -> g) -> GenCmmTop d h g -> GenCmmTop d h g
+optProc _ top@(CmmData {}) = top
+optProc opt (CmmProc info lbl g) = CmmProc info lbl (opt g)
------------------------------------
-mapProcs :: Tx (GenCmmTop d h s) -> Tx (GenCmm d h s)
-mapProcs f (Cmm tops) = fmap Cmm (mapTx f tops)
+mapProcs :: (GenCmmTop d h s -> GenCmmTop d h s) -> GenCmm d h s -> GenCmm d h s
+mapProcs f (Cmm tops) = Cmm (map f tops)
----------------------------------------------------------------
-branchChainElim :: Tx (ListGraph CmmStmt)
+oldBranchChainElim :: Old.ListGraph Old.CmmStmt -> Old.ListGraph Old.CmmStmt
-- If L is not captured in an instruction, we can remove any
-- basic block of the form L: goto L', and replace L with L' everywhere else.
-- How does L get captured? In a CallArea.
-branchChainElim (ListGraph blocks)
+oldBranchChainElim (Old.ListGraph blocks)
| null lone_branch_blocks -- No blocks to remove
- = noTx (ListGraph blocks)
+ = Old.ListGraph blocks
| otherwise
- = aTx (ListGraph new_blocks)
+ = Old.ListGraph new_blocks
where
(lone_branch_blocks, others) = partitionWith isLoneBranch blocks
new_blocks = map (replaceLabels env) others
env = mkClosureBlockEnv lone_branch_blocks
-isLoneBranch :: CmmBasicBlock -> Either (BlockId, BlockId) CmmBasicBlock
-isLoneBranch (BasicBlock id [CmmBranch target]) | id /= target = Left (id, target)
-isLoneBranch other_block = Right other_block
- -- An infinite loop is not a link in a branch chain!
+ isLoneBranch :: Old.CmmBasicBlock -> Either (BlockId, BlockId) Old.CmmBasicBlock
+ isLoneBranch (Old.BasicBlock id [Old.CmmBranch target]) | id /= target = Left (id, target)
+ isLoneBranch other_block = Right other_block
+ -- An infinite loop is not a link in a branch chain!
-replaceLabels :: BlockEnv BlockId -> CmmBasicBlock -> CmmBasicBlock
-replaceLabels env (BasicBlock id stmts)
- = BasicBlock id (map replace stmts)
- where
- replace (CmmBranch id) = CmmBranch (lookup id)
- replace (CmmCondBranch e id) = CmmCondBranch e (lookup id)
- replace (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
- replace other_stmt = other_stmt
+ replaceLabels :: BlockEnv BlockId -> Old.CmmBasicBlock -> Old.CmmBasicBlock
+ replaceLabels env (Old.BasicBlock id stmts)
+ = Old.BasicBlock id (map replace stmts)
+ where
+ replace (Old.CmmBranch id) = Old.CmmBranch (lookup id)
+ replace (Old.CmmCondBranch e id) = Old.CmmCondBranch e (lookup id)
+ replace (Old.CmmSwitch e tbl) = Old.CmmSwitch e (map (fmap lookup) tbl)
+ replace other_stmt = other_stmt
+
+ lookup id = mapLookup id env `orElse` id
- lookup id = lookupBlockEnv env id `orElse` id
----------------------------------------------------------------
-branchChainElimZ :: Tx CmmGraph
+branchChainElim :: CmmGraph -> CmmGraph
-- Remove any basic block of the form L: goto L',
-- and replace L with L' everywhere else,
-- unless L is the successor of a call instruction and L'
-- JD isn't quite sure when it's safe to share continuations for different
-- function calls -- have to think about where the SP will be,
-- so we'll table that problem for now by leaving all call successors alone.
-branchChainElimZ g@(G.LGraph eid _)
+branchChainElim g
| null lone_branch_blocks -- No blocks to remove
- = noTx g
+ = g
| otherwise
- = aTx $ replaceLabelsZ env $ G.of_block_list eid (self_branches ++ others)
+ = replaceLabels env $ ofBlockList (g_entry g) (self_branches ++ others)
where
- blocks = G.to_block_list g
- (lone_branch_blocks, others) = partitionWith isLoneBranchZ blocks
- env = mkClosureBlockEnvZ lone_branch_blocks
+ blocks = toBlockList g
+ (lone_branch_blocks, others) = partitionWith isLoneBranch blocks
+ env = mkClosureBlockEnv lone_branch_blocks
self_branches =
let loop_to (id, _) =
if lookup id == id then
- Just (G.Block id (G.ZLast (G.mkBranchNode id)))
+ Just $ blockOfNodeList (JustC (CmmEntry id), [], JustC (mkBranchNode id))
else
Nothing
in mapMaybe loop_to lone_branch_blocks
- lookup id = lookupBlockEnv env id `orElse` id
+ lookup id = mapLookup id env `orElse` id
call_succs = foldl add emptyBlockSet blocks
- where add succs b =
- case G.last (G.unzip b) of
- LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet succs k
- _ -> succs
- isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
- isLoneBranchZ (G.Block id (G.ZLast (G.LastOther (LastBranch target))))
- | id /= target && not (elemBlockSet id call_succs) = Left (id,target)
- isLoneBranchZ other = Right other
+ where add :: BlockSet -> CmmBlock -> BlockSet
+ add succs b =
+ case lastNode b of
+ (CmmCall _ (Just k) _ _ _) -> setInsert k succs
+ (CmmForeignCall {succ=k}) -> setInsert k succs
+ _ -> succs
+ isLoneBranch :: CmmBlock -> Either (BlockId, BlockId) CmmBlock
+ isLoneBranch block | (JustC (CmmEntry id), [], JustC (CmmBranch target)) <- blockToNodeList block,
+ id /= target && not (setMember id call_succs)
+ = Left (id,target)
+ isLoneBranch other = Right other
-- An infinite loop is not a link in a branch chain!
-maybeReplaceLabels :: (Last -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
+maybeReplaceLabels :: (CmmNode O C -> Bool) -> BlockEnv BlockId -> CmmGraph -> CmmGraph
maybeReplaceLabels lpred env =
- replace_eid . G.map_nodes id middle last
+ replace_eid . mapGraphNodes (id, middle, last)
where
- replace_eid (G.LGraph eid blocks) = G.LGraph (lookup eid) blocks
- middle = mapExpDeepMiddle exp
- last l = if lpred l then mapExpDeepLast exp (last' l) else l
- last' (LastBranch bid) = LastBranch (lookup bid)
- last' (LastCondBranch p t f) = LastCondBranch p (lookup t) (lookup f)
- last' (LastSwitch e arms) = LastSwitch e (map (liftM lookup) arms)
- last' (LastCall t k a res r) = LastCall t (liftM lookup k) a res r
- exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
- exp (CmmStackSlot (CallArea (Young id)) i) =
- CmmStackSlot (CallArea (Young (lookup id))) i
- exp e = e
- lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id
-
-replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph
-replaceLabelsZ = maybeReplaceLabels (const True)
-
--- replaceBranchLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
--- replaceBranchLabels env g@(LGraph _ _) = maybeReplaceLabels lpred env g
--- where lpred (LastBranch _) = True
--- lpred _ = False
+ replace_eid g = g {g_entry = lookup (g_entry g)}
+ lookup id = fmap lookup (mapLookup id env) `orElse` id
+
+ middle = mapExpDeep exp
+ last l = if lpred l then mapExpDeep exp (last' l) else l
+ last' :: CmmNode O C -> CmmNode O C
+ last' (CmmBranch bid) = CmmBranch (lookup bid)
+ last' (CmmCondBranch p t f) = CmmCondBranch p (lookup t) (lookup f)
+ last' (CmmSwitch e arms) = CmmSwitch e (map (liftM lookup) arms)
+ last' (CmmCall t k a res r) = CmmCall t (liftM lookup k) a res r
+ last' (CmmForeignCall t r a bid u i) = CmmForeignCall t r a (lookup bid) u i
+
+ exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid))
+ exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i
+ exp e = e
+
+
+replaceLabels :: BlockEnv BlockId -> CmmGraph -> CmmGraph
+replaceLabels = maybeReplaceLabels (const True)
replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph
-replaceBranches env g = map_nodes id id last g
+replaceBranches env g = mapGraphNodes (id, id, last) g
where
- last (LastBranch id) = LastBranch (lookup id)
- last (LastCondBranch e ti fi) = LastCondBranch e (lookup ti) (lookup fi)
- last (LastSwitch e tbl) = LastSwitch e (map (fmap lookup) tbl)
- last l@(LastCall {}) = l
- lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id
+ last :: CmmNode O C -> CmmNode O C
+ last (CmmBranch id) = CmmBranch (lookup id)
+ last (CmmCondBranch e ti fi) = CmmCondBranch e (lookup ti) (lookup fi)
+ last (CmmSwitch e tbl) = CmmSwitch e (map (fmap lookup) tbl)
+ last l@(CmmCall {}) = l
+ last l@(CmmForeignCall {}) = l
+ lookup id = fmap lookup (mapLookup id env) `orElse` id
----------------------------------------------------------------
-- Build a map from a block to its set of predecessors. Very useful.
-predMap :: G.LastNode l => G.LGraph m l -> BlockEnv BlockSet
-predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges
- where add_preds b env = foldl (add b) env (G.succs b)
- add (G.Block bid _) env b' =
- extendBlockEnv env b' $
- extendBlockSet (lookupBlockEnv env b' `orElse` emptyBlockSet) bid
+predMap :: [CmmBlock] -> BlockEnv BlockSet
+predMap blocks = foldr add_preds mapEmpty blocks -- find the back edges
+ where add_preds block env = foldl (add (entryLabel block)) env (successors block)
+ add bid env b' =
+ mapInsert b' (setInsert bid (mapLookup b' env `orElse` setEmpty)) env
----------------------------------------------------------------
-- If a block B branches to a label L, L is not the entry block,
-- and L has no other predecessors,
-- then we can splice the block starting with L onto the end of B.
--- Because this optimization can be inhibited by unreachable blocks,
--- we first take a pass to drops unreachable blocks.
-- Order matters, so we work bottom up (reverse postorder DFS).
+-- This optimization can be inhibited by unreachable blocks, but
+-- the reverse postorder DFS returns only reachable blocks.
--
-- To ensure correctness, we have to make sure that the BlockId of the block
-- we are about to eliminate is not named in another instruction.
--
-- Note: This optimization does _not_ subsume branch chain elimination.
-blockConcatZ :: Tx CmmGraph
-blockConcatZ = removeUnreachableBlocksZ `seqTx` blockConcatZ'
-blockConcatZ' :: Tx CmmGraph
-blockConcatZ' g@(G.LGraph eid blocks) =
- tx $ replaceLabelsZ concatMap $ G.LGraph eid blocks'
- where (changed, blocks', concatMap) =
- foldr maybe_concat (False, blocks, emptyBlockEnv) $ G.postorder_dfs g
- maybe_concat b@(G.Block bid _) (changed, blocks', concatMap) =
- let unchanged = (changed, extendBlockEnv blocks' bid b, concatMap)
- in case G.goto_end $ G.unzip b of
- (h, G.LastOther (LastBranch b')) ->
+blockConcat :: CmmGraph -> CmmGraph
+blockConcat g@(CmmGraph {g_entry=eid}) =
+ replaceLabels concatMap $ ofBlockMap (g_entry g) blocks'
+ where blocks = postorderDfs g
+ (blocks', concatMap) =
+ foldr maybe_concat (toBlockMap g, mapEmpty) $ blocks
+ maybe_concat :: CmmBlock -> (LabelMap CmmBlock, LabelMap Label) -> (LabelMap CmmBlock, LabelMap Label)
+ maybe_concat b unchanged@(blocks', concatMap) =
+ let bid = entryLabel b
+ in case blockToNodeList b of
+ (JustC h, m, JustC (CmmBranch b')) ->
if canConcatWith b' then
- (True, extendBlockEnv blocks' bid $ splice blocks' h b',
- extendBlockEnv concatMap b' bid)
+ (mapInsert bid (splice blocks' h m b') blocks',
+ mapInsert b' bid concatMap)
else unchanged
_ -> unchanged
- num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0
+ num_preds bid = liftM setSize (mapLookup bid backEdges) `orElse` 0
canConcatWith b' = b' /= eid && num_preds b' == 1
- backEdges = predMap g
- splice blocks' h bid' =
- case lookupBlockEnv blocks' bid' of
- Just (G.Block _ t) -> G.zip $ G.ZBlock h t
+ backEdges = predMap blocks
+ splice :: forall map n e x.
+ IsMap map =>
+ map (Block n e x) -> n C O -> [n O O] -> KeyOf map -> Block n C x
+ splice blocks' h m bid' =
+ case mapLookup bid' blocks' of
Nothing -> panic "unknown successor block"
- tx = if changed then aTx else noTx
+ Just block | (_, m', l') <- blockToNodeList block -> blockOfNodeList (JustC h, (m ++ m'), l')
----------------------------------------------------------------
mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId
-mkClosureBlockEnv blocks = mkBlockEnv $ map follow blocks
- where singleEnv = mkBlockEnv blocks
- follow (id, next) = (id, endChain id next)
- endChain orig id = case lookupBlockEnv singleEnv id of
- Just id' | id /= orig -> endChain orig id'
- _ -> id
-mkClosureBlockEnvZ :: [(BlockId, BlockId)] -> BlockEnv BlockId
-mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks
- where singleEnv = mkBlockEnv blocks
+mkClosureBlockEnv blocks = mapFromList $ map follow blocks
+ where singleEnv = mapFromList blocks :: BlockEnv BlockId
follow (id, next) = (id, endChain id next)
- endChain orig id = case lookupBlockEnv singleEnv id of
+ endChain orig id = case mapLookup id singleEnv of
Just id' | id /= orig -> endChain orig id'
_ -> id
----------------------------------------------------------------
-removeUnreachableBlocksZ :: Tx CmmGraph
-removeUnreachableBlocksZ g@(G.LGraph id blocks) =
- if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id blocks'
- else noTx g
- where blocks' = G.postorder_dfs g
+removeUnreachableBlocks :: CmmGraph -> CmmGraph
+removeUnreachableBlocks g =
+ if length blocks < mapSize (toBlockMap g) then ofBlockList (g_entry g) blocks
+ else g
+ where blocks = postorderDfs g
-{-# LANGUAGE PatternGuards #-}
+{-# LANGUAGE GADTs #-}
+-- ToDo: remove
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
module CmmCvt
( cmmToZgraph, cmmOfZgraph )
import BlockId
import Cmm
-import MkZipCfgCmm hiding (CmmGraph)
-import ZipCfgCmmRep -- imported for reverse conversion
-import CmmZipUtil
-import PprCmm()
-import qualified ZipCfg as G
+import CmmDecl
+import CmmExpr
+import MkGraph
+import qualified OldCmm as Old
+import OldPprCmm ()
-import FastString
+import Compiler.Hoopl hiding ((<*>), mkLabel, mkBranch)
import Control.Monad
+import Data.Maybe
+import Maybes
import Outputable
import UniqSupply
-cmmToZgraph :: GenCmm d h (ListGraph CmmStmt) -> UniqSM (GenCmm d h (CmmStackInfo, CmmGraph))
-cmmOfZgraph :: GenCmm d h (CmmStackInfo, CmmGraph) -> GenCmm d h (ListGraph CmmStmt)
+cmmToZgraph :: Old.Cmm -> UniqSM Cmm
+cmmOfZgraph :: Cmm -> Old.Cmm
cmmToZgraph (Cmm tops) = liftM Cmm $ mapM mapTop tops
- where mapTop (CmmProc h l args g) =
- toZgraph (showSDoc $ ppr l) args g >>= return . CmmProc h l args
+ where mapTop (CmmProc (Old.CmmInfo _ _ info_tbl) l g) =
+ do (stack_info, g) <- toZgraph (showSDoc $ ppr l) g
+ return $ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) l g
mapTop (CmmData s ds) = return $ CmmData s ds
-cmmOfZgraph = cmmMapGraph (ofZgraph . snd)
+cmmOfZgraph (Cmm tops) = Cmm $ map mapTop tops
+ where mapTop (CmmProc h l g) = CmmProc (Old.CmmInfo Nothing Nothing (info_tbl h)) l (ofZgraph g)
+ mapTop (CmmData s ds) = CmmData s ds
-toZgraph :: String -> CmmFormals -> ListGraph CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
-toZgraph _ _ (ListGraph []) =
+toZgraph :: String -> Old.ListGraph Old.CmmStmt -> UniqSM (CmmStackInfo, CmmGraph)
+toZgraph _ (Old.ListGraph []) =
do g <- lgraphOfAGraph emptyAGraph
- return ((0, Nothing), g)
-toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) =
- let (offset, entry) = mkEntry id NativeNodeCall args in
+ return (StackInfo {arg_space=0, updfr_space=Nothing}, g)
+toZgraph fun_name g@(Old.ListGraph (Old.BasicBlock id ss : other_blocks)) =
+ let (offset, entry) = mkCallEntry NativeNodeCall [] in
do g <- labelAGraph id $
entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks
- return ((offset, Nothing), g)
- where addBlock (BasicBlock id ss) g =
+ return (StackInfo {arg_space = offset, updfr_space = Nothing}, g)
+ where addBlock (Old.BasicBlock id ss) g =
mkLabel id <*> mkStmts ss <*> g
updfr_sz = 0 -- panic "upd frame size lost in cmm conversion"
- mkStmts (CmmNop : ss) = mkNop <*> mkStmts ss
- mkStmts (CmmComment s : ss) = mkComment s <*> mkStmts ss
- mkStmts (CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
- mkStmts (CmmStore l r : ss) = mkStore l r <*> mkStmts ss
- mkStmts (CmmCall (CmmCallee f conv) res args (CmmSafe _) CmmMayReturn : ss) =
- mkCall f (conv', conv') (map hintlessCmm res) (map hintlessCmm args) updfr_sz
- <*> mkStmts ss
+ mkStmts (Old.CmmNop : ss) = mkNop <*> mkStmts ss
+ mkStmts (Old.CmmComment s : ss) = mkComment s <*> mkStmts ss
+ mkStmts (Old.CmmAssign l r : ss) = mkAssign l r <*> mkStmts ss
+ mkStmts (Old.CmmStore l r : ss) = mkStore l r <*> mkStmts ss
+ mkStmts (Old.CmmCall (Old.CmmCallee f conv) res args (Old.CmmSafe _) Old.CmmMayReturn : ss) =
+ mkCall f (conv', conv') (map Old.hintlessCmm res) (map Old.hintlessCmm args) updfr_sz
+ <*> mkStmts ss
where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS
- mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) =
+ mkStmts (Old.CmmCall (Old.CmmPrim {}) _ _ (Old.CmmSafe _) _ : _) =
panic "safe call to a primitive CmmPrim CallishMachOp"
- mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) =
+ mkStmts (Old.CmmCall f res args Old.CmmUnsafe Old.CmmMayReturn : ss) =
mkUnsafeCall (convert_target f res args)
- (strip_hints res) (strip_hints args)
+ (strip_hints res) (strip_hints args)
<*> mkStmts ss
- mkStmts (CmmCondBranch e l : fbranch) =
+ mkStmts (Old.CmmCondBranch e l : fbranch) =
mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch)
mkStmts (last : []) = mkLast last
mkStmts [] = bad "fell off end"
mkStmts (_ : _ : _) = bad "last node not at end"
bad msg = pprPanic (msg ++ " in function " ++ fun_name) (ppr g)
- mkLast (CmmCall (CmmCallee f conv) [] args _ CmmNeverReturns) =
- mkFinalCall f conv (map hintlessCmm args) updfr_sz
- mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) =
+ mkLast (Old.CmmCall (Old.CmmCallee f conv) [] args _ Old.CmmNeverReturns) =
+ mkFinalCall f conv (map Old.hintlessCmm args) updfr_sz
+ mkLast (Old.CmmCall (Old.CmmPrim {}) _ _ _ Old.CmmNeverReturns) =
panic "Call to CmmPrim never returns?!"
- mkLast (CmmSwitch scrutinee table) = mkSwitch scrutinee table
+ mkLast (Old.CmmSwitch scrutinee table) = mkSwitch scrutinee table
-- SURELY, THESE HINTLESS ARGS ARE WRONG AND WILL BE FIXED WHEN CALLING
-- CONVENTIONS ARE HONORED?
- mkLast (CmmJump tgt args) = mkJump tgt (map hintlessCmm args) updfr_sz
- mkLast (CmmReturn ress) =
- mkReturnSimple (map hintlessCmm ress) updfr_sz
- mkLast (CmmBranch tgt) = mkBranch tgt
- mkLast (CmmCall _f (_:_) _args _ CmmNeverReturns) =
+ mkLast (Old.CmmJump tgt args) = mkJump tgt (map Old.hintlessCmm args) updfr_sz
+ mkLast (Old.CmmReturn ress) =
+ mkReturnSimple (map Old.hintlessCmm ress) updfr_sz
+ mkLast (Old.CmmBranch tgt) = mkBranch tgt
+ mkLast (Old.CmmCall _f (_:_) _args _ Old.CmmNeverReturns) =
panic "Call never returns but has results?!"
mkLast _ = panic "fell off end of block"
-strip_hints :: [CmmHinted a] -> [a]
-strip_hints = map hintlessCmm
+strip_hints :: [Old.CmmHinted a] -> [a]
+strip_hints = map Old.hintlessCmm
-convert_target :: CmmCallTarget -> HintedCmmFormals -> HintedCmmActuals -> MidCallTarget
-convert_target (CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map cmmHint args) (map cmmHint ress))
-convert_target (CmmPrim op) _ress _args = PrimTarget op
+convert_target :: Old.CmmCallTarget -> Old.HintedCmmFormals -> Old.HintedCmmActuals -> ForeignTarget
+convert_target (Old.CmmCallee e cc) ress args = ForeignTarget e (ForeignConvention cc (map Old.cmmHint args) (map Old.cmmHint ress))
+convert_target (Old.CmmPrim op) _ress _args = PrimTarget op
-add_hints :: Convention -> ValueDirection -> [a] -> [CmmHinted a]
-add_hints conv vd args = zipWith CmmHinted args (get_hints conv vd)
+data ValueDirection = Arguments | Results
+
+add_hints :: Convention -> ValueDirection -> [a] -> [Old.CmmHinted a]
+add_hints conv vd args = zipWith Old.CmmHinted args (get_hints conv vd)
get_hints :: Convention -> ValueDirection -> [ForeignHint]
get_hints (Foreign (ForeignConvention _ hints _)) Arguments = hints
get_hints (Foreign (ForeignConvention _ _ hints)) Results = hints
-get_hints _other_conv _vd = repeat NoHint
+get_hints _other_conv _vd = repeat NoHint
-get_conv :: MidCallTarget -> Convention
+get_conv :: ForeignTarget -> Convention
get_conv (PrimTarget _) = NativeNodeCall -- JD: SUSPICIOUS
get_conv (ForeignTarget _ fc) = Foreign fc
-cmm_target :: MidCallTarget -> CmmCallTarget
-cmm_target (PrimTarget op) = CmmPrim op
-cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = CmmCallee e cc
-
-ofZgraph :: CmmGraph -> ListGraph CmmStmt
-ofZgraph g = ListGraph $ swallow blocks
- where blocks = G.postorder_dfs g
- -- | the next two functions are hooks on which to hang debugging info
- extend_entry stmts = stmts
- extend_block _id stmts = stmts
- _extend_entry stmts = scomment showblocks : scomment cscomm : stmts
- showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++
- concat (map (\(G.Block id _) -> " " ++ show id) blocks)
- cscomm = "Call successors are" ++
- (concat $ map (\id -> " " ++ show id) $ blockSetToList call_succs)
- swallow [] = []
- swallow (G.Block id t : rest) = tail id [] t rest
- tail id prev' (G.ZTail m t) rest = tail id (mid m : prev') t rest
- tail id prev' (G.ZLast G.LastExit) rest = exit id prev' rest
- tail id prev' (G.ZLast (G.LastOther l)) rest = last id prev' l rest
- mid (MidComment s) = CmmComment s
- mid (MidAssign l r) = CmmAssign l r
- mid (MidStore l r) = CmmStore l r
- mid (MidForeignCall _ (PrimTarget MO_Touch) _ _) = CmmNop
- mid (MidForeignCall _ target ress args)
- = CmmCall (cmm_target target)
- (add_hints conv Results ress)
- (add_hints conv Arguments args)
- CmmUnsafe CmmMayReturn
- where
- conv = get_conv target
- block' id prev'
- | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev')
- | otherwise = BasicBlock id $ extend_block id (reverse prev')
- last id prev' l n =
- let endblock stmt = block' id (stmt : prev') : swallow n in
- case l of
- LastBranch tgt ->
- case n of
- -- THIS OPT IS WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH
- --G.Block id' _ t : bs
- -- | tgt == id', unique_pred id'
- -- -> tail id prev' t bs -- optimize out redundant labels
- _ -> endblock (CmmBranch tgt)
- LastCondBranch expr tid fid ->
- case n of
- G.Block id' t : bs
- -- It would be better to handle earlier, but we still must
- -- generate correct code here.
- | id' == fid, tid == fid, unique_pred id' ->
- tail id prev' t bs
- | id' == fid, unique_pred id' ->
- tail id (CmmCondBranch expr tid : prev') t bs
- | id' == tid, unique_pred id',
- Just e' <- maybeInvertCmmExpr expr ->
- tail id (CmmCondBranch e' fid : prev') t bs
- _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev'
- in block' id instrs' : swallow n
- LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids
- LastCall e _ _ _ _ -> endblock $ CmmJump e []
- exit id prev' n = -- highly irregular (assertion violation?)
- let endblock stmt = block' id (stmt : prev') : swallow n in
- case n of [] -> endblock (scomment "procedure falls off end")
- G.Block id' t : bs ->
- if unique_pred id' then
- tail id (scomment "went thru exit" : prev') t bs
- else
- endblock (CmmBranch id')
- preds = zipPreds g
- single_preds =
- let add b single =
- let id = G.blockId b
- in case lookupBlockEnv preds id of
- Nothing -> single
- Just s -> if sizeBlockSet s == 1 then
- extendBlockSet single id
- else single
- in G.fold_blocks add emptyBlockSet g
- unique_pred id = elemBlockSet id single_preds
- call_succs =
- let add b succs =
- case G.last (G.unzip b) of
- G.LastOther (LastCall _ (Just id) _ _ _) ->
- extendBlockSet succs id
- _ -> succs
- in G.fold_blocks add emptyBlockSet g
- _is_call_succ id = elemBlockSet id call_succs
-
-scomment :: String -> CmmStmt
-scomment s = CmmComment $ mkFastString s
+cmm_target :: ForeignTarget -> Old.CmmCallTarget
+cmm_target (PrimTarget op) = Old.CmmPrim op
+cmm_target (ForeignTarget e (ForeignConvention cc _ _)) = Old.CmmCallee e cc
+
+ofZgraph :: CmmGraph -> Old.ListGraph Old.CmmStmt
+ofZgraph g = Old.ListGraph $ mapMaybe convert_block $ postorderDfs g
+ -- We catenated some blocks in the conversion process,
+ -- because of the CmmCondBranch -- the machine code does not have
+ -- 'jump here or there' instruction, but has 'jump if true' instruction.
+ -- As OldCmm has the same instruction, so we use it.
+ -- When we are doing this, we also catenate normal goto-s (it is for free).
+
+ -- Exactly, we catenate blocks with nonentry labes, that are
+ -- a) mentioned exactly once as a successor
+ -- b) any of 1) are a target of a goto
+ -- 2) are false branch target of a conditional jump
+ -- 3) are true branch target of a conditional jump, and
+ -- the false branch target is a successor of at least 2 blocks
+ -- and the condition can be inverted
+ -- The complicated rule 3) is here because we need to assign at most one
+ -- catenable block to a CmmCondBranch.
+ where preds :: BlockEnv [CmmNode O C]
+ preds = mapFold add mapEmpty $ toBlockMap g
+ where add block env = foldr (add' $ lastNode block) env (successors block)
+ add' :: CmmNode O C -> BlockId -> BlockEnv [CmmNode O C] -> BlockEnv [CmmNode O C]
+ add' node succ env = mapInsert succ (node : (mapLookup succ env `orElse` [])) env
+
+ to_be_catenated :: BlockId -> Bool
+ to_be_catenated id | id == g_entry g = False
+ | Just [CmmBranch _] <- mapLookup id preds = True
+ | Just [CmmCondBranch _ _ f] <- mapLookup id preds
+ , f == id = True
+ | Just [CmmCondBranch e t f] <- mapLookup id preds
+ , t == id
+ , Just (_:_:_) <- mapLookup f preds
+ , Just _ <- maybeInvertCmmExpr e = True
+ to_be_catenated _ = False
+
+ convert_block block | to_be_catenated (entryLabel block) = Nothing
+ convert_block block = Just $ foldBlockNodesB3 (first, middle, last) block ()
+ where first :: CmmNode C O -> [Old.CmmStmt] -> Old.CmmBasicBlock
+ first (CmmEntry bid) stmts = Old.BasicBlock bid stmts
+
+ middle :: CmmNode O O -> [Old.CmmStmt] -> [Old.CmmStmt]
+ middle node stmts = stmt : stmts
+ where stmt :: Old.CmmStmt
+ stmt = case node of
+ CmmComment s -> Old.CmmComment s
+ CmmAssign l r -> Old.CmmAssign l r
+ CmmStore l r -> Old.CmmStore l r
+ CmmUnsafeForeignCall (PrimTarget MO_Touch) _ _ -> Old.CmmNop
+ CmmUnsafeForeignCall target ress args ->
+ Old.CmmCall (cmm_target target)
+ (add_hints (get_conv target) Results ress)
+ (add_hints (get_conv target) Arguments args)
+ Old.CmmUnsafe Old.CmmMayReturn
+
+ last :: CmmNode O C -> () -> [Old.CmmStmt]
+ last node _ = stmts
+ where stmts :: [Old.CmmStmt]
+ stmts = case node of
+ CmmBranch tgt | to_be_catenated tgt -> tail_of tgt
+ | otherwise -> [Old.CmmBranch tgt]
+ CmmCondBranch expr tid fid
+ | to_be_catenated fid -> Old.CmmCondBranch expr tid : tail_of fid
+ | to_be_catenated tid
+ , Just expr' <- maybeInvertCmmExpr expr -> Old.CmmCondBranch expr' fid : tail_of tid
+ | otherwise -> [Old.CmmCondBranch expr tid, Old.CmmBranch fid]
+ CmmSwitch arg ids -> [Old.CmmSwitch arg ids]
+ CmmCall e _ _ _ _ -> [Old.CmmJump e []]
+ CmmForeignCall {} -> panic "ofZgraph: CmmForeignCall"
+ tail_of bid = case foldBlockNodesB3 (first, middle, last) block () of
+ Old.BasicBlock _ stmts -> stmts
+ where Just block = mapLookup bid $ toBlockMap g
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Cmm data types
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module CmmDecl (
+ GenCmm(..), GenCmmTop(..),
+ CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription,
+ ProfilingInfo(..), ClosureTypeTag,
+ CmmActual, CmmActuals, CmmFormal, CmmFormals, ForeignHint(..),
+ CmmStatic(..), Section(..),
+ ) where
+
+#include "HsVersions.h"
+
+import CmmExpr
+import CLabel
+import SMRep
+import ClosureInfo
+
+import Data.Word
+
+
+-- 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.
+
+-----------------------------------------------------------------------------
+-- GenCmm, GenCmmTop
+-----------------------------------------------------------------------------
+
+-- A file is a list of top-level chunks. These may be arbitrarily
+-- re-orderd during code generation.
+
+-- GenCmm is abstracted over
+-- d, the type of static data elements in CmmData
+-- h, the static info preceding the code of a CmmProc
+-- g, the control-flow graph of a CmmProc
+--
+-- We expect there to be two main instances of this type:
+-- (a) C--, i.e. populated with various C-- constructs
+-- (Cmm and RawCmm in OldCmm.hs)
+-- (b) Native code, populated with data/instructions
+--
+-- A second family of instances based on Hoopl is in Cmm.hs.
+--
+newtype GenCmm d h g = Cmm [GenCmmTop d h g]
+
+-- | A top-level chunk, abstracted over the type of the contents of
+-- the basic blocks (Cmm or instructions are the likely instantiations).
+data GenCmmTop d h g
+ = CmmProc -- A procedure
+ h -- Extra header such as the info table
+ CLabel -- Used to generate both info & entry labels
+ g -- Control-flow graph for the procedure's code
+
+ | CmmData -- Static data
+ Section
+ [d]
+
+
+-- A basic block containing a single label, at the beginning.
+-- The list of basic blocks in a top-level code block may be re-ordered.
+-- Fall-through is not allowed: there must be an explicit jump at the
+-- end of each basic block, but the code generator might rearrange basic
+-- blocks in order to turn some jumps into fallthroughs.
+
+
+-----------------------------------------------------------------------------
+-- Info Tables
+-----------------------------------------------------------------------------
+
+-- Info table as a haskell data type
+data CmmInfoTable
+ = CmmInfoTable
+ HasStaticClosure
+ ProfilingInfo
+ ClosureTypeTag -- Int
+ ClosureTypeInfo
+ | CmmNonInfoTable -- Procedure doesn't need an info table
+
+type HasStaticClosure = Bool
+
+-- TODO: The GC target shouldn't really be part of CmmInfo
+-- as it doesn't appear in the resulting info table.
+-- It should be factored out.
+
+data ClosureTypeInfo
+ = ConstrInfo ClosureLayout ConstrTag ConstrDescription
+ | FunInfo ClosureLayout C_SRT FunArity ArgDescr SlowEntry
+ | ThunkInfo ClosureLayout C_SRT
+ | ThunkSelectorInfo SelectorOffset C_SRT
+ | ContInfo
+ [Maybe LocalReg] -- Stack layout: Just x, an item x
+ -- Nothing: a 1-word gap
+ -- Start of list is the *young* end
+ C_SRT
+
+-- TODO: These types may need refinement
+data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
+type ClosureTypeTag = StgHalfWord
+type ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
+type ConstrTag = StgHalfWord
+type ConstrDescription = CmmLit
+type FunArity = StgHalfWord
+type SlowEntry = CmmLit
+ -- We would like this to be a CLabel but
+ -- for now the parser sets this to zero on an INFO_TABLE_FUN.
+type SelectorOffset = StgWord
+
+type CmmActual = CmmExpr
+type CmmFormal = LocalReg
+type CmmActuals = [CmmActual]
+type CmmFormals = [CmmFormal]
+
+data ForeignHint
+ = NoHint | AddrHint | SignedHint
+ deriving( Eq )
+ -- Used to give extra per-argument or per-result
+ -- information needed by foreign calling conventions
+
+-----------------------------------------------------------------------------
+-- Static Data
+-----------------------------------------------------------------------------
+
+data Section
+ = Text
+ | Data
+ | ReadOnlyData
+ | RelocatableReadOnlyData
+ | UninitialisedData
+ | ReadOnlyData16 -- .rodata.cst16 on x86_64, 16-byte aligned
+ | OtherSection String
+
+data CmmStatic
+ = CmmStaticLit CmmLit
+ -- a literal value, size given by cmmLitRep of the literal.
+ | CmmUninitialised Int
+ -- uninitialised data, N bytes long
+ | CmmAlign Int
+ -- align to next N-byte boundary (N must be a power of 2).
+ | CmmDataLabel CLabel
+ -- label the current position in this section.
+ | CmmString [Word8]
+ -- string of 8-bit values only, not zero terminated.
+
module CmmExpr
- ( CmmType -- Abstract
- , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
- , cInt, cLong
- , cmmBits, cmmFloat
- , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
- , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
-
- , Width(..)
- , widthInBits, widthInBytes, widthInLog, widthFromBytes
- , wordWidth, halfWordWidth, cIntWidth, cLongWidth
- , narrowU, narrowS
-
- , CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
+ ( CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr
, CmmReg(..), cmmRegType
, CmmLit(..), cmmLitType
, LocalReg(..), localRegType
, plusRegSet, minusRegSet, timesRegSet
, regUsedIn
, Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, isStackSlotOf
-
- -- MachOp
- , MachOp(..)
- , pprMachOp, isCommutableMachOp, isAssociativeMachOp
- , isComparisonMachOp, machOpResultType
- , machOpArgReps, maybeInvertComparison
-
- -- MachOp builders
- , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
- , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
- , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
- , mo_wordULe, mo_wordUGt, mo_wordULt
- , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
- , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
- , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
- , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
- )
+ , module CmmMachOp
+ , module CmmType
+ )
where
#include "HsVersions.h"
+import CmmType
+import CmmMachOp
import BlockId
import CLabel
-import Constants
-import FastString
-import Outputable
import Unique
import UniqSet
-import Data.Word
-import Data.Int
import Data.Map (Map)
-----------------------------------------------------------------------------
foldSlotsUsed _ set [] = set
foldSlotsUsed f set (x:xs) = foldSlotsUsed f (foldSlotsUsed f set x) xs
+instance DefinerOfSlots a => DefinerOfSlots [a] where
+ foldSlotsDefd _ set [] = set
+ foldSlotsDefd f set (x:xs) = foldSlotsDefd f (foldSlotsDefd f set x) xs
+
+instance DefinerOfSlots SubArea where
+ foldSlotsDefd f z a = f z a
-----------------------------------------------------------------------------
-- Global STG registers
globalRegType Hp = gcWord -- The initialiser for all
-- dynamically allocated closures
globalRegType _ = bWord
-
-
------------------------------------------------------------------------------
--- CmmType
------------------------------------------------------------------------------
-
- -- NOTE: CmmType is an abstract type, not exported from this
- -- module so you can easily change its representation
- --
- -- However Width is exported in a concrete way,
- -- and is used extensively in pattern-matching
-
-data CmmType -- The important one!
- = CmmType CmmCat Width
-
-data CmmCat -- "Category" (not exported)
- = GcPtrCat -- GC pointer
- | BitsCat -- Non-pointer
- | FloatCat -- Float
- deriving( Eq )
- -- See Note [Signed vs unsigned] at the end
-
-instance Outputable CmmType where
- ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)
-
-instance Outputable CmmCat where
- ppr FloatCat = ptext $ sLit("F")
- ppr _ = ptext $ sLit("I")
--- Temp Jan 08
--- ppr FloatCat = ptext $ sLit("float")
--- ppr BitsCat = ptext $ sLit("bits")
--- ppr GcPtrCat = ptext $ sLit("gcptr")
-
--- Why is CmmType stratified? For native code generation,
--- most of the time you just want to know what sort of register
--- to put the thing in, and for this you need to know how
--- many bits thing has and whether it goes in a floating-point
--- register. By contrast, the distinction between GcPtr and
--- GcNonPtr is of interest to only a few parts of the code generator.
-
--------- Equality on CmmType --------------
--- CmmType is *not* an instance of Eq; sometimes we care about the
--- Gc/NonGc distinction, and sometimes we don't
--- So we use an explicit function to force you to think about it
-cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality
-cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2
-
-cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool
- -- This equality is temporary; used in CmmLint
- -- but the RTS files are not yet well-typed wrt pointers
-cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2)
- = c1 `weak_eq` c2 && w1==w2
- where
- FloatCat `weak_eq` FloatCat = True
- FloatCat `weak_eq` _other = False
- _other `weak_eq` FloatCat = False
- _word1 `weak_eq` _word2 = True -- Ignores GcPtr
-
---- Simple operations on CmmType -----
-typeWidth :: CmmType -> Width
-typeWidth (CmmType _ w) = w
-
-cmmBits, cmmFloat :: Width -> CmmType
-cmmBits = CmmType BitsCat
-cmmFloat = CmmType FloatCat
-
--------- Common CmmTypes ------------
--- Floats and words of specific widths
-b8, b16, b32, b64, f32, f64 :: CmmType
-b8 = cmmBits W8
-b16 = cmmBits W16
-b32 = cmmBits W32
-b64 = cmmBits W64
-f32 = cmmFloat W32
-f64 = cmmFloat W64
-
--- CmmTypes of native word widths
-bWord, bHalfWord, gcWord :: CmmType
-bWord = cmmBits wordWidth
-bHalfWord = cmmBits halfWordWidth
-gcWord = CmmType GcPtrCat wordWidth
-
-cInt, cLong :: CmmType
-cInt = cmmBits cIntWidth
-cLong = cmmBits cLongWidth
-
-
------------- Predicates ----------------
-isFloatType, isGcPtrType :: CmmType -> Bool
-isFloatType (CmmType FloatCat _) = True
-isFloatType _other = False
-
-isGcPtrType (CmmType GcPtrCat _) = True
-isGcPtrType _other = False
-
-isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool
--- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise)
--- isFloat32 and 64 are obvious
-
-isWord64 (CmmType BitsCat W64) = True
-isWord64 (CmmType GcPtrCat W64) = True
-isWord64 _other = False
-
-isWord32 (CmmType BitsCat W32) = True
-isWord32 (CmmType GcPtrCat W32) = True
-isWord32 _other = False
-
-isFloat32 (CmmType FloatCat W32) = True
-isFloat32 _other = False
-
-isFloat64 (CmmType FloatCat W64) = True
-isFloat64 _other = False
-
------------------------------------------------------------------------------
--- Width
------------------------------------------------------------------------------
-
-data Width = W8 | W16 | W32 | W64
- | W80 -- Extended double-precision float,
- -- used in x86 native codegen only.
- -- (we use Ord, so it'd better be in this order)
- | W128
- deriving (Eq, Ord, Show)
-
-instance Outputable Width where
- ppr rep = ptext (mrStr rep)
-
-mrStr :: Width -> LitString
-mrStr W8 = sLit("W8")
-mrStr W16 = sLit("W16")
-mrStr W32 = sLit("W32")
-mrStr W64 = sLit("W64")
-mrStr W128 = sLit("W128")
-mrStr W80 = sLit("W80")
-
-
--------- Common Widths ------------
-wordWidth, halfWordWidth :: Width
-wordWidth | wORD_SIZE == 4 = W32
- | wORD_SIZE == 8 = W64
- | otherwise = panic "MachOp.wordRep: Unknown word size"
-
-halfWordWidth | wORD_SIZE == 4 = W16
- | wORD_SIZE == 8 = W32
- | otherwise = panic "MachOp.halfWordRep: Unknown word size"
-
--- cIntRep is the Width for a C-language 'int'
-cIntWidth, cLongWidth :: Width
-#if SIZEOF_INT == 4
-cIntWidth = W32
-#elif SIZEOF_INT == 8
-cIntWidth = W64
-#endif
-
-#if SIZEOF_LONG == 4
-cLongWidth = W32
-#elif SIZEOF_LONG == 8
-cLongWidth = W64
-#endif
-
-widthInBits :: Width -> Int
-widthInBits W8 = 8
-widthInBits W16 = 16
-widthInBits W32 = 32
-widthInBits W64 = 64
-widthInBits W128 = 128
-widthInBits W80 = 80
-
-widthInBytes :: Width -> Int
-widthInBytes W8 = 1
-widthInBytes W16 = 2
-widthInBytes W32 = 4
-widthInBytes W64 = 8
-widthInBytes W128 = 16
-widthInBytes W80 = 10
-
-widthFromBytes :: Int -> Width
-widthFromBytes 1 = W8
-widthFromBytes 2 = W16
-widthFromBytes 4 = W32
-widthFromBytes 8 = W64
-widthFromBytes 16 = W128
-widthFromBytes 10 = W80
-widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n)
-
--- log_2 of the width in bytes, useful for generating shifts.
-widthInLog :: Width -> Int
-widthInLog W8 = 0
-widthInLog W16 = 1
-widthInLog W32 = 2
-widthInLog W64 = 3
-widthInLog W128 = 4
-widthInLog W80 = panic "widthInLog: F80"
-
--- widening / narrowing
-
-narrowU :: Width -> Integer -> Integer
-narrowU W8 x = fromIntegral (fromIntegral x :: Word8)
-narrowU W16 x = fromIntegral (fromIntegral x :: Word16)
-narrowU W32 x = fromIntegral (fromIntegral x :: Word32)
-narrowU W64 x = fromIntegral (fromIntegral x :: Word64)
-narrowU _ _ = panic "narrowTo"
-
-narrowS :: Width -> Integer -> Integer
-narrowS W8 x = fromIntegral (fromIntegral x :: Int8)
-narrowS W16 x = fromIntegral (fromIntegral x :: Int16)
-narrowS W32 x = fromIntegral (fromIntegral x :: Int32)
-narrowS W64 x = fromIntegral (fromIntegral x :: Int64)
-narrowS _ _ = panic "narrowTo"
-
------------------------------------------------------------------------------
--- MachOp
------------------------------------------------------------------------------
-
-{-
-Implementation notes:
-
-It might suffice to keep just a width, without distinguishing between
-floating and integer types. However, keeping the distinction will
-help the native code generator to assign registers more easily.
--}
-
-
-{- |
-Machine-level primops; ones which we can reasonably delegate to the
-native code generators to handle. Basically contains C's primops
-and no others.
-
-Nomenclature: all ops indicate width and signedness, where
-appropriate. Widths: 8\/16\/32\/64 means the given size, obviously.
-Nat means the operation works on STG word sized objects.
-Signedness: S means signed, U means unsigned. For operations where
-signedness is irrelevant or makes no difference (for example
-integer add), the signedness component is omitted.
-
-An exception: NatP is a ptr-typed native word. From the point of
-view of the native code generators this distinction is irrelevant,
-but the C code generator sometimes needs this info to emit the
-right casts.
--}
-
-data MachOp
- -- Integer operations (insensitive to signed/unsigned)
- = MO_Add Width
- | MO_Sub Width
- | MO_Eq Width
- | MO_Ne Width
- | MO_Mul Width -- low word of multiply
-
- -- Signed multiply/divide
- | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows
- | MO_S_Quot Width -- signed / (same semantics as IntQuotOp)
- | MO_S_Rem Width -- signed % (same semantics as IntRemOp)
- | MO_S_Neg Width -- unary -
-
- -- Unsigned multiply/divide
- | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows
- | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp)
- | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp)
-
- -- Signed comparisons
- | MO_S_Ge Width
- | MO_S_Le Width
- | MO_S_Gt Width
- | MO_S_Lt Width
-
- -- Unsigned comparisons
- | MO_U_Ge Width
- | MO_U_Le Width
- | MO_U_Gt Width
- | MO_U_Lt Width
-
- -- Floating point arithmetic
- | MO_F_Add Width
- | MO_F_Sub Width
- | MO_F_Neg Width -- unary -
- | MO_F_Mul Width
- | MO_F_Quot Width
-
- -- Floating point comparison
- | MO_F_Eq Width
- | MO_F_Ne Width
- | MO_F_Ge Width
- | MO_F_Le Width
- | MO_F_Gt Width
- | MO_F_Lt Width
-
- -- Bitwise operations. Not all of these may be supported
- -- at all sizes, and only integral Widths are valid.
- | MO_And Width
- | MO_Or Width
- | MO_Xor Width
- | MO_Not Width
- | MO_Shl Width
- | MO_U_Shr Width -- unsigned shift right
- | MO_S_Shr Width -- signed shift right
-
- -- Conversions. Some of these will be NOPs.
- -- Floating-point conversions use the signed variant.
- | MO_SF_Conv Width Width -- Signed int -> Float
- | MO_FS_Conv Width Width -- Float -> Signed int
- | MO_SS_Conv Width Width -- Signed int -> Signed int
- | MO_UU_Conv Width Width -- unsigned int -> unsigned int
- | MO_FF_Conv Width Width -- Float -> Float
- deriving (Eq, Show)
-
-pprMachOp :: MachOp -> SDoc
-pprMachOp mo = text (show mo)
-
-
-
--- -----------------------------------------------------------------------------
--- Some common MachReps
-
--- A 'wordRep' is a machine word on the target architecture
--- Specifically, it is the size of an Int#, Word#, Addr#
--- and the unit of allocation on the stack and the heap
--- Any pointer is also guaranteed to be a wordRep.
-
-mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
- , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
- , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
- , mo_wordULe, mo_wordUGt, mo_wordULt
- , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
- , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
- , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
- , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
- :: MachOp
-
-mo_wordAdd = MO_Add wordWidth
-mo_wordSub = MO_Sub wordWidth
-mo_wordEq = MO_Eq wordWidth
-mo_wordNe = MO_Ne wordWidth
-mo_wordMul = MO_Mul wordWidth
-mo_wordSQuot = MO_S_Quot wordWidth
-mo_wordSRem = MO_S_Rem wordWidth
-mo_wordSNeg = MO_S_Neg wordWidth
-mo_wordUQuot = MO_U_Quot wordWidth
-mo_wordURem = MO_U_Rem wordWidth
-
-mo_wordSGe = MO_S_Ge wordWidth
-mo_wordSLe = MO_S_Le wordWidth
-mo_wordSGt = MO_S_Gt wordWidth
-mo_wordSLt = MO_S_Lt wordWidth
-
-mo_wordUGe = MO_U_Ge wordWidth
-mo_wordULe = MO_U_Le wordWidth
-mo_wordUGt = MO_U_Gt wordWidth
-mo_wordULt = MO_U_Lt wordWidth
-
-mo_wordAnd = MO_And wordWidth
-mo_wordOr = MO_Or wordWidth
-mo_wordXor = MO_Xor wordWidth
-mo_wordNot = MO_Not wordWidth
-mo_wordShl = MO_Shl wordWidth
-mo_wordSShr = MO_S_Shr wordWidth
-mo_wordUShr = MO_U_Shr wordWidth
-
-mo_u_8To32 = MO_UU_Conv W8 W32
-mo_s_8To32 = MO_SS_Conv W8 W32
-mo_u_16To32 = MO_UU_Conv W16 W32
-mo_s_16To32 = MO_SS_Conv W16 W32
-
-mo_u_8ToWord = MO_UU_Conv W8 wordWidth
-mo_s_8ToWord = MO_SS_Conv W8 wordWidth
-mo_u_16ToWord = MO_UU_Conv W16 wordWidth
-mo_s_16ToWord = MO_SS_Conv W16 wordWidth
-mo_s_32ToWord = MO_SS_Conv W32 wordWidth
-mo_u_32ToWord = MO_UU_Conv W32 wordWidth
-
-mo_WordTo8 = MO_UU_Conv wordWidth W8
-mo_WordTo16 = MO_UU_Conv wordWidth W16
-mo_WordTo32 = MO_UU_Conv wordWidth W32
-
-mo_32To8 = MO_UU_Conv W32 W8
-mo_32To16 = MO_UU_Conv W32 W16
-
-
--- ----------------------------------------------------------------------------
--- isCommutableMachOp
-
-{- |
-Returns 'True' if the MachOp has commutable arguments. This is used
-in the platform-independent Cmm optimisations.
-
-If in doubt, return 'False'. This generates worse code on the
-native routes, but is otherwise harmless.
--}
-isCommutableMachOp :: MachOp -> Bool
-isCommutableMachOp mop =
- case mop of
- MO_Add _ -> True
- MO_Eq _ -> True
- MO_Ne _ -> True
- MO_Mul _ -> True
- MO_S_MulMayOflo _ -> True
- MO_U_MulMayOflo _ -> True
- MO_And _ -> True
- MO_Or _ -> True
- MO_Xor _ -> True
- _other -> False
-
--- ----------------------------------------------------------------------------
--- isAssociativeMachOp
-
-{- |
-Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)
-This is used in the platform-independent Cmm optimisations.
-
-If in doubt, return 'False'. This generates worse code on the
-native routes, but is otherwise harmless.
--}
-isAssociativeMachOp :: MachOp -> Bool
-isAssociativeMachOp mop =
- case mop of
- MO_Add {} -> True -- NB: does not include
- MO_Mul {} -> True -- floatint point!
- MO_And {} -> True
- MO_Or {} -> True
- MO_Xor {} -> True
- _other -> False
-
--- ----------------------------------------------------------------------------
--- isComparisonMachOp
-
-{- |
-Returns 'True' if the MachOp is a comparison.
-
-If in doubt, return False. This generates worse code on the
-native routes, but is otherwise harmless.
--}
-isComparisonMachOp :: MachOp -> Bool
-isComparisonMachOp mop =
- case mop of
- MO_Eq _ -> True
- MO_Ne _ -> True
- MO_S_Ge _ -> True
- MO_S_Le _ -> True
- MO_S_Gt _ -> True
- MO_S_Lt _ -> True
- MO_U_Ge _ -> True
- MO_U_Le _ -> True
- MO_U_Gt _ -> True
- MO_U_Lt _ -> True
- MO_F_Eq {} -> True
- MO_F_Ne {} -> True
- MO_F_Ge {} -> True
- MO_F_Le {} -> True
- MO_F_Gt {} -> True
- MO_F_Lt {} -> True
- _other -> False
-
--- -----------------------------------------------------------------------------
--- Inverting conditions
-
--- Sometimes it's useful to be able to invert the sense of a
--- condition. Not all conditional tests are invertible: in
--- particular, floating point conditionals cannot be inverted, because
--- there exist floating-point values which return False for both senses
--- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
-
-maybeInvertComparison :: MachOp -> Maybe MachOp
-maybeInvertComparison op
- = case op of -- None of these Just cases include floating point
- MO_Eq r -> Just (MO_Ne r)
- MO_Ne r -> Just (MO_Eq r)
- MO_U_Lt r -> Just (MO_U_Ge r)
- MO_U_Gt r -> Just (MO_U_Le r)
- MO_U_Le r -> Just (MO_U_Gt r)
- MO_U_Ge r -> Just (MO_U_Lt r)
- MO_S_Lt r -> Just (MO_S_Ge r)
- MO_S_Gt r -> Just (MO_S_Le r)
- MO_S_Le r -> Just (MO_S_Gt r)
- MO_S_Ge r -> Just (MO_S_Lt r)
- MO_F_Eq r -> Just (MO_F_Ne r)
- MO_F_Ne r -> Just (MO_F_Eq r)
- MO_F_Ge r -> Just (MO_F_Le r)
- MO_F_Le r -> Just (MO_F_Ge r)
- MO_F_Gt r -> Just (MO_F_Lt r)
- MO_F_Lt r -> Just (MO_F_Gt r)
- _other -> Nothing
-
--- ----------------------------------------------------------------------------
--- machOpResultType
-
-{- |
-Returns the MachRep of the result of a MachOp.
--}
-machOpResultType :: MachOp -> [CmmType] -> CmmType
-machOpResultType mop tys =
- case mop of
- MO_Add {} -> ty1 -- Preserve GC-ptr-hood
- MO_Sub {} -> ty1 -- of first arg
- MO_Mul r -> cmmBits r
- MO_S_MulMayOflo r -> cmmBits r
- MO_S_Quot r -> cmmBits r
- MO_S_Rem r -> cmmBits r
- MO_S_Neg r -> cmmBits r
- MO_U_MulMayOflo r -> cmmBits r
- MO_U_Quot r -> cmmBits r
- MO_U_Rem r -> cmmBits r
-
- MO_Eq {} -> comparisonResultRep
- MO_Ne {} -> comparisonResultRep
- MO_S_Ge {} -> comparisonResultRep
- MO_S_Le {} -> comparisonResultRep
- MO_S_Gt {} -> comparisonResultRep
- MO_S_Lt {} -> comparisonResultRep
-
- MO_U_Ge {} -> comparisonResultRep
- MO_U_Le {} -> comparisonResultRep
- MO_U_Gt {} -> comparisonResultRep
- MO_U_Lt {} -> comparisonResultRep
-
- MO_F_Add r -> cmmFloat r
- MO_F_Sub r -> cmmFloat r
- MO_F_Mul r -> cmmFloat r
- MO_F_Quot r -> cmmFloat r
- MO_F_Neg r -> cmmFloat r
- MO_F_Eq {} -> comparisonResultRep
- MO_F_Ne {} -> comparisonResultRep
- MO_F_Ge {} -> comparisonResultRep
- MO_F_Le {} -> comparisonResultRep
- MO_F_Gt {} -> comparisonResultRep
- MO_F_Lt {} -> comparisonResultRep
-
- MO_And {} -> ty1 -- Used for pointer masking
- MO_Or {} -> ty1
- MO_Xor {} -> ty1
- MO_Not r -> cmmBits r
- MO_Shl r -> cmmBits r
- MO_U_Shr r -> cmmBits r
- MO_S_Shr r -> cmmBits r
-
- MO_SS_Conv _ to -> cmmBits to
- MO_UU_Conv _ to -> cmmBits to
- MO_FS_Conv _ to -> cmmBits to
- MO_SF_Conv _ to -> cmmFloat to
- MO_FF_Conv _ to -> cmmFloat to
- where
- (ty1:_) = tys
-
-comparisonResultRep :: CmmType
-comparisonResultRep = bWord -- is it?
-
-
--- -----------------------------------------------------------------------------
--- machOpArgReps
-
--- | This function is used for debugging only: we can check whether an
--- application of a MachOp is "type-correct" by checking that the MachReps of
--- its arguments are the same as the MachOp expects. This is used when
--- linting a CmmExpr.
-
-machOpArgReps :: MachOp -> [Width]
-machOpArgReps op =
- case op of
- MO_Add r -> [r,r]
- MO_Sub r -> [r,r]
- MO_Eq r -> [r,r]
- MO_Ne r -> [r,r]
- MO_Mul r -> [r,r]
- MO_S_MulMayOflo r -> [r,r]
- MO_S_Quot r -> [r,r]
- MO_S_Rem r -> [r,r]
- MO_S_Neg r -> [r]
- MO_U_MulMayOflo r -> [r,r]
- MO_U_Quot r -> [r,r]
- MO_U_Rem r -> [r,r]
-
- MO_S_Ge r -> [r,r]
- MO_S_Le r -> [r,r]
- MO_S_Gt r -> [r,r]
- MO_S_Lt r -> [r,r]
-
- MO_U_Ge r -> [r,r]
- MO_U_Le r -> [r,r]
- MO_U_Gt r -> [r,r]
- MO_U_Lt r -> [r,r]
-
- MO_F_Add r -> [r,r]
- MO_F_Sub r -> [r,r]
- MO_F_Mul r -> [r,r]
- MO_F_Quot r -> [r,r]
- MO_F_Neg r -> [r]
- MO_F_Eq r -> [r,r]
- MO_F_Ne r -> [r,r]
- MO_F_Ge r -> [r,r]
- MO_F_Le r -> [r,r]
- MO_F_Gt r -> [r,r]
- MO_F_Lt r -> [r,r]
-
- MO_And r -> [r,r]
- MO_Or r -> [r,r]
- MO_Xor r -> [r,r]
- MO_Not r -> [r]
- MO_Shl r -> [r,wordWidth]
- MO_U_Shr r -> [r,wordWidth]
- MO_S_Shr r -> [r,wordWidth]
-
- MO_SS_Conv from _ -> [from]
- MO_UU_Conv from _ -> [from]
- MO_SF_Conv from _ -> [from]
- MO_FS_Conv from _ -> [from]
- MO_FF_Conv from _ -> [from]
-
-
--------------------------------------------------------------------------
-{- Note [Signed vs unsigned]
- ~~~~~~~~~~~~~~~~~~~~~~~~~
-Should a CmmType include a signed vs. unsigned distinction?
-
-This is very much like a "hint" in C-- terminology: it isn't necessary
-in order to generate correct code, but it might be useful in that the
-compiler can generate better code if it has access to higher-level
-hints about data. This is important at call boundaries, because the
-definition of a function is not visible at all of its call sites, so
-the compiler cannot infer the hints.
-
-Here in Cmm, we're taking a slightly different approach. We include
-the int vs. float hint in the MachRep, because (a) the majority of
-platforms have a strong distinction between float and int registers,
-and (b) we don't want to do any heavyweight hint-inference in the
-native code backend in order to get good code. We're treating the
-hint more like a type: our Cmm is always completely consistent with
-respect to hints. All coercions between float and int are explicit.
-
-What about the signed vs. unsigned hint? This information might be
-useful if we want to keep sub-word-sized values in word-size
-registers, which we must do if we only have word-sized registers.
-
-On such a system, there are two straightforward conventions for
-representing sub-word-sized values:
-
-(a) Leave the upper bits undefined. Comparison operations must
- sign- or zero-extend both operands before comparing them,
- depending on whether the comparison is signed or unsigned.
-
-(b) Always keep the values sign- or zero-extended as appropriate.
- Arithmetic operations must narrow the result to the appropriate
- size.
-
-A clever compiler might not use either (a) or (b) exclusively, instead
-it would attempt to minimize the coercions by analysis: the same kind
-of analysis that propagates hints around. In Cmm we don't want to
-have to do this, so we plump for having richer types and keeping the
-type information consistent.
-
-If signed/unsigned hints are missing from MachRep, then the only
-choice we have is (a), because we don't know whether the result of an
-operation should be sign- or zero-extended.
-
-Many architectures have extending load operations, which work well
-with (b). To make use of them with (a), you need to know whether the
-value is going to be sign- or zero-extended by an enclosing comparison
-(for example), which involves knowing above the context. This is
-doable but more complex.
-
-Further complicating the issue is foreign calls: a foreign calling
-convention can specify that signed 8-bit quantities are passed as
-sign-extended 32 bit quantities, for example (this is the case on the
-PowerPC). So we *do* need sign information on foreign call arguments.
-
-Pros for adding signed vs. unsigned to MachRep:
-
- - It would let us use convention (b) above, and get easier
- code generation for extending loads.
-
- - Less information required on foreign calls.
-
- - MachOp type would be simpler
-
-Cons:
-
- - More complexity
-
- - What is the MachRep for a VanillaReg? Currently it is
- always wordRep, but now we have to decide whether it is
- signed or unsigned. The same VanillaReg can thus have
- different MachReps in different parts of the program.
-
- - Extra coercions cluttering up expressions.
-
-Currently for GHC, the foreign call point is moot, because we do our
-own promotion of sub-word-sized values to word-sized values. The Int8
-type is represnted by an Int# which is kept sign-extended at all times
-(this is slightly naughty, because we're making assumptions about the
-C calling convention rather early on in the compiler). However, given
-this, the cons outweigh the pros.
-
--}
-
emptyContInfoTable,
cmmToRawCmm,
mkInfoTable,
- mkBareInfoTable
) where
#include "HsVersions.h"
-import Cmm
+import OldCmm
import CmmUtils
import CLabel
import CgCallConv
import CgUtils
import SMRep
-import ZipCfgCmmRep
import Constants
import Panic
import Data.Bits
-- When we split at proc points, we need an empty info table.
-emptyContInfoTable :: CmmInfo
-emptyContInfoTable =
- CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
- (ContInfo [] NoC_SRT))
+emptyContInfoTable :: CmmInfoTable
+emptyContInfoTable = CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL
+ (ContInfo [] NoC_SRT)
where zero = CmmInt 0 wordWidth
cmmToRawCmm :: [Cmm] -> IO [RawCmm]
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable _ (CmmData sec dat) = [CmmData sec dat]
-mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) =
+mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label blocks) =
case info of
-- Code without an info table. Easy.
- CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks]
+ CmmNonInfoTable -> [CmmProc [] entry_label blocks]
CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info ->
let info_label = entryLblToInfoLbl entry_label
-- A function entry point.
FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry ->
mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
- arguments blocks
+ blocks
where
fun_type = argDescrType pap_bitmap
fun_extra_bits =
-- A constructor.
ConstrInfo (ptrs, nptrs) con_tag descr ->
mkInfoTableAndCode info_label std_info [con_name] entry_label
- arguments blocks
+ blocks
where
std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout
con_name = makeRelativeRefTo info_label descr
-- A thunk.
ThunkInfo (ptrs, nptrs) srt ->
mkInfoTableAndCode info_label std_info srt_label entry_label
- arguments blocks
+ blocks
where
std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout
(srt_label, srt_bitmap) = mkSRTLit info_label srt
-- A selector thunk.
ThunkSelectorInfo offset _srt ->
mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label
- arguments blocks
+ blocks
where
std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset)
ContInfo stack_layout srt ->
liveness_data ++
mkInfoTableAndCode info_label std_info srt_label entry_label
- arguments blocks
+ blocks
where
std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap
(makeRelativeRefTo info_label liveness_lit)
else type_tag
(srt_label, srt_bitmap) = mkSRTLit info_label srt
--- Generate a bare info table, not attached to any procedure.
-mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ]
-mkBareInfoTable lbl uniq info =
- case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of
- [CmmProc d _ _ _] ->
- ASSERT (tablesNextToCode)
- [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])]
- [CmmData d s] -> [CmmData d s]
- _ -> panic "mkBareInfoTable expected to produce only data"
-
-
-- Handle the differences between tables-next-to-code
-- and not tables-next-to-code
mkInfoTableAndCode :: CLabel
-> [CmmLit]
-> [CmmLit]
-> CLabel
- -> CmmFormals
-> ListGraph CmmStmt
-> [RawCmmTop]
-mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
+mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl blocks
| tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
= [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
- entry_lbl args blocks]
+ entry_lbl blocks]
| ListGraph [] <- blocks -- No code; only the info table is significant
= -- Use a zero place-holder in place of the
| otherwise -- Separately emit info table (with the function entry
= -- point as first entry) and the entry code
- [CmmProc [] entry_lbl args blocks,
+ [CmmProc [] entry_lbl blocks,
mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)]
mkSRTLit :: CLabel
CmmToken(..), cmmlex,
) where
-import Cmm
+import OldCmm
import Lexer
import SrcLoc
) where
import BlockId
-import Cmm
+import OldCmm
import CLabel
import Outputable
-import PprCmm
+import OldPprCmm()
import Constants
import FastString
Right _ -> Nothing
lintCmmTop :: (GenCmmTop h i (ListGraph CmmStmt)) -> CmmLint ()
-lintCmmTop (CmmProc _ lbl _ (ListGraph blocks))
+lintCmmTop (CmmProc _ lbl (ListGraph blocks))
= addLintInfo (text "in proc " <> pprCLabel lbl) $
- let labels = foldl (\s b -> extendBlockSet s (blockId b)) emptyBlockSet blocks
+ let labels = foldl (\s b -> setInsert (blockId b) s) setEmpty blocks
in mapM_ (lintCmmBlock labels) blocks
lintCmmTop (CmmData {})
lint (CmmJump e args) = lintCmmExpr e >> mapM_ (lintCmmExpr . hintlessCmm) args
lint (CmmReturn ress) = mapM_ (lintCmmExpr . hintlessCmm) ress
lint (CmmBranch id) = checkTarget id
- checkTarget id = if elemBlockSet id labels then return ()
+ checkTarget id = if setMember id labels then return ()
else cmmLintErr (text "Branch to nonexistent id" <+> ppr id)
lintTarget :: CmmCallTarget -> CmmLint ()
cmmLintMachOpErr :: CmmExpr -> [CmmType] -> [Width] -> CmmLint a
cmmLintMachOpErr expr argsRep opExpectsRep
= cmmLintErr (text "in MachOp application: " $$
- nest 2 (pprExpr expr) $$
+ nest 2 (ppr expr) $$
(text "op is expecting: " <+> ppr opExpectsRep) $$
(text "arguments provide: " <+> ppr argsRep))
cmmLintAssignErr :: CmmStmt -> CmmType -> CmmType -> CmmLint a
cmmLintAssignErr stmt e_ty r_ty
= cmmLintErr (text "in assignment: " $$
- nest 2 (vcat [pprStmt stmt,
+ nest 2 (vcat [ppr stmt,
text "Reg ty:" <+> ppr r_ty,
text "Rhs ty:" <+> ppr e_ty]))
cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a
cmmLintDubiousWordOffset expr
= cmmLintErr (text "offset is not a multiple of words: " $$
- nest 2 (pprExpr expr))
+ nest 2 (ppr expr))
-module CmmLive (
- CmmLive,
- BlockEntryLiveness,
- cmmLiveness,
- cmmFormalsToLiveLocals,
- ) where
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-#include "HsVersions.h"
+module CmmLive
+ ( CmmLive
+ , cmmLiveness
+ , liveLattice
+ , noLiveOnEntry, xferLive
+ )
+where
import BlockId
import Cmm
-import Dataflow
+import CmmExpr
+import Control.Monad
+import OptimizationFuel
+import PprCmmExpr ()
+import Compiler.Hoopl
import Maybes
-import Panic
+import Outputable
import UniqSet
-----------------------------------------------------------------------------
-----------------------------------------------------------------------------
-- | The variables live on entry to a block
-type CmmLive = UniqSet LocalReg
+type CmmLive = RegSet
+
+-- | The dataflow lattice
+liveLattice :: DataflowLattice CmmLive
+liveLattice = DataflowLattice "live LocalReg's" emptyRegSet add
+ where add _ (OldFact old) (NewFact new) = case unionUniqSets old new of
+ join -> (changeIf $ sizeUniqSet join > sizeUniqSet old, join)
-- | A mapping from block labels to the variables live on entry
type BlockEntryLiveness = BlockEnv CmmLive
--- | A mapping from block labels to the blocks that target it
-type BlockSources = BlockEnv (UniqSet BlockId)
-
--- | A mapping from block labels to the statements in the block
-type BlockStmts = BlockEnv [CmmStmt]
-
------------------------------------------------------------------------------
--- | Calculated liveness info for a list of 'CmmBasicBlock'
------------------------------------------------------------------------------
-cmmLiveness :: [CmmBasicBlock] -> BlockEntryLiveness
-cmmLiveness blocks =
- fixedpoint (cmmBlockDependants sources)
- (cmmBlockUpdate blocks')
- (map blockId blocks)
- (mkBlockEnv [(blockId b, emptyUniqSet) | b <- blocks])
- where
- sources :: BlockSources
- sources = cmmBlockSources blocks
-
- blocks' :: BlockStmts
- blocks' = mkBlockEnv $ map block_name blocks
-
- block_name :: CmmBasicBlock -> (BlockId, [CmmStmt])
- block_name b = (blockId b, blockStmts b)
-
-{-
--- For debugging, annotate each block with a comment indicating
--- the calculated live variables
-cmmLivenessComment ::
- BlockEnv (UniqSet LocalReg) -> CmmBasicBlock -> CmmBasicBlock
-cmmLivenessComment live (BasicBlock ident stmts) =
- BasicBlock ident stmts' where
- stmts' = (CmmComment $ mkFastString $ showSDoc $ ppr $ live'):stmts
- live' = map CmmLocal $ uniqSetToList $ lookupWithDefaultUFM live emptyUniqSet ident
--}
-
-
------------------------------------------------------------------------------
--- | Calculates a table of where one can lookup the blocks that might
--- need updating after a given block is updated in the liveness analysis
------------------------------------------------------------------------------
-cmmBlockSources :: [CmmBasicBlock] -> BlockSources
-cmmBlockSources blocks = foldr aux emptyBlockEnv blocks
- where
- aux :: CmmBasicBlock
- -> BlockSources
- -> BlockSources
- aux block sourcesUFM =
- foldUniqSet (add_source_edges $ blockId block)
- sourcesUFM
- (branch_targets $ blockStmts block)
-
- add_source_edges :: BlockId -> BlockId
- -> BlockSources
- -> BlockSources
- add_source_edges source target ufm =
- addToBEnv_Acc (flip addOneToUniqSet) unitUniqSet ufm target source
-
- branch_targets :: [CmmStmt] -> UniqSet BlockId
- branch_targets stmts =
- mkUniqSet $ concatMap target stmts where
- target (CmmBranch ident) = [ident]
- target (CmmCondBranch _ ident) = [ident]
- target (CmmSwitch _ blocks) = mapMaybe id blocks
- target _ = []
-
------------------------------------------------------------------------------
--- | Given the table calculated by 'cmmBlockSources', list all blocks
--- that depend on the result of a particular block.
---
--- Used by the call to 'fixedpoint'.
------------------------------------------------------------------------------
-cmmBlockDependants :: BlockSources -> BlockId -> [BlockId]
-cmmBlockDependants sources ident =
- uniqSetToList $ lookupWithDefaultBEnv sources emptyUniqSet ident
-
------------------------------------------------------------------------------
--- | Given the table of type 'BlockStmts' and a block that was updated,
--- calculate an updated BlockEntryLiveness
-----------------------------------------------------------------------------
-cmmBlockUpdate ::
- BlockStmts
- -> BlockId
- -> Maybe BlockId
- -> BlockEntryLiveness
- -> Maybe BlockEntryLiveness
-cmmBlockUpdate blocks node _ state =
- if (sizeUniqSet old_live) == (sizeUniqSet new_live)
- then Nothing
- else Just $ extendBlockEnv state node new_live
- where
- new_live, old_live :: CmmLive
- new_live = cmmStmtListLive state block_stmts
- old_live = lookupWithDefaultBEnv state missing_live node
-
- block_stmts :: [CmmStmt]
- block_stmts = lookupWithDefaultBEnv blocks missing_block node
-
- missing_live = panic "unknown block id during liveness analysis"
- missing_block = panic "unknown block id during liveness analysis"
-
+-- | Calculated liveness info for a CmmGraph
-----------------------------------------------------------------------------
--- Section:
------------------------------------------------------------------------------
------------------------------------------------------------------------------
--- CmmBlockLive, cmmStmtListLive and helpers
------------------------------------------------------------------------------
-
--- Calculate the live registers for a local block (list of statements)
-
-cmmStmtListLive :: BlockEntryLiveness -> [CmmStmt] -> CmmLive
-cmmStmtListLive other_live stmts =
- foldr ((.) . (cmmStmtLive other_live)) id stmts emptyUniqSet
-
------------------------------------------------------------------------------
--- This code is written in the style of a state monad,
--- but since Control.Monad.State is not in the core
--- we can't use it in GHC, so we'll fake one here.
--- We don't need a return value so well leave it out.
--- Thus 'bind' reduces to function composition.
-
-type CmmLivenessTransformer = CmmLive -> CmmLive
-
--- Helpers for the "Monad"
-addLive, addKilled :: CmmLive -> CmmLivenessTransformer
-addLive new_live live = live `unionUniqSets` new_live
-addKilled new_killed live = live `minusUniqSet` new_killed
-
---------------------------------
--- Liveness of a CmmStmt
---------------------------------
-cmmFormalsToLiveLocals :: HintedCmmFormals -> [LocalReg]
-cmmFormalsToLiveLocals formals = map hintlessCmm formals
-
-cmmStmtLive :: BlockEntryLiveness -> CmmStmt -> CmmLivenessTransformer
-cmmStmtLive _ (CmmNop) = id
-cmmStmtLive _ (CmmComment _) = id
-cmmStmtLive _ (CmmAssign reg expr) =
- cmmExprLive expr . reg_liveness where
- reg_liveness =
- case reg of
- (CmmLocal reg') -> addKilled $ unitUniqSet reg'
- (CmmGlobal _) -> id
-cmmStmtLive _ (CmmStore expr1 expr2) =
- cmmExprLive expr2 . cmmExprLive expr1
-cmmStmtLive _ (CmmCall target results arguments _ _) =
- target_liveness .
- foldr ((.) . cmmExprLive) id (map hintlessCmm arguments) .
- addKilled (mkUniqSet $ cmmFormalsToLiveLocals results) where
- target_liveness =
- case target of
- (CmmCallee target _) -> cmmExprLive target
- (CmmPrim _) -> id
-cmmStmtLive other_live (CmmBranch target) =
- addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
-cmmStmtLive other_live (CmmCondBranch expr target) =
- cmmExprLive expr .
- addLive (lookupWithDefaultBEnv other_live emptyUniqSet target)
-cmmStmtLive other_live (CmmSwitch expr targets) =
- cmmExprLive expr .
- (foldr ((.) . (addLive .
- lookupWithDefaultBEnv other_live emptyUniqSet))
- id
- (mapCatMaybes id targets))
-cmmStmtLive _ (CmmJump expr params) =
- const (cmmExprLive expr $ foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet)
-cmmStmtLive _ (CmmReturn params) =
- const (foldr ((.) . cmmExprLive) id (map hintlessCmm params) $ emptyUniqSet)
-
---------------------------------
--- Liveness of a CmmExpr
---------------------------------
-cmmExprLive :: CmmExpr -> CmmLivenessTransformer
-cmmExprLive expr = addLive (mkUniqSet $ expr_liveness expr) where
- expr_liveness :: CmmExpr -> [LocalReg]
- expr_liveness (CmmLit _) = []
- expr_liveness (CmmLoad expr _) = expr_liveness expr
- expr_liveness (CmmReg reg) = reg_liveness reg
- expr_liveness (CmmMachOp _ exprs) = concatMap expr_liveness exprs
- expr_liveness (CmmRegOff reg _) = reg_liveness reg
- expr_liveness (CmmStackSlot _ _) = panic "cmmExprLive CmmStackSlot"
- reg_liveness :: CmmReg -> [LocalReg]
- reg_liveness (CmmLocal reg) = [reg]
- reg_liveness (CmmGlobal _) = []
+cmmLiveness :: CmmGraph -> FuelUniqSM BlockEntryLiveness
+cmmLiveness graph =
+ liftM check $ liftM snd $ dataflowPassBwd graph [] $ analBwd liveLattice xferLive
+ where entry = g_entry graph
+ check facts = noLiveOnEntry entry (expectJust "check" $ mapLookup entry facts) facts
+
+gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
+gen_kill a = gen a . kill a
+
+-- | On entry to the procedure, there had better not be any LocalReg's live-in.
+noLiveOnEntry :: BlockId -> CmmLive -> a -> a
+noLiveOnEntry bid in_fact x =
+ if isEmptyUniqSet in_fact then x
+ else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
+
+-- | The transfer equations use the traditional 'gen' and 'kill'
+-- notations, which should be familiar from the dragon book.
+gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
+gen a live = foldRegsUsed extendRegSet live a
+kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
+kill a live = foldRegsDefd delOneFromUniqSet live a
+
+xferLive :: BwdTransfer CmmNode CmmLive
+xferLive = mkBTransfer3 fst mid lst
+ where fst _ f = f
+ mid :: CmmNode O O -> CmmLive -> CmmLive
+ mid n f = gen_kill n $ case n of CmmUnsafeForeignCall {} -> emptyRegSet
+ _ -> f
+ lst :: CmmNode O C -> FactBase CmmLive -> CmmLive
+ lst n f = gen_kill n $ case n of CmmCall {} -> emptyRegSet
+ CmmForeignCall {} -> emptyRegSet
+ _ -> joinOutFacts liveLattice n f
+++ /dev/null
-
-module CmmLiveZ
- ( CmmLive
- , cmmLivenessZ
- , liveLattice
- , middleLiveness, noLiveOnEntry
- )
-where
-
-import BlockId
-import CmmExpr
-import CmmTx
-import DFMonad
-import Control.Monad
-import PprCmm()
-import PprCmmZ()
-import ZipCfg
-import ZipDataflow
-import ZipCfgCmmRep
-
-import Maybes
-import Outputable
-import UniqSet
-
------------------------------------------------------------------------------
--- Calculating what variables are live on entry to a basic block
------------------------------------------------------------------------------
-
--- | The variables live on entry to a block
-type CmmLive = RegSet
-
--- | The dataflow lattice
-liveLattice :: DataflowLattice CmmLive
-liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False
- where add new old =
- let join = unionUniqSets new old in
- (if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join
-
--- | A mapping from block labels to the variables live on entry
-type BlockEntryLiveness = BlockEnv CmmLive
-
------------------------------------------------------------------------------
--- | Calculated liveness info for a CmmGraph
------------------------------------------------------------------------------
-cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness
-cmmLivenessZ g@(LGraph entry _) =
- liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive))
- where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers
- emptyUniqSet (graphOfLGraph g)
- transfers = BackwardTransfers (flip const) mid last
- mid m = gen_kill m . midLive m
- last l = gen_kill l . lastLive l
- check facts =
- noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts
-
-gen_kill :: (DefinerOfLocalRegs a, UserOfLocalRegs a) => a -> CmmLive -> CmmLive
-gen_kill a = gen a . kill a
-
-middleLiveness :: Middle -> CmmLive -> CmmLive
-middleLiveness = gen_kill
-
--- | On entry to the procedure, there had better not be any LocalReg's live-in.
-noLiveOnEntry :: BlockId -> CmmLive -> a -> a
-noLiveOnEntry bid in_fact x =
- if isEmptyUniqSet in_fact then x
- else pprPanic "LocalReg's live-in to graph" (ppr bid <+> ppr in_fact)
-
--- | The transfer equations use the traditional 'gen' and 'kill'
--- notations, which should be familiar from the dragon book.
-gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
-gen a live = foldRegsUsed extendRegSet live a
-kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
-kill a live = foldRegsDefd delOneFromUniqSet live a
-
-midLive :: Middle -> CmmLive -> CmmLive
-midLive (MidForeignCall {}) _ = emptyUniqSet
-midLive _ live = live
-
-lastLive :: Last -> (BlockId -> CmmLive) -> CmmLive
-lastLive l env = last l
- where last (LastBranch id) = env id
- last (LastCall _ _ _ _ _) = emptyUniqSet
- last (LastCondBranch _ t f) = unionUniqSets (env t) (env f)
- last (LastSwitch _ tbl) = unionManyUniqSets $ map env (catMaybes tbl)
--- /dev/null
+
+module CmmMachOp
+ ( MachOp(..)
+ , pprMachOp, isCommutableMachOp, isAssociativeMachOp
+ , isComparisonMachOp, machOpResultType
+ , machOpArgReps, maybeInvertComparison
+
+ -- MachOp builders
+ , mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+ , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+ , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+ , mo_wordULe, mo_wordUGt, mo_wordULt
+ , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
+ , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+ , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
+ , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
+
+ -- CallishMachOp
+ , CallishMachOp(..)
+ , pprCallishMachOp
+ )
+where
+
+#include "HsVersions.h"
+
+import CmmType
+import Outputable
+
+-----------------------------------------------------------------------------
+-- MachOp
+-----------------------------------------------------------------------------
+
+{-
+Implementation notes:
+
+It might suffice to keep just a width, without distinguishing between
+floating and integer types. However, keeping the distinction will
+help the native code generator to assign registers more easily.
+-}
+
+
+{- |
+Machine-level primops; ones which we can reasonably delegate to the
+native code generators to handle. Basically contains C's primops
+and no others.
+
+Nomenclature: all ops indicate width and signedness, where
+appropriate. Widths: 8\/16\/32\/64 means the given size, obviously.
+Nat means the operation works on STG word sized objects.
+Signedness: S means signed, U means unsigned. For operations where
+signedness is irrelevant or makes no difference (for example
+integer add), the signedness component is omitted.
+
+An exception: NatP is a ptr-typed native word. From the point of
+view of the native code generators this distinction is irrelevant,
+but the C code generator sometimes needs this info to emit the
+right casts.
+-}
+
+data MachOp
+ -- Integer operations (insensitive to signed/unsigned)
+ = MO_Add Width
+ | MO_Sub Width
+ | MO_Eq Width
+ | MO_Ne Width
+ | MO_Mul Width -- low word of multiply
+
+ -- Signed multiply/divide
+ | MO_S_MulMayOflo Width -- nonzero if signed multiply overflows
+ | MO_S_Quot Width -- signed / (same semantics as IntQuotOp)
+ | MO_S_Rem Width -- signed % (same semantics as IntRemOp)
+ | MO_S_Neg Width -- unary -
+
+ -- Unsigned multiply/divide
+ | MO_U_MulMayOflo Width -- nonzero if unsigned multiply overflows
+ | MO_U_Quot Width -- unsigned / (same semantics as WordQuotOp)
+ | MO_U_Rem Width -- unsigned % (same semantics as WordRemOp)
+
+ -- Signed comparisons
+ | MO_S_Ge Width
+ | MO_S_Le Width
+ | MO_S_Gt Width
+ | MO_S_Lt Width
+
+ -- Unsigned comparisons
+ | MO_U_Ge Width
+ | MO_U_Le Width
+ | MO_U_Gt Width
+ | MO_U_Lt Width
+
+ -- Floating point arithmetic
+ | MO_F_Add Width
+ | MO_F_Sub Width
+ | MO_F_Neg Width -- unary -
+ | MO_F_Mul Width
+ | MO_F_Quot Width
+
+ -- Floating point comparison
+ | MO_F_Eq Width
+ | MO_F_Ne Width
+ | MO_F_Ge Width
+ | MO_F_Le Width
+ | MO_F_Gt Width
+ | MO_F_Lt Width
+
+ -- Bitwise operations. Not all of these may be supported
+ -- at all sizes, and only integral Widths are valid.
+ | MO_And Width
+ | MO_Or Width
+ | MO_Xor Width
+ | MO_Not Width
+ | MO_Shl Width
+ | MO_U_Shr Width -- unsigned shift right
+ | MO_S_Shr Width -- signed shift right
+
+ -- Conversions. Some of these will be NOPs.
+ -- Floating-point conversions use the signed variant.
+ | MO_SF_Conv Width Width -- Signed int -> Float
+ | MO_FS_Conv Width Width -- Float -> Signed int
+ | MO_SS_Conv Width Width -- Signed int -> Signed int
+ | MO_UU_Conv Width Width -- unsigned int -> unsigned int
+ | MO_FF_Conv Width Width -- Float -> Float
+ deriving (Eq, Show)
+
+pprMachOp :: MachOp -> SDoc
+pprMachOp mo = text (show mo)
+
+
+
+-- -----------------------------------------------------------------------------
+-- Some common MachReps
+
+-- A 'wordRep' is a machine word on the target architecture
+-- Specifically, it is the size of an Int#, Word#, Addr#
+-- and the unit of allocation on the stack and the heap
+-- Any pointer is also guaranteed to be a wordRep.
+
+mo_wordAdd, mo_wordSub, mo_wordEq, mo_wordNe,mo_wordMul, mo_wordSQuot
+ , mo_wordSRem, mo_wordSNeg, mo_wordUQuot, mo_wordURem
+ , mo_wordSGe, mo_wordSLe, mo_wordSGt, mo_wordSLt, mo_wordUGe
+ , mo_wordULe, mo_wordUGt, mo_wordULt
+ , mo_wordAnd, mo_wordOr, mo_wordXor, mo_wordNot, mo_wordShl, mo_wordSShr, mo_wordUShr
+ , mo_u_8To32, mo_s_8To32, mo_u_16To32, mo_s_16To32
+ , mo_u_8ToWord, mo_s_8ToWord, mo_u_16ToWord, mo_s_16ToWord, mo_u_32ToWord, mo_s_32ToWord
+ , mo_32To8, mo_32To16, mo_WordTo8, mo_WordTo16, mo_WordTo32
+ :: MachOp
+
+mo_wordAdd = MO_Add wordWidth
+mo_wordSub = MO_Sub wordWidth
+mo_wordEq = MO_Eq wordWidth
+mo_wordNe = MO_Ne wordWidth
+mo_wordMul = MO_Mul wordWidth
+mo_wordSQuot = MO_S_Quot wordWidth
+mo_wordSRem = MO_S_Rem wordWidth
+mo_wordSNeg = MO_S_Neg wordWidth
+mo_wordUQuot = MO_U_Quot wordWidth
+mo_wordURem = MO_U_Rem wordWidth
+
+mo_wordSGe = MO_S_Ge wordWidth
+mo_wordSLe = MO_S_Le wordWidth
+mo_wordSGt = MO_S_Gt wordWidth
+mo_wordSLt = MO_S_Lt wordWidth
+
+mo_wordUGe = MO_U_Ge wordWidth
+mo_wordULe = MO_U_Le wordWidth
+mo_wordUGt = MO_U_Gt wordWidth
+mo_wordULt = MO_U_Lt wordWidth
+
+mo_wordAnd = MO_And wordWidth
+mo_wordOr = MO_Or wordWidth
+mo_wordXor = MO_Xor wordWidth
+mo_wordNot = MO_Not wordWidth
+mo_wordShl = MO_Shl wordWidth
+mo_wordSShr = MO_S_Shr wordWidth
+mo_wordUShr = MO_U_Shr wordWidth
+
+mo_u_8To32 = MO_UU_Conv W8 W32
+mo_s_8To32 = MO_SS_Conv W8 W32
+mo_u_16To32 = MO_UU_Conv W16 W32
+mo_s_16To32 = MO_SS_Conv W16 W32
+
+mo_u_8ToWord = MO_UU_Conv W8 wordWidth
+mo_s_8ToWord = MO_SS_Conv W8 wordWidth
+mo_u_16ToWord = MO_UU_Conv W16 wordWidth
+mo_s_16ToWord = MO_SS_Conv W16 wordWidth
+mo_s_32ToWord = MO_SS_Conv W32 wordWidth
+mo_u_32ToWord = MO_UU_Conv W32 wordWidth
+
+mo_WordTo8 = MO_UU_Conv wordWidth W8
+mo_WordTo16 = MO_UU_Conv wordWidth W16
+mo_WordTo32 = MO_UU_Conv wordWidth W32
+
+mo_32To8 = MO_UU_Conv W32 W8
+mo_32To16 = MO_UU_Conv W32 W16
+
+
+-- ----------------------------------------------------------------------------
+-- isCommutableMachOp
+
+{- |
+Returns 'True' if the MachOp has commutable arguments. This is used
+in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'. This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isCommutableMachOp :: MachOp -> Bool
+isCommutableMachOp mop =
+ case mop of
+ MO_Add _ -> True
+ MO_Eq _ -> True
+ MO_Ne _ -> True
+ MO_Mul _ -> True
+ MO_S_MulMayOflo _ -> True
+ MO_U_MulMayOflo _ -> True
+ MO_And _ -> True
+ MO_Or _ -> True
+ MO_Xor _ -> True
+ _other -> False
+
+-- ----------------------------------------------------------------------------
+-- isAssociativeMachOp
+
+{- |
+Returns 'True' if the MachOp is associative (i.e. @(x+y)+z == x+(y+z)@)
+This is used in the platform-independent Cmm optimisations.
+
+If in doubt, return 'False'. This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isAssociativeMachOp :: MachOp -> Bool
+isAssociativeMachOp mop =
+ case mop of
+ MO_Add {} -> True -- NB: does not include
+ MO_Mul {} -> True -- floatint point!
+ MO_And {} -> True
+ MO_Or {} -> True
+ MO_Xor {} -> True
+ _other -> False
+
+-- ----------------------------------------------------------------------------
+-- isComparisonMachOp
+
+{- |
+Returns 'True' if the MachOp is a comparison.
+
+If in doubt, return False. This generates worse code on the
+native routes, but is otherwise harmless.
+-}
+isComparisonMachOp :: MachOp -> Bool
+isComparisonMachOp mop =
+ case mop of
+ MO_Eq _ -> True
+ MO_Ne _ -> True
+ MO_S_Ge _ -> True
+ MO_S_Le _ -> True
+ MO_S_Gt _ -> True
+ MO_S_Lt _ -> True
+ MO_U_Ge _ -> True
+ MO_U_Le _ -> True
+ MO_U_Gt _ -> True
+ MO_U_Lt _ -> True
+ MO_F_Eq {} -> True
+ MO_F_Ne {} -> True
+ MO_F_Ge {} -> True
+ MO_F_Le {} -> True
+ MO_F_Gt {} -> True
+ MO_F_Lt {} -> True
+ _other -> False
+
+-- -----------------------------------------------------------------------------
+-- Inverting conditions
+
+-- Sometimes it's useful to be able to invert the sense of a
+-- condition. Not all conditional tests are invertible: in
+-- particular, floating point conditionals cannot be inverted, because
+-- there exist floating-point values which return False for both senses
+-- of a condition (eg. !(NaN > NaN) && !(NaN /<= NaN)).
+
+maybeInvertComparison :: MachOp -> Maybe MachOp
+maybeInvertComparison op
+ = case op of -- None of these Just cases include floating point
+ MO_Eq r -> Just (MO_Ne r)
+ MO_Ne r -> Just (MO_Eq r)
+ MO_U_Lt r -> Just (MO_U_Ge r)
+ MO_U_Gt r -> Just (MO_U_Le r)
+ MO_U_Le r -> Just (MO_U_Gt r)
+ MO_U_Ge r -> Just (MO_U_Lt r)
+ MO_S_Lt r -> Just (MO_S_Ge r)
+ MO_S_Gt r -> Just (MO_S_Le r)
+ MO_S_Le r -> Just (MO_S_Gt r)
+ MO_S_Ge r -> Just (MO_S_Lt r)
+ MO_F_Eq r -> Just (MO_F_Ne r)
+ MO_F_Ne r -> Just (MO_F_Eq r)
+ MO_F_Ge r -> Just (MO_F_Le r)
+ MO_F_Le r -> Just (MO_F_Ge r)
+ MO_F_Gt r -> Just (MO_F_Lt r)
+ MO_F_Lt r -> Just (MO_F_Gt r)
+ _other -> Nothing
+
+-- ----------------------------------------------------------------------------
+-- machOpResultType
+
+{- |
+Returns the MachRep of the result of a MachOp.
+-}
+machOpResultType :: MachOp -> [CmmType] -> CmmType
+machOpResultType mop tys =
+ case mop of
+ MO_Add {} -> ty1 -- Preserve GC-ptr-hood
+ MO_Sub {} -> ty1 -- of first arg
+ MO_Mul r -> cmmBits r
+ MO_S_MulMayOflo r -> cmmBits r
+ MO_S_Quot r -> cmmBits r
+ MO_S_Rem r -> cmmBits r
+ MO_S_Neg r -> cmmBits r
+ MO_U_MulMayOflo r -> cmmBits r
+ MO_U_Quot r -> cmmBits r
+ MO_U_Rem r -> cmmBits r
+
+ MO_Eq {} -> comparisonResultRep
+ MO_Ne {} -> comparisonResultRep
+ MO_S_Ge {} -> comparisonResultRep
+ MO_S_Le {} -> comparisonResultRep
+ MO_S_Gt {} -> comparisonResultRep
+ MO_S_Lt {} -> comparisonResultRep
+
+ MO_U_Ge {} -> comparisonResultRep
+ MO_U_Le {} -> comparisonResultRep
+ MO_U_Gt {} -> comparisonResultRep
+ MO_U_Lt {} -> comparisonResultRep
+
+ MO_F_Add r -> cmmFloat r
+ MO_F_Sub r -> cmmFloat r
+ MO_F_Mul r -> cmmFloat r
+ MO_F_Quot r -> cmmFloat r
+ MO_F_Neg r -> cmmFloat r
+ MO_F_Eq {} -> comparisonResultRep
+ MO_F_Ne {} -> comparisonResultRep
+ MO_F_Ge {} -> comparisonResultRep
+ MO_F_Le {} -> comparisonResultRep
+ MO_F_Gt {} -> comparisonResultRep
+ MO_F_Lt {} -> comparisonResultRep
+
+ MO_And {} -> ty1 -- Used for pointer masking
+ MO_Or {} -> ty1
+ MO_Xor {} -> ty1
+ MO_Not r -> cmmBits r
+ MO_Shl r -> cmmBits r
+ MO_U_Shr r -> cmmBits r
+ MO_S_Shr r -> cmmBits r
+
+ MO_SS_Conv _ to -> cmmBits to
+ MO_UU_Conv _ to -> cmmBits to
+ MO_FS_Conv _ to -> cmmBits to
+ MO_SF_Conv _ to -> cmmFloat to
+ MO_FF_Conv _ to -> cmmFloat to
+ where
+ (ty1:_) = tys
+
+comparisonResultRep :: CmmType
+comparisonResultRep = bWord -- is it?
+
+
+-- -----------------------------------------------------------------------------
+-- machOpArgReps
+
+-- | This function is used for debugging only: we can check whether an
+-- application of a MachOp is "type-correct" by checking that the MachReps of
+-- its arguments are the same as the MachOp expects. This is used when
+-- linting a CmmExpr.
+
+machOpArgReps :: MachOp -> [Width]
+machOpArgReps op =
+ case op of
+ MO_Add r -> [r,r]
+ MO_Sub r -> [r,r]
+ MO_Eq r -> [r,r]
+ MO_Ne r -> [r,r]
+ MO_Mul r -> [r,r]
+ MO_S_MulMayOflo r -> [r,r]
+ MO_S_Quot r -> [r,r]
+ MO_S_Rem r -> [r,r]
+ MO_S_Neg r -> [r]
+ MO_U_MulMayOflo r -> [r,r]
+ MO_U_Quot r -> [r,r]
+ MO_U_Rem r -> [r,r]
+
+ MO_S_Ge r -> [r,r]
+ MO_S_Le r -> [r,r]
+ MO_S_Gt r -> [r,r]
+ MO_S_Lt r -> [r,r]
+
+ MO_U_Ge r -> [r,r]
+ MO_U_Le r -> [r,r]
+ MO_U_Gt r -> [r,r]
+ MO_U_Lt r -> [r,r]
+
+ MO_F_Add r -> [r,r]
+ MO_F_Sub r -> [r,r]
+ MO_F_Mul r -> [r,r]
+ MO_F_Quot r -> [r,r]
+ MO_F_Neg r -> [r]
+ MO_F_Eq r -> [r,r]
+ MO_F_Ne r -> [r,r]
+ MO_F_Ge r -> [r,r]
+ MO_F_Le r -> [r,r]
+ MO_F_Gt r -> [r,r]
+ MO_F_Lt r -> [r,r]
+
+ MO_And r -> [r,r]
+ MO_Or r -> [r,r]
+ MO_Xor r -> [r,r]
+ MO_Not r -> [r]
+ MO_Shl r -> [r,wordWidth]
+ MO_U_Shr r -> [r,wordWidth]
+ MO_S_Shr r -> [r,wordWidth]
+
+ MO_SS_Conv from _ -> [from]
+ MO_UU_Conv from _ -> [from]
+ MO_SF_Conv from _ -> [from]
+ MO_FS_Conv from _ -> [from]
+ MO_FF_Conv from _ -> [from]
+
+-----------------------------------------------------------------------------
+-- CallishMachOp
+-----------------------------------------------------------------------------
+
+-- CallishMachOps tend to be implemented by foreign calls in some backends,
+-- so we separate them out. In Cmm, these can only occur in a
+-- statement position, in contrast to an ordinary MachOp which can occur
+-- anywhere in an expression.
+data CallishMachOp
+ = MO_F64_Pwr
+ | MO_F64_Sin
+ | MO_F64_Cos
+ | MO_F64_Tan
+ | MO_F64_Sinh
+ | MO_F64_Cosh
+ | MO_F64_Tanh
+ | MO_F64_Asin
+ | MO_F64_Acos
+ | MO_F64_Atan
+ | MO_F64_Log
+ | MO_F64_Exp
+ | MO_F64_Sqrt
+ | MO_F32_Pwr
+ | MO_F32_Sin
+ | MO_F32_Cos
+ | MO_F32_Tan
+ | MO_F32_Sinh
+ | MO_F32_Cosh
+ | MO_F32_Tanh
+ | MO_F32_Asin
+ | MO_F32_Acos
+ | MO_F32_Atan
+ | MO_F32_Log
+ | MO_F32_Exp
+ | MO_F32_Sqrt
+ | MO_WriteBarrier
+ | MO_Touch -- Keep variables live (when using interior pointers)
+ deriving (Eq, Show)
+
+pprCallishMachOp :: CallishMachOp -> SDoc
+pprCallishMachOp mo = text (show mo)
--- /dev/null
+-- CmmNode type for representation using Hoopl graphs.
+{-# LANGUAGE GADTs #-}
+module CmmNode
+ ( CmmNode(..)
+ , UpdFrameOffset, Convention(..), ForeignConvention(..), ForeignTarget(..)
+ , mapExp, mapExpDeep, foldExp, foldExpDeep
+ )
+where
+
+import CmmExpr
+import CmmDecl
+import FastString
+import ForeignCall
+import SMRep
+
+import Compiler.Hoopl
+import Data.Maybe
+import Prelude hiding (succ)
+
+
+------------------------
+-- CmmNode
+
+data CmmNode e x where
+ CmmEntry :: Label -> CmmNode C O
+ CmmComment :: FastString -> CmmNode O O
+ CmmAssign :: CmmReg -> CmmExpr -> CmmNode O O -- Assign to register
+ CmmStore :: CmmExpr -> CmmExpr -> CmmNode O O -- Assign to memory location. Size is
+ -- given by cmmExprType of the rhs.
+ CmmUnsafeForeignCall :: -- An unsafe foreign call; see Note [Foreign calls]
+ ForeignTarget -> -- call target
+ CmmFormals -> -- zero or more results
+ CmmActuals -> -- zero or more arguments
+ CmmNode O O
+ CmmBranch :: Label -> CmmNode O C -- Goto another block in the same procedure
+ CmmCondBranch :: { -- conditional branch
+ cml_pred :: CmmExpr,
+ cml_true, cml_false :: Label
+ } -> CmmNode O C
+ CmmSwitch :: CmmExpr -> [Maybe Label] -> CmmNode O C -- Table branch
+ -- The scrutinee is zero-based;
+ -- zero -> first block
+ -- one -> second block etc
+ -- Undefined outside range, and when there's a Nothing
+ CmmCall :: { -- A call (native or safe foreign)
+ cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
+
+ cml_cont :: Maybe Label,
+ -- Label of continuation (Nothing for return or tail call)
+
+ cml_args :: ByteOff,
+ -- Byte offset, from the *old* end of the Area associated with
+ -- the Label (if cml_cont = Nothing, then Old area), of
+ -- youngest outgoing arg. Set the stack pointer to this before
+ -- transferring control.
+ -- (NB: an update frame might also have been stored in the Old
+ -- area, but it'll be in an older part than the args.)
+
+ cml_ret_args :: ByteOff,
+ -- For calls *only*, the byte offset for youngest returned value
+ -- This is really needed at the *return* point rather than here
+ -- at the call, but in practice it's convenient to record it here.
+
+ cml_ret_off :: ByteOff
+ -- For calls *only*, the byte offset of the base of the frame that
+ -- must be described by the info table for the return point.
+ -- The older words are an update frames, which have their own
+ -- info-table and layout information
+
+ -- From a liveness point of view, the stack words older than
+ -- cml_ret_off are treated as live, even if the sequel of
+ -- the call goes into a loop.
+ } -> CmmNode O C
+ CmmForeignCall :: { -- A safe foreign call; see Note [Foreign calls]
+ tgt :: ForeignTarget, -- call target and convention
+ res :: CmmFormals, -- zero or more results
+ args :: CmmActuals, -- zero or more arguments
+ succ :: Label, -- Label of continuation
+ updfr :: UpdFrameOffset, -- where the update frame is (for building infotable)
+ intrbl:: Bool -- whether or not the call is interruptible
+ } -> CmmNode O C
+
+{- Note [Foreign calls]
+~~~~~~~~~~~~~~~~~~~~~~~
+A MidForeign call is used for *unsafe* foreign calls;
+a LastForeign call is used for *safe* foreign calls.
+Unsafe ones are easy: think of them as a "fat machine instruction".
+
+Safe ones are trickier. A safe foreign call
+ r = f(x)
+ultimately expands to
+ push "return address" -- Never used to return to;
+ -- just points an info table
+ save registers into TSO
+ call suspendThread
+ r = f(x) -- Make the call
+ call resumeThread
+ restore registers
+ pop "return address"
+We cannot "lower" a safe foreign call to this sequence of Cmms, because
+after we've saved Sp all the Cmm optimiser's assumptions are broken.
+Furthermore, currently the smart Cmm constructors know the calling
+conventions for Haskell, the garbage collector, etc, and "lower" them
+so that a LastCall passes no parameters or results. But the smart
+constructors do *not* (currently) know the foreign call conventions.
+
+Note that a safe foreign call needs an info table.
+-}
+
+---------------------------------------------
+-- Eq instance of CmmNode
+-- It is a shame GHC cannot infer it by itself :(
+
+instance Eq (CmmNode e x) where
+ (CmmEntry a) == (CmmEntry a') = a==a'
+ (CmmComment a) == (CmmComment a') = a==a'
+ (CmmAssign a b) == (CmmAssign a' b') = a==a' && b==b'
+ (CmmStore a b) == (CmmStore a' b') = a==a' && b==b'
+ (CmmUnsafeForeignCall a b c) == (CmmUnsafeForeignCall a' b' c') = a==a' && b==b' && c==c'
+ (CmmBranch a) == (CmmBranch a') = a==a'
+ (CmmCondBranch a b c) == (CmmCondBranch a' b' c') = a==a' && b==b' && c==c'
+ (CmmSwitch a b) == (CmmSwitch a' b') = a==a' && b==b'
+ (CmmCall a b c d e) == (CmmCall a' b' c' d' e') = a==a' && b==b' && c==c' && d==d' && e==e'
+ (CmmForeignCall a b c d e f) == (CmmForeignCall a' b' c' d' e' f') = a==a' && b==b' && c==c' && d==d' && e==e' && f==f'
+ _ == _ = False
+
+----------------------------------------------
+-- Hoopl instances of CmmNode
+
+instance NonLocal CmmNode where
+ entryLabel (CmmEntry l) = l
+ -- entryLabel _ = error "CmmNode.entryLabel"
+
+ successors (CmmBranch l) = [l]
+ successors (CmmCondBranch {cml_true=t, cml_false=f}) = [f, t] -- meets layout constraint
+ successors (CmmSwitch _ ls) = catMaybes ls
+ successors (CmmCall {cml_cont=l}) = maybeToList l
+ successors (CmmForeignCall {succ=l}) = [l]
+ -- successors _ = error "CmmNode.successors"
+
+
+instance HooplNode CmmNode where
+ mkBranchNode label = CmmBranch label
+ mkLabelNode label = CmmEntry label
+
+--------------------------------------------------
+-- Various helper types
+
+type UpdFrameOffset = ByteOff
+
+data Convention
+ = NativeDirectCall -- Native C-- call skipping the node (closure) argument
+ | NativeNodeCall -- Native C-- call including the node argument
+ | NativeReturn -- Native C-- return
+ | Slow -- Slow entry points: all args pushed on the stack
+ | GC -- Entry to the garbage collector: uses the node reg!
+ | PrimOpCall -- Calling prim ops
+ | PrimOpReturn -- Returning from prim ops
+ | Foreign -- Foreign call/return
+ ForeignConvention
+ | Private
+ -- Used for control transfers within a (pre-CPS) procedure All
+ -- jump sites known, never pushed on the stack (hence no SRT)
+ -- You can choose whatever calling convention you please
+ -- (provided you make sure all the call sites agree)!
+ -- This data type eventually to be extended to record the convention.
+ deriving( Eq )
+
+data ForeignConvention
+ = ForeignConvention
+ CCallConv -- Which foreign-call convention
+ [ForeignHint] -- Extra info about the args
+ [ForeignHint] -- Extra info about the result
+ deriving Eq
+
+data ForeignTarget -- The target of a foreign call
+ = ForeignTarget -- A foreign procedure
+ CmmExpr -- Its address
+ ForeignConvention -- Its calling convention
+ | PrimTarget -- A possibly-side-effecting machine operation
+ CallishMachOp -- Which one
+ deriving Eq
+
+--------------------------------------------------
+-- Instances of register and slot users / definers
+
+instance UserOfLocalRegs (CmmNode e x) where
+ foldRegsUsed f z n = case n of
+ CmmAssign _ expr -> fold f z expr
+ CmmStore addr rval -> fold f (fold f z addr) rval
+ CmmUnsafeForeignCall t _ args -> fold f (fold f z t) args
+ CmmCondBranch expr _ _ -> fold f z expr
+ CmmSwitch expr _ -> fold f z expr
+ CmmCall {cml_target=tgt} -> fold f z tgt
+ CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+ _ -> z
+ where fold :: forall a b.
+ UserOfLocalRegs a =>
+ (b -> LocalReg -> b) -> b -> a -> b
+ fold f z n = foldRegsUsed f z n
+
+instance UserOfLocalRegs ForeignTarget where
+ foldRegsUsed _f z (PrimTarget _) = z
+ foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
+
+instance DefinerOfLocalRegs (CmmNode e x) where
+ foldRegsDefd f z n = case n of
+ CmmAssign lhs _ -> fold f z lhs
+ CmmUnsafeForeignCall _ fs _ -> fold f z fs
+ CmmForeignCall {res=res} -> fold f z res
+ _ -> z
+ where fold :: forall a b.
+ DefinerOfLocalRegs a =>
+ (b -> LocalReg -> b) -> b -> a -> b
+ fold f z n = foldRegsDefd f z n
+
+
+instance UserOfSlots (CmmNode e x) where
+ foldSlotsUsed f z n = case n of
+ CmmAssign _ expr -> fold f z expr
+ CmmStore addr rval -> fold f (fold f z addr) rval
+ CmmUnsafeForeignCall _ _ args -> fold f z args
+ CmmCondBranch expr _ _ -> fold f z expr
+ CmmSwitch expr _ -> fold f z expr
+ CmmCall {cml_target=tgt} -> fold f z tgt
+ CmmForeignCall {tgt=tgt, args=args} -> fold f (fold f z tgt) args
+ _ -> z
+ where fold :: forall a b.
+ UserOfSlots a =>
+ (b -> SubArea -> b) -> b -> a -> b
+ fold f z n = foldSlotsUsed f z n
+
+instance UserOfSlots ForeignTarget where
+ foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
+ foldSlotsUsed _f z (PrimTarget _) = z
+
+instance DefinerOfSlots (CmmNode e x) where
+ foldSlotsDefd f z n = case n of
+ CmmStore (CmmStackSlot a i) expr -> f z (a, i, widthInBytes $ typeWidth $ cmmExprType expr)
+ CmmForeignCall {res=res} -> fold f z $ map foreign_call_slot res
+ _ -> z
+ where
+ fold :: forall a b.
+ DefinerOfSlots a =>
+ (b -> SubArea -> b) -> b -> a -> b
+ fold f z n = foldSlotsDefd f z n
+ foreign_call_slot r = case widthInBytes $ typeWidth $ localRegType r of w -> (RegSlot r, w, w)
+
+-----------------------------------
+-- mapping Expr in CmmNode
+
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
+mapForeignTarget exp (ForeignTarget e c) = ForeignTarget (exp e) c
+mapForeignTarget _ m@(PrimTarget _) = m
+
+-- Take a transformer on expressions and apply it recursively.
+wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
+wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
+wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
+wrapRecExp f e = f e
+
+mapExp :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExp _ f@(CmmEntry _) = f
+mapExp _ m@(CmmComment _) = m
+mapExp f (CmmAssign r e) = CmmAssign r (f e)
+mapExp f (CmmStore addr e) = CmmStore (f addr) (f e)
+mapExp f (CmmUnsafeForeignCall tgt fs as) = CmmUnsafeForeignCall (mapForeignTarget f tgt) fs (map f as)
+mapExp _ l@(CmmBranch _) = l
+mapExp f (CmmCondBranch e ti fi) = CmmCondBranch (f e) ti fi
+mapExp f (CmmSwitch e tbl) = CmmSwitch (f e) tbl
+mapExp f (CmmCall tgt mb_id o i s) = CmmCall (f tgt) mb_id o i s
+mapExp f (CmmForeignCall tgt fs as succ updfr intrbl) = CmmForeignCall (mapForeignTarget f tgt) fs (map f as) succ updfr intrbl
+
+mapExpDeep :: (CmmExpr -> CmmExpr) -> CmmNode e x -> CmmNode e x
+mapExpDeep f = mapExp $ wrapRecExp f
+
+-----------------------------------
+-- folding Expr in CmmNode
+
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
+foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
+foldExpForeignTarget _ (PrimTarget _) z = z
+
+-- Take a folder on expressions and apply it recursively.
+wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
+wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
+wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
+wrapRecExpf f e z = f e z
+
+foldExp :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExp _ (CmmEntry {}) z = z
+foldExp _ (CmmComment {}) z = z
+foldExp f (CmmAssign _ e) z = f e z
+foldExp f (CmmStore addr e) z = f addr $ f e z
+foldExp f (CmmUnsafeForeignCall t _ as) z = foldr f (foldExpForeignTarget f t z) as
+foldExp _ (CmmBranch _) z = z
+foldExp f (CmmCondBranch e _ _) z = f e z
+foldExp f (CmmSwitch e _) z = f e z
+foldExp f (CmmCall {cml_target=tgt}) z = f tgt z
+foldExp f (CmmForeignCall {tgt=tgt, args=args}) z = foldr f (foldExpForeignTarget f tgt z) args
+
+foldExpDeep :: (CmmExpr -> z -> z) -> CmmNode e x -> z -> z
+foldExpDeep f = foldExp $ wrapRecExpf f
#include "HsVersions.h"
-import Cmm
-import CmmExpr
+import OldCmm
import CmmUtils
import CLabel
import StaticFlags
-}
cmmLoopifyForC :: RawCmmTop -> RawCmmTop
-cmmLoopifyForC p@(CmmProc info entry_lbl []
+cmmLoopifyForC p@(CmmProc info entry_lbl
(ListGraph blocks@(BasicBlock top_id _ : _)))
| null info = p -- only if there's an info table, ignore case alts
| otherwise =
-- pprTrace "jump_lbl" (ppr jump_lbl <+> ppr entry_lbl) $
- CmmProc info entry_lbl [] (ListGraph blocks')
+ CmmProc info entry_lbl (ListGraph blocks')
where blocks' = [ BasicBlock id (map do_stmt stmts)
| BasicBlock id stmts <- blocks ]
import CostCentre
import BlockId
-import Cmm
-import PprCmm
+import OldCmm
+import OldPprCmm()
import CmmUtils
import CmmLex
import CLabel
-module CmmProcPoint (
- calculateProcPoints
- ) where
+{-# LANGUAGE GADTs, DisambiguateRecordFields #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
-#include "HsVersions.h"
+module CmmProcPoint
+ ( ProcPointSet, Status(..)
+ , callProcPoints, minimalProcPointSet
+ , addProcPointProtocols, splitAtProcPoints, procPointAnalysis
+ )
+where
-import BlockId
-import CmmBrokenBlock
-import Dataflow
+import Prelude hiding (last, unzip, succ, zip)
+import BlockId
+import CLabel
+import Cmm
+import CmmDecl
+import CmmExpr
+import CmmContFlowOpt
+import CmmInfo
+import CmmLive
+import Constants
+import Data.List (sortBy)
+import Maybes
+import MkGraph
+import Control.Monad
+import OptimizationFuel
+import Outputable
import UniqSet
-import Panic
-
--- Determine the proc points for a set of basic blocks.
---
--- A proc point is any basic block that must start a new function.
--- The entry block of the original function is a proc point.
--- The continuation of a function call is also a proc point.
--- The third kind of proc point arises when there is a joint point
--- in the control flow. Suppose we have code like the following:
---
--- if (...) { ...; call foo(); ...}
--- else { ...; call bar(); ...}
--- x = y;
---
--- That last statement "x = y" must be a proc point because
--- it can be reached by blocks owned by different proc points
--- (the two branches of the conditional).
---
--- We calculate these proc points by starting with the minimal set
--- and finding blocks that are reachable from more proc points than
--- one of their parents. (This ensures we don't choose a block
--- simply beause it is reachable from another block that is reachable
--- from multiple proc points.) These new blocks are added to the
--- set of proc points and the process is repeated until there
--- are no more proc points to be found.
-
-calculateProcPoints :: [BrokenBlock] -> UniqSet BlockId
-calculateProcPoints blocks =
- calculateProcPoints' init_proc_points blocks
- where
- init_proc_points = mkUniqSet $
- map brokenBlockId $
- filter always_proc_point blocks
- always_proc_point BrokenBlock {
- brokenBlockEntry = FunctionEntry _ _ _ } = True
- always_proc_point BrokenBlock {
- brokenBlockEntry = ContinuationEntry _ _ _ } = True
- always_proc_point _ = False
-
-calculateProcPoints' :: UniqSet BlockId -> [BrokenBlock] -> UniqSet BlockId
-calculateProcPoints' old_proc_points blocks =
- if sizeUniqSet old_proc_points == sizeUniqSet new_proc_points
- then old_proc_points
- else calculateProcPoints' new_proc_points blocks
- where
- blocks_ufm :: BlockEnv BrokenBlock
- blocks_ufm = blocksToBlockEnv blocks
-
- owners = calculateOwnership blocks_ufm old_proc_points blocks
- new_proc_points =
- unionManyUniqSets
- (old_proc_points:
- map (calculateNewProcPoints owners) blocks)
-
-calculateNewProcPoints :: BlockEnv (UniqSet BlockId)
- -> BrokenBlock
- -> UniqSet BlockId
-calculateNewProcPoints owners block =
- unionManyUniqSets (map (maybe_proc_point parent_id) child_ids)
- where
- parent_id = brokenBlockId block
- child_ids = brokenBlockTargets block
- maybe_proc_point parent_id child_id =
- if needs_proc_point
- then unitUniqSet child_id
- else emptyUniqSet
- where
- parent_owners = lookupWithDefaultBEnv owners emptyUniqSet parent_id
- child_owners = lookupWithDefaultBEnv owners emptyUniqSet child_id
- needs_proc_point =
- -- only if parent isn't dead
- (not $ isEmptyUniqSet parent_owners) &&
- -- and only if child has more owners than parent
- (not $ isEmptyUniqSet $
- child_owners `minusUniqSet` parent_owners)
-
-calculateOwnership :: BlockEnv BrokenBlock
- -> UniqSet BlockId
- -> [BrokenBlock]
- -> BlockEnv (UniqSet BlockId)
-calculateOwnership blocks_ufm proc_points blocks =
- fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv
- where
- dependants :: BlockId -> [BlockId]
- dependants ident =
- brokenBlockTargets $ lookupWithDefaultBEnv
- blocks_ufm unknown_block ident
-
- update :: BlockId
- -> Maybe BlockId
- -> BlockEnv (UniqSet BlockId)
- -> Maybe (BlockEnv (UniqSet BlockId))
- update ident cause owners =
- case (cause, ident `elementOfUniqSet` proc_points) of
- (Nothing, True) ->
- Just $ extendBlockEnv owners ident (unitUniqSet ident)
- (Nothing, False) -> Nothing
- (Just _, True) -> Nothing
- (Just cause', False) ->
- if (sizeUniqSet old) == (sizeUniqSet new)
- then Nothing
- else Just $ extendBlockEnv owners ident new
- where
- old = lookupWithDefaultBEnv owners emptyUniqSet ident
- new = old `unionUniqSets`
- lookupWithDefaultBEnv owners emptyUniqSet cause'
-
- unknown_block = panic "unknown BlockId in calculateOwnership"
+import UniqSupply
+
+import Compiler.Hoopl
+
+import qualified Data.Map as Map
+
+-- Compute a minimal set of proc points for a control-flow graph.
+
+-- Determine a protocol for each proc point (which live variables will
+-- be passed as arguments and which will be on the stack).
+
+{-
+A proc point is a basic block that, after CPS transformation, will
+start a new function. The entry block of the original function is a
+proc point, as is the continuation of each function call.
+A third kind of proc point arises if we want to avoid copying code.
+Suppose we have code like the following:
+
+ f() {
+ if (...) { ..1..; call foo(); ..2..}
+ else { ..3..; call bar(); ..4..}
+ x = y + z;
+ return x;
+ }
+
+The statement 'x = y + z' can be reached from two different proc
+points: the continuations of foo() and bar(). We would prefer not to
+put a copy in each continuation; instead we would like 'x = y + z' to
+be the start of a new procedure to which the continuations can jump:
+
+ f_cps () {
+ if (...) { ..1..; push k_foo; jump foo_cps(); }
+ else { ..3..; push k_bar; jump bar_cps(); }
+ }
+ k_foo() { ..2..; jump k_join(y, z); }
+ k_bar() { ..4..; jump k_join(y, z); }
+ k_join(y, z) { x = y + z; return x; }
+
+You might think then that a criterion to make a node a proc point is
+that it is directly reached by two distinct proc points. (Note
+[Direct reachability].) But this criterion is a bit too simple; for
+example, 'return x' is also reached by two proc points, yet there is
+no point in pulling it out of k_join. A good criterion would be to
+say that a node should be made a proc point if it is reached by a set
+of proc points that is different than its immediate dominator. NR
+believes this criterion can be shown to produce a minimum set of proc
+points, and given a dominator tree, the proc points can be chosen in
+time linear in the number of blocks. Lacking a dominator analysis,
+however, we turn instead to an iterative solution, starting with no
+proc points and adding them according to these rules:
+
+ 1. The entry block is a proc point.
+ 2. The continuation of a call is a proc point.
+ 3. A node is a proc point if it is directly reached by more proc
+ points than one of its predecessors.
+
+Because we don't understand the problem very well, we apply rule 3 at
+most once per iteration, then recompute the reachability information.
+(See Note [No simple dataflow].) The choice of the new proc point is
+arbitrary, and I don't know if the choice affects the final solution,
+so I don't know if the number of proc points chosen is the
+minimum---but the set will be minimal.
+-}
+
+type ProcPointSet = BlockSet
+
+data Status
+ = ReachedBy ProcPointSet -- set of proc points that directly reach the block
+ | ProcPoint -- this block is itself a proc point
+
+instance Outputable Status where
+ ppr (ReachedBy ps)
+ | setNull ps = text "<not-reached>"
+ | otherwise = text "reached by" <+>
+ (hsep $ punctuate comma $ map ppr $ setElems ps)
+ ppr ProcPoint = text "<procpt>"
+
+lattice :: DataflowLattice Status
+lattice = DataflowLattice "direct proc-point reachability" unreached add_to
+ where unreached = ReachedBy setEmpty
+ add_to _ (OldFact ProcPoint) _ = (NoChange, ProcPoint)
+ add_to _ _ (NewFact ProcPoint) = (SomeChange, ProcPoint) -- because of previous case
+ add_to _ (OldFact (ReachedBy p)) (NewFact (ReachedBy p')) =
+ let union = setUnion p' p
+ in if setSize union > setSize p then (SomeChange, ReachedBy union)
+ else (NoChange, ReachedBy p)
+--------------------------------------------------
+-- transfer equations
+
+forward :: FwdTransfer CmmNode Status
+forward = mkFTransfer3 first middle ((mkFactBase lattice . ) . last)
+ where first :: CmmNode C O -> Status -> Status
+ first (CmmEntry id) ProcPoint = ReachedBy $ setSingleton id
+ first _ x = x
+
+ middle _ x = x
+
+ last :: CmmNode O C -> Status -> [(Label, Status)]
+ last (CmmCall {cml_cont = Just k}) _ = [(k, ProcPoint)]
+ last (CmmForeignCall {succ = k}) _ = [(k, ProcPoint)]
+ last l x = map (\id -> (id, x)) (successors l)
+
+-- It is worth distinguishing two sets of proc points:
+-- those that are induced by calls in the original graph
+-- and those that are introduced because they're reachable from multiple proc points.
+callProcPoints :: CmmGraph -> ProcPointSet
+callProcPoints g = foldGraphBlocks add (setSingleton (g_entry g)) g
+ where add :: CmmBlock -> BlockSet -> BlockSet
+ add b set = case lastNode b of
+ CmmCall {cml_cont = Just k} -> setInsert k set
+ CmmForeignCall {succ=k} -> setInsert k set
+ _ -> set
+
+minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelUniqSM ProcPointSet
+-- Given the set of successors of calls (which must be proc-points)
+-- figure out the minimal set of necessary proc-points
+minimalProcPointSet callProcPoints g = extendPPSet g (postorderDfs g) callProcPoints
+
+procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelUniqSM (BlockEnv Status)
+-- Once you know what the proc-points are, figure out
+-- what proc-points each block is reachable from
+procPointAnalysis procPoints g =
+ liftM snd $ dataflowPassFwd g initProcPoints $ analFwd lattice forward
+ where initProcPoints = [(id, ProcPoint) | id <- setElems procPoints]
+
+extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelUniqSM ProcPointSet
+extendPPSet g blocks procPoints =
+ do env <- procPointAnalysis procPoints g
+ let add block pps = let id = entryLabel block
+ in case mapLookup id env of
+ Just ProcPoint -> setInsert id pps
+ _ -> pps
+ procPoints' = foldGraphBlocks add setEmpty g
+ newPoints = mapMaybe ppSuccessor blocks
+ newPoint = listToMaybe newPoints
+ ppSuccessor b =
+ let nreached id = case mapLookup id env `orElse`
+ pprPanic "no ppt" (ppr id <+> ppr b) of
+ ProcPoint -> 1
+ ReachedBy ps -> setSize ps
+ block_procpoints = nreached (entryLabel b)
+ -- | Looking for a successor of b that is reached by
+ -- more proc points than b and is not already a proc
+ -- point. If found, it can become a proc point.
+ newId succ_id = not (setMember succ_id procPoints') &&
+ nreached succ_id > block_procpoints
+ in listToMaybe $ filter newId $ successors b
+{-
+ case newPoints of
+ [] -> return procPoints'
+ pps -> extendPPSet g blocks
+ (foldl extendBlockSet procPoints' pps)
+-}
+ case newPoint of Just id ->
+ if setMember id procPoints' then panic "added old proc pt"
+ else extendPPSet g blocks (setInsert id procPoints')
+ Nothing -> return procPoints'
+
+
+------------------------------------------------------------------------
+-- Computing Proc-Point Protocols --
+------------------------------------------------------------------------
+
+{-
+
+There is one major trick, discovered by Michael Adams, which is that
+we want to choose protocols in a way that enables us to optimize away
+some continuations. The optimization is very much like branch-chain
+elimination, except that it involves passing results as well as
+control. The idea is that if a call's continuation k does nothing but
+CopyIn its results and then goto proc point P, the call's continuation
+may be changed to P, *provided* P's protocol is identical to the
+protocol for the CopyIn. We choose protocols to make this so.
+
+Here's an explanatory example; we begin with the source code (lines
+separate basic blocks):
+
+ ..1..;
+ x, y = g();
+ goto P;
+ -------
+ P: ..2..;
+
+Zipperization converts this code as follows:
+
+ ..1..;
+ call g() returns to k;
+ -------
+ k: CopyIn(x, y);
+ goto P;
+ -------
+ P: ..2..;
+
+What we'd like to do is assign P the same CopyIn protocol as k, so we
+can eliminate k:
+
+ ..1..;
+ call g() returns to P;
+ -------
+ P: CopyIn(x, y); ..2..;
+
+Of course, P may be the target of more than one continuation, and
+different continuations may have different protocols. Michael Adams
+implemented a voting mechanism, but he thinks a simple greedy
+algorithm would be just as good, so that's what we do.
+
+-}
+
+data Protocol = Protocol Convention CmmFormals Area
+ deriving Eq
+instance Outputable Protocol where
+ ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
+
+-- | Function 'optimize_calls' chooses protocols only for those proc
+-- points that are relevant to the optimization explained above.
+-- The others are assigned by 'add_unassigned', which is not yet clever.
+
+addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelUniqSM CmmGraph
+addProcPointProtocols callPPs procPoints g =
+ do liveness <- cmmLiveness g
+ (protos, g') <- optimize_calls liveness g
+ blocks'' <- add_CopyOuts protos procPoints g'
+ return $ ofBlockMap (g_entry g) blocks''
+ where optimize_calls liveness g = -- see Note [Separate Adams optimization]
+ do let (protos, blocks') =
+ foldGraphBlocks maybe_add_call (mapEmpty, mapEmpty) g
+ protos' = add_unassigned liveness procPoints protos
+ let g' = ofBlockMap (g_entry g) (add_CopyIns callPPs protos' blocks')
+ return (protos', removeUnreachableBlocks g')
+ maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
+ -> (BlockEnv Protocol, BlockEnv CmmBlock)
+ -- ^ If the block is a call whose continuation goes to a proc point
+ -- whose protocol either matches the continuation's or is not yet set,
+ -- redirect the call (cf 'newblock') and set the protocol if necessary
+ maybe_add_call block (protos, blocks) =
+ case lastNode block of
+ CmmCall tgt (Just k) args res s
+ | Just proto <- mapLookup k protos,
+ Just pee <- branchesToProcPoint k
+ -> let newblock = replaceLastNode block (CmmCall tgt (Just pee)
+ args res s)
+ changed_blocks = insertBlock newblock blocks
+ unchanged_blocks = insertBlock block blocks
+ in case mapLookup pee protos of
+ Nothing -> (mapInsert pee proto protos, changed_blocks)
+ Just proto' ->
+ if proto == proto' then (protos, changed_blocks)
+ else (protos, unchanged_blocks)
+ _ -> (protos, insertBlock block blocks)
+
+ branchesToProcPoint :: BlockId -> Maybe BlockId
+ -- ^ Tells whether the named block is just a branch to a proc point
+ branchesToProcPoint id =
+ let block = mapLookup id (toBlockMap g) `orElse`
+ panic "branch out of graph"
+ in case blockToNodeList block of
+-- MS: There is an ugly bug in ghc-6.10, which rejects following valid code.
+-- After trying several tricks, the NOINLINE on getItOut worked. Uffff.
+#if __GLASGOW_HASKELL__ >= 612
+ (_, [], JustC (CmmBranch pee)) | setMember pee procPoints -> Just pee
+ _ -> Nothing
+#else
+ (_, [], exit) | CmmBranch pee <- getItOut exit
+ , setMember pee procPoints -> Just pee
+ _ -> Nothing
+ where {-# NOINLINE getItOut #-}
+ getItOut :: MaybeC C a -> a
+ getItOut (JustC a) = a
+#endif
+
+-- | For now, following a suggestion by Ben Lippmeier, we pass all
+-- live variables as arguments, hoping that a clever register
+-- allocator might help.
+
+add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol ->
+ BlockEnv Protocol
+add_unassigned = pass_live_vars_as_args
+
+pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet ->
+ BlockEnv Protocol -> BlockEnv Protocol
+pass_live_vars_as_args _liveness procPoints protos = protos'
+ where protos' = setFold addLiveVars protos procPoints
+ addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
+ addLiveVars id protos =
+ case mapLookup id protos of
+ Just _ -> protos
+ Nothing -> let live = emptyRegSet
+ --lookupBlockEnv _liveness id `orElse`
+ --panic ("no liveness at block " ++ show id)
+ formals = uniqSetToList live
+ prot = Protocol Private formals $ CallArea $ Young id
+ in mapInsert id prot protos
+
+
+-- | Add copy-in instructions to each proc point that did not arise from a call
+-- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
+
+add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock -> BlockEnv CmmBlock
+add_CopyIns callPPs protos blocks = mapFold maybe_insert_CopyIns mapEmpty blocks
+ where maybe_insert_CopyIns block blocks
+ | not $ setMember bid callPPs
+ , Just (Protocol c fs _area) <- mapLookup bid protos
+ = let nodes = copyInSlot c fs
+ (h, m, l) = blockToNodeList block
+ in insertBlock (blockOfNodeList (h, nodes ++ m, l)) blocks
+ | otherwise = insertBlock block blocks
+ where bid = entryLabel block
+
+
+-- | Add a CopyOut node before each procpoint.
+-- If the predecessor is a call, then the copy outs should already be done by the callee.
+-- Note: If we need to add copy-out instructions, they may require stack space,
+-- so we accumulate a map from the successors to the necessary stack space,
+-- then update the successors after we have finished inserting the copy-outs.
+
+add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
+ FuelUniqSM (BlockEnv CmmBlock)
+add_CopyOuts protos procPoints g = foldGraphBlocks mb_copy_out (return mapEmpty) g
+ where mb_copy_out :: CmmBlock -> FuelUniqSM (BlockEnv CmmBlock) ->
+ FuelUniqSM (BlockEnv CmmBlock)
+ mb_copy_out b z | entryLabel b == g_entry g = skip b z
+ mb_copy_out b z =
+ case lastNode b of
+ CmmCall {} -> skip b z -- copy out done by callee
+ CmmForeignCall {} -> skip b z -- copy out done by callee
+ _ -> copy_out b z
+ copy_out b z = foldr trySucc init (successors b) >>= finish
+ where init = (\bmap -> (b, bmap)) `liftM` z
+ trySucc succId z =
+ if setMember succId procPoints then
+ case mapLookup succId protos of
+ Nothing -> z
+ Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
+ else z
+ insert z succId m =
+ do (b, bmap) <- z
+ (b, bs) <- insertBetween b m succId
+ -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
+ return $ (b, foldl (flip insertBlock) bmap bs)
+ finish (b, bmap) = return $ insertBlock b bmap
+ skip b bs = insertBlock b `liftM` bs
+
+-- At this point, we have found a set of procpoints, each of which should be
+-- the entry point of a procedure.
+-- Now, we create the procedure for each proc point,
+-- which requires that we:
+-- 1. build a map from proc points to the blocks reachable from the proc point
+-- 2. turn each branch to a proc point into a jump
+-- 3. turn calls and returns into jumps
+-- 4. build info tables for the procedures -- and update the info table for
+-- the SRTs in the entry procedure as well.
+-- Input invariant: A block should only be reachable from a single ProcPoint.
+splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
+ CmmTop -> FuelUniqSM [CmmTop]
+splitAtProcPoints entry_label callPPs procPoints procMap
+ (CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
+ top_l g@(CmmGraph {g_entry=entry})) =
+ do -- Build a map from procpoints to the blocks they reach
+ let addBlock b graphEnv =
+ case mapLookup bid procMap of
+ Just ProcPoint -> add graphEnv bid bid b
+ Just (ReachedBy set) ->
+ case setElems set of
+ [] -> graphEnv
+ [id] -> add graphEnv id bid b
+ _ -> panic "Each block should be reachable from only one ProcPoint"
+ Nothing -> pprPanic "block not reached by a proc point?" (ppr bid)
+ where bid = entryLabel b
+ add graphEnv procId bid b = mapInsert procId graph' graphEnv
+ where graph = mapLookup procId graphEnv `orElse` mapEmpty
+ graph' = mapInsert bid b graph
+ graphEnv <- return $ foldGraphBlocks addBlock emptyBlockMap g
+ -- Build a map from proc point BlockId to labels for their new procedures
+ -- Due to common blockification, we may overestimate the set of procpoints.
+ let add_label map pp = return $ Map.insert pp lbl map
+ where lbl = if pp == entry then entry_label else blockLbl pp
+ procLabels <- foldM add_label Map.empty
+ (filter (flip mapMember (toBlockMap g)) (setElems procPoints))
+ -- For each procpoint, we need to know the SP offset on entry.
+ -- If the procpoint is:
+ -- - continuation of a call, the SP offset is in the call
+ -- - otherwise, 0 (and left out of the spEntryMap)
+ let add_sp_off :: CmmBlock -> BlockEnv CmmStackInfo -> BlockEnv CmmStackInfo
+ add_sp_off b env =
+ case lastNode b of
+ CmmCall {cml_cont = Just succ, cml_ret_args = off, cml_ret_off = updfr_off} ->
+ mapInsert succ (StackInfo { arg_space = off, updfr_space = Just updfr_off}) env
+ CmmForeignCall {succ = succ, updfr = updfr_off} ->
+ mapInsert succ (StackInfo { arg_space = wORD_SIZE, updfr_space = Just updfr_off}) env
+ _ -> env
+ spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry stack_info emptyBlockMap) g
+ getStackInfo id = mapLookup id spEntryMap `orElse` StackInfo {arg_space = 0, updfr_space = Nothing}
+ -- In each new graph, add blocks jumping off to the new procedures,
+ -- and replace branches to procpoints with branches to the jump-off blocks
+ let add_jump_block (env, bs) (pp, l) =
+ do bid <- liftM mkBlockId getUniqueM
+ let b = blockOfNodeList (JustC (CmmEntry bid), [], JustC jump)
+ StackInfo {arg_space = argSpace, updfr_space = off} = getStackInfo pp
+ jump = CmmCall (CmmLit (CmmLabel l')) Nothing argSpace 0
+ (off `orElse` 0) -- Jump's shouldn't need the offset...
+ l' = if setMember pp callPPs then entryLblToInfoLbl l else l
+ return (mapInsert pp bid env, b : bs)
+ add_jumps (newGraphEnv) (ppId, blockEnv) =
+ do let needed_jumps = -- find which procpoints we currently branch to
+ mapFold add_if_branch_to_pp [] blockEnv
+ add_if_branch_to_pp :: CmmBlock -> [(BlockId, CLabel)] -> [(BlockId, CLabel)]
+ add_if_branch_to_pp block rst =
+ case lastNode block of
+ CmmBranch id -> add_if_pp id rst
+ CmmCondBranch _ ti fi -> add_if_pp ti (add_if_pp fi rst)
+ CmmSwitch _ tbl -> foldr add_if_pp rst (catMaybes tbl)
+ _ -> rst
+ add_if_pp id rst = case Map.lookup id procLabels of
+ Just x -> (id, x) : rst
+ Nothing -> rst
+ (jumpEnv, jumpBlocks) <-
+ foldM add_jump_block (mapEmpty, []) needed_jumps
+ -- update the entry block
+ let b = expectJust "block in env" $ mapLookup ppId blockEnv
+ off = getStackInfo ppId
+ blockEnv' = mapInsert ppId b blockEnv
+ -- replace branches to procpoints with branches to jumps
+ blockEnv'' = toBlockMap $ replaceBranches jumpEnv $ ofBlockMap ppId blockEnv'
+ -- add the jump blocks to the graph
+ blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
+ let g' = (off, ofBlockMap ppId blockEnv''')
+ -- pprTrace "g' pre jumps" (ppr g') $ do
+ return (mapInsert ppId g' newGraphEnv)
+ graphEnv <- foldM add_jumps emptyBlockMap $ mapToList graphEnv
+ let to_proc (bid, (stack_info, g)) | setMember bid callPPs =
+ if bid == entry then
+ CmmProc (TopInfo {info_tbl=info_tbl, stack_info=stack_info})
+ top_l (replacePPIds g)
+ else
+ CmmProc (TopInfo {info_tbl=emptyContInfoTable, stack_info=stack_info})
+ lbl (replacePPIds g)
+ where lbl = expectJust "pp label" $ Map.lookup bid procLabels
+ to_proc (bid, (stack_info, g)) =
+ CmmProc (TopInfo {info_tbl=CmmNonInfoTable, stack_info=stack_info})
+ lbl (replacePPIds g)
+ where lbl = expectJust "pp label" $ Map.lookup bid procLabels
+ -- References to procpoint IDs can now be replaced with the infotable's label
+ replacePPIds g = mapGraphNodes (id, mapExp repl, mapExp repl) g
+ where repl e@(CmmLit (CmmBlock bid)) =
+ case Map.lookup bid procLabels of
+ Just l -> CmmLit (CmmLabel (entryLblToInfoLbl l))
+ Nothing -> e
+ repl e = e
+ -- The C back end expects to see return continuations before the call sites.
+ -- Here, we sort them in reverse order -- it gets reversed later.
+ let (_, block_order) = foldl add_block_num (0::Int, emptyBlockMap) (postorderDfs g)
+ add_block_num (i, map) block = (i+1, mapInsert (entryLabel block) i map)
+ sort_fn (bid, _) (bid', _) =
+ compare (expectJust "block_order" $ mapLookup bid block_order)
+ (expectJust "block_order" $ mapLookup bid' block_order)
+ procs <- return $ map to_proc $ sortBy sort_fn $ mapToList graphEnv
+ return -- pprTrace "procLabels" (ppr procLabels)
+ -- pprTrace "splitting graphs" (ppr procs)
+ procs
+splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
+
+----------------------------------------------------------------
+
+{-
+Note [Direct reachability]
+
+Block B is directly reachable from proc point P iff control can flow
+from P to B without passing through an intervening proc point.
+-}
+
+----------------------------------------------------------------
+
+{-
+Note [No simple dataflow]
+
+Sadly, it seems impossible to compute the proc points using a single
+dataflow pass. One might attempt to use this simple lattice:
+
+ data Location = Unknown
+ | InProc BlockId -- node is in procedure headed by the named proc point
+ | ProcPoint -- node is itself a proc point
+
+At a join, a node in two different blocks becomes a proc point.
+The difficulty is that the change of information during iterative
+computation may promote a node prematurely. Here's a program that
+illustrates the difficulty:
+
+ f () {
+ entry:
+ ....
+ L1:
+ if (...) { ... }
+ else { ... }
+
+ L2: if (...) { g(); goto L1; }
+ return x + y;
+ }
+
+The only proc-point needed (besides the entry) is L1. But in an
+iterative analysis, consider what happens to L2. On the first pass
+through, it rises from Unknown to 'InProc entry', but when L1 is
+promoted to a proc point (because it's the successor of g()), L1's
+successors will be promoted to 'InProc L1'. The problem hits when the
+new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
+The join operation makes it a proc point when in fact it needn't be,
+because its immediate dominator L1 is already a proc point and there
+are no other proc points that directly reach L2.
+-}
+
+
+
+{- Note [Separate Adams optimization]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+It may be worthwhile to attempt the Adams optimization by rewriting
+the graph before the assignment of proc-point protocols. Here are a
+couple of rules:
+
+ g() returns to k; g() returns to L;
+ k: CopyIn c ress; goto L:
+ ... ==> ...
+ L: // no CopyIn node here L: CopyIn c ress;
+
+
+And when c == c' and ress == ress', this also:
+
+ g() returns to k; g() returns to L;
+ k: CopyIn c ress; goto L:
+ ... ==> ...
+ L: CopyIn c' ress' L: CopyIn c' ress' ;
+
+In both cases the goal is to eliminate k.
+-}
+++ /dev/null
-module CmmProcPointZ
- ( ProcPointSet, Status(..)
- , callProcPoints, minimalProcPointSet
- , addProcPointProtocols, splitAtProcPoints, procPointAnalysis
- )
-where
-
-import Prelude hiding (zip, unzip, last)
-
-import BlockId
-import CLabel
-import Cmm hiding (blockId)
-import CmmContFlowOpt
-import CmmInfo
-import CmmLiveZ
-import CmmTx
-import DFMonad
-import Data.List (sortBy)
-import Maybes
-import MkZipCfg
-import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ)
-import Control.Monad
-import Outputable
-import UniqSet
-import UniqSupply
-import ZipCfg
-import ZipCfgCmmRep
-import ZipDataflow
-
-import qualified Data.Map as Map
-
--- Compute a minimal set of proc points for a control-flow graph.
-
--- Determine a protocol for each proc point (which live variables will
--- be passed as arguments and which will be on the stack).
-
-{-
-A proc point is a basic block that, after CPS transformation, will
-start a new function. The entry block of the original function is a
-proc point, as is the continuation of each function call.
-A third kind of proc point arises if we want to avoid copying code.
-Suppose we have code like the following:
-
- f() {
- if (...) { ..1..; call foo(); ..2..}
- else { ..3..; call bar(); ..4..}
- x = y + z;
- return x;
- }
-
-The statement 'x = y + z' can be reached from two different proc
-points: the continuations of foo() and bar(). We would prefer not to
-put a copy in each continuation; instead we would like 'x = y + z' to
-be the start of a new procedure to which the continuations can jump:
-
- f_cps () {
- if (...) { ..1..; push k_foo; jump foo_cps(); }
- else { ..3..; push k_bar; jump bar_cps(); }
- }
- k_foo() { ..2..; jump k_join(y, z); }
- k_bar() { ..4..; jump k_join(y, z); }
- k_join(y, z) { x = y + z; return x; }
-
-You might think then that a criterion to make a node a proc point is
-that it is directly reached by two distinct proc points. (Note
-[Direct reachability].) But this criterion is a bit too simple; for
-example, 'return x' is also reached by two proc points, yet there is
-no point in pulling it out of k_join. A good criterion would be to
-say that a node should be made a proc point if it is reached by a set
-of proc points that is different than its immediate dominator. NR
-believes this criterion can be shown to produce a minimum set of proc
-points, and given a dominator tree, the proc points can be chosen in
-time linear in the number of blocks. Lacking a dominator analysis,
-however, we turn instead to an iterative solution, starting with no
-proc points and adding them according to these rules:
-
- 1. The entry block is a proc point.
- 2. The continuation of a call is a proc point.
- 3. A node is a proc point if it is directly reached by more proc
- points than one of its predecessors.
-
-Because we don't understand the problem very well, we apply rule 3 at
-most once per iteration, then recompute the reachability information.
-(See Note [No simple dataflow].) The choice of the new proc point is
-arbitrary, and I don't know if the choice affects the final solution,
-so I don't know if the number of proc points chosen is the
-minimum---but the set will be minimal.
--}
-
-type ProcPointSet = BlockSet
-
-data Status
- = ReachedBy ProcPointSet -- set of proc points that directly reach the block
- | ProcPoint -- this block is itself a proc point
-
-instance Outputable Status where
- ppr (ReachedBy ps)
- | isEmptyBlockSet ps = text "<not-reached>"
- | otherwise = text "reached by" <+>
- (hsep $ punctuate comma $ map ppr $ blockSetToList ps)
- ppr ProcPoint = text "<procpt>"
-
-
-lattice :: DataflowLattice Status
-lattice = DataflowLattice "direct proc-point reachability" unreached add_to False
- where unreached = ReachedBy emptyBlockSet
- add_to _ ProcPoint = noTx ProcPoint
- add_to ProcPoint _ = aTx ProcPoint -- aTx because of previous case again
- add_to (ReachedBy p) (ReachedBy p') =
- let union = unionBlockSets p p'
- in if sizeBlockSet union > sizeBlockSet p' then
- aTx (ReachedBy union)
- else
- noTx (ReachedBy p')
---------------------------------------------------
--- transfer equations
-
-forward :: ForwardTransfers Middle Last Status
-forward = ForwardTransfers first middle last exit
- where first id ProcPoint = ReachedBy $ unitBlockSet id
- first _ x = x
- middle _ x = x
- last (LastCall _ (Just id) _ _ _) _ = LastOutFacts [(id, ProcPoint)]
- last l x = LastOutFacts $ map (\id -> (id, x)) (succs l)
- exit x = x
-
--- It is worth distinguishing two sets of proc points:
--- those that are induced by calls in the original graph
--- and those that are introduced because they're reachable from multiple proc points.
-callProcPoints :: CmmGraph -> ProcPointSet
-callProcPoints g = fold_blocks add (unitBlockSet (lg_entry g)) g
- where add b set = case last $ unzip b of
- LastOther (LastCall _ (Just k) _ _ _) -> extendBlockSet set k
- _ -> set
-
-minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet
--- Given the set of successors of calls (which must be proc-points)
--- figure ou the minimal set of necessary proc-points
-minimalProcPointSet callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints
-
-type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ())
-
-procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status)
--- Once you know what the proc-points are, figure out
--- what proc-points each block is reachable from
-procPointAnalysis procPoints g =
- let addPP env id = extendBlockEnv env id ProcPoint
- initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints)
- in liftM zdfFpFacts $
- (zdfSolveFrom initProcPoints "proc-point reachability" lattice
- forward (fact_bot lattice) $ graphOfLGraph g :: PPFix)
-
-extendPPSet :: CmmGraph -> [CmmBlock] -> ProcPointSet -> FuelMonad ProcPointSet
-extendPPSet g blocks procPoints =
- do env <- procPointAnalysis procPoints g
- let add block pps = let id = blockId block
- in case lookupBlockEnv env id of
- Just ProcPoint -> extendBlockSet pps id
- _ -> pps
- procPoints' = fold_blocks add emptyBlockSet g
- newPoints = mapMaybe ppSuccessor blocks
- newPoint = listToMaybe newPoints
- ppSuccessor b@(Block bid _) =
- let nreached id = case lookupBlockEnv env id `orElse`
- pprPanic "no ppt" (ppr id <+> ppr b) of
- ProcPoint -> 1
- ReachedBy ps -> sizeBlockSet ps
- block_procpoints = nreached bid
- -- | Looking for a successor of b that is reached by
- -- more proc points than b and is not already a proc
- -- point. If found, it can become a proc point.
- newId succ_id = not (elemBlockSet succ_id procPoints') &&
- nreached succ_id > block_procpoints
- in listToMaybe $ filter newId $ succs b
-{-
- case newPoints of
- [] -> return procPoints'
- pps -> extendPPSet g blocks
- (foldl extendBlockSet procPoints' pps)
--}
- case newPoint of Just id ->
- if elemBlockSet id procPoints' then panic "added old proc pt"
- else extendPPSet g blocks (extendBlockSet procPoints' id)
- Nothing -> return procPoints'
-
-
-------------------------------------------------------------------------
--- Computing Proc-Point Protocols --
-------------------------------------------------------------------------
-
-{-
-
-There is one major trick, discovered by Michael Adams, which is that
-we want to choose protocols in a way that enables us to optimize away
-some continuations. The optimization is very much like branch-chain
-elimination, except that it involves passing results as well as
-control. The idea is that if a call's continuation k does nothing but
-CopyIn its results and then goto proc point P, the call's continuation
-may be changed to P, *provided* P's protocol is identical to the
-protocol for the CopyIn. We choose protocols to make this so.
-
-Here's an explanatory example; we begin with the source code (lines
-separate basic blocks):
-
- ..1..;
- x, y = g();
- goto P;
- -------
- P: ..2..;
-
-Zipperization converts this code as follows:
-
- ..1..;
- call g() returns to k;
- -------
- k: CopyIn(x, y);
- goto P;
- -------
- P: ..2..;
-
-What we'd like to do is assign P the same CopyIn protocol as k, so we
-can eliminate k:
-
- ..1..;
- call g() returns to P;
- -------
- P: CopyIn(x, y); ..2..;
-
-Of course, P may be the target of more than one continuation, and
-different continuations may have different protocols. Michael Adams
-implemented a voting mechanism, but he thinks a simple greedy
-algorithm would be just as good, so that's what we do.
-
--}
-
-data Protocol = Protocol Convention CmmFormals Area
- deriving Eq
-instance Outputable Protocol where
- ppr (Protocol c fs a) = text "Protocol" <+> ppr c <+> ppr fs <+> ppr a
-
--- | Function 'optimize_calls' chooses protocols only for those proc
--- points that are relevant to the optimization explained above.
--- The others are assigned by 'add_unassigned', which is not yet clever.
-
-addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph
-addProcPointProtocols callPPs procPoints g =
- do liveness <- cmmLivenessZ g
- (protos, g') <- optimize_calls liveness g
- blocks'' <- add_CopyOuts protos procPoints g'
- return $ LGraph (lg_entry g) blocks''
- where optimize_calls liveness g = -- see Note [Separate Adams optimization]
- do let (protos, blocks') =
- fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g
- protos' = add_unassigned liveness procPoints protos
- blocks <- add_CopyIns callPPs protos' blocks'
- let g' = LGraph (lg_entry g) (mkBlockEnv (map withKey (concat blocks)))
- withKey b@(Block bid _) = (bid, b)
- return (protos', runTx removeUnreachableBlocksZ g')
- maybe_add_call :: CmmBlock -> (BlockEnv Protocol, BlockEnv CmmBlock)
- -> (BlockEnv Protocol, BlockEnv CmmBlock)
- -- ^ If the block is a call whose continuation goes to a proc point
- -- whose protocol either matches the continuation's or is not yet set,
- -- redirect the call (cf 'newblock') and set the protocol if necessary
- maybe_add_call block (protos, blocks) =
- case goto_end $ unzip block of
- (h, LastOther (LastCall tgt (Just k) args res s))
- | Just proto <- lookupBlockEnv protos k,
- Just pee <- branchesToProcPoint k
- -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee)
- args res s))
- changed_blocks = insertBlock newblock blocks
- unchanged_blocks = insertBlock block blocks
- in case lookupBlockEnv protos pee of
- Nothing -> (extendBlockEnv protos pee proto,changed_blocks)
- Just proto' ->
- if proto == proto' then (protos, changed_blocks)
- else (protos, unchanged_blocks)
- _ -> (protos, insertBlock block blocks)
-
- branchesToProcPoint :: BlockId -> Maybe BlockId
- -- ^ Tells whether the named block is just a branch to a proc point
- branchesToProcPoint id =
- let (Block _ t) = lookupBlockEnv (lg_blocks g) id `orElse`
- panic "branch out of graph"
- in case t of
- ZLast (LastOther (LastBranch pee))
- | elemBlockSet pee procPoints -> Just pee
- _ -> Nothing
- init_protocols = fold_blocks maybe_add_proto emptyBlockEnv g
- maybe_add_proto :: CmmBlock -> BlockEnv Protocol -> BlockEnv Protocol
- --maybe_add_proto (Block id (ZTail (CopyIn c _ fs _srt) _)) env =
- -- extendBlockEnv env id (Protocol c fs $ toArea id fs)
- maybe_add_proto _ env = env
- -- JD: Is this proto stuff even necessary, now that we have
- -- common blockification?
-
--- | For now, following a suggestion by Ben Lippmeier, we pass all
--- live variables as arguments, hoping that a clever register
--- allocator might help.
-
-add_unassigned :: BlockEnv CmmLive -> ProcPointSet -> BlockEnv Protocol ->
- BlockEnv Protocol
-add_unassigned = pass_live_vars_as_args
-
-pass_live_vars_as_args :: BlockEnv CmmLive -> ProcPointSet ->
- BlockEnv Protocol -> BlockEnv Protocol
-pass_live_vars_as_args _liveness procPoints protos = protos'
- where protos' = foldBlockSet addLiveVars protos procPoints
- addLiveVars :: BlockId -> BlockEnv Protocol -> BlockEnv Protocol
- addLiveVars id protos =
- case lookupBlockEnv protos id of
- Just _ -> protos
- Nothing -> let live = emptyRegSet
- --lookupBlockEnv _liveness id `orElse`
- --panic ("no liveness at block " ++ show id)
- formals = uniqSetToList live
- prot = Protocol Private formals $ CallArea $ Young id
- in extendBlockEnv protos id prot
-
-
--- | Add copy-in instructions to each proc point that did not arise from a call
--- instruction. (Proc-points that arise from calls already have their copy-in instructions.)
-
-add_CopyIns :: ProcPointSet -> BlockEnv Protocol -> BlockEnv CmmBlock ->
- FuelMonad [[CmmBlock]]
-add_CopyIns callPPs protos blocks =
- liftUniq $ mapM maybe_insert_CopyIns (blockEnvToList blocks)
- where maybe_insert_CopyIns (_, b@(Block id t))
- | not $ elemBlockSet id callPPs
- = case lookupBlockEnv protos id of
- Just (Protocol c fs _area) ->
- do LGraph _ blocks <-
- lgraphOfAGraph (mkLabel id <*> copyInSlot c fs <*> mkZTail t)
- return (map snd $ blockEnvToList blocks)
- Nothing -> return [b]
- | otherwise = return [b]
-
--- | Add a CopyOut node before each procpoint.
--- If the predecessor is a call, then the copy outs should already be done by the callee.
--- Note: If we need to add copy-out instructions, they may require stack space,
--- so we accumulate a map from the successors to the necessary stack space,
--- then update the successors after we have finished inserting the copy-outs.
-
-add_CopyOuts :: BlockEnv Protocol -> ProcPointSet -> CmmGraph ->
- FuelMonad (BlockEnv CmmBlock)
-add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv) g
- where mb_copy_out :: CmmBlock -> FuelMonad (BlockEnv CmmBlock) ->
- FuelMonad (BlockEnv CmmBlock)
- mb_copy_out b@(Block bid _) z | bid == lg_entry g = skip b z
- mb_copy_out b z =
- case last $ unzip b of
- LastOther (LastCall _ _ _ _ _) -> skip b z -- copy out done by callee
- _ -> copy_out b z
- copy_out b z = fold_succs trySucc b init >>= finish
- where init = z >>= (\bmap -> return (b, bmap))
- trySucc succId z =
- if elemBlockSet succId procPoints then
- case lookupBlockEnv protos succId of
- Nothing -> z
- Just (Protocol c fs _area) -> insert z succId $ copyOutSlot c fs
- else z
- insert z succId m =
- do (b, bmap) <- z
- (b, bs) <- insertBetween b m succId
- -- pprTrace "insert for succ" (ppr succId <> ppr m) $ do
- return $ (b, foldl (flip insertBlock) bmap bs)
- finish (b@(Block bid _), bmap) =
- return $ (extendBlockEnv bmap bid b)
- skip b@(Block bid _) bs =
- bs >>= (\bmap -> return (extendBlockEnv bmap bid b))
-
--- At this point, we have found a set of procpoints, each of which should be
--- the entry point of a procedure.
--- Now, we create the procedure for each proc point,
--- which requires that we:
--- 1. build a map from proc points to the blocks reachable from the proc point
--- 2. turn each branch to a proc point into a jump
--- 3. turn calls and returns into jumps
--- 4. build info tables for the procedures -- and update the info table for
--- the SRTs in the entry procedure as well.
--- Input invariant: A block should only be reachable from a single ProcPoint.
-splitAtProcPoints :: CLabel -> ProcPointSet-> ProcPointSet -> BlockEnv Status ->
- CmmTopZ -> FuelMonad [CmmTopZ]
-splitAtProcPoints entry_label callPPs procPoints procMap
- (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args
- (stackInfo, g@(LGraph entry blocks))) =
- do -- Build a map from procpoints to the blocks they reach
- let addBlock b@(Block bid _) graphEnv =
- case lookupBlockEnv procMap bid of
- Just ProcPoint -> add graphEnv bid bid b
- Just (ReachedBy set) ->
- case blockSetToList set of
- [] -> graphEnv
- [id] -> add graphEnv id bid b
- _ -> panic "Each block should be reachable from only one ProcPoint"
- Nothing -> pprPanic "block not reached by a proc point?" (ppr bid)
- add graphEnv procId bid b = extendBlockEnv graphEnv procId graph'
- where graph = lookupBlockEnv graphEnv procId `orElse` emptyBlockEnv
- graph' = extendBlockEnv graph bid b
- graphEnv <- return $ fold_blocks addBlock emptyBlockEnv g
- -- Build a map from proc point BlockId to labels for their new procedures
- -- Due to common blockification, we may overestimate the set of procpoints.
- let add_label map pp = return $ Map.insert pp lbl map
- where lbl = if pp == entry then entry_label else blockLbl pp
- procLabels <- foldM add_label Map.empty
- (filter (elemBlockEnv blocks) (blockSetToList procPoints))
- -- For each procpoint, we need to know the SP offset on entry.
- -- If the procpoint is:
- -- - continuation of a call, the SP offset is in the call
- -- - otherwise, 0 -- no overflow for passing those variables
- let add_sp_off b env =
- case last (unzip b) of
- LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off,
- cml_ret_off = updfr_off}) ->
- extendBlockEnv env succ (off, updfr_off)
- _ -> env
- spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, stackInfo)]) g
- getStackInfo id = lookupBlockEnv spEntryMap id `orElse` (0, Nothing)
- -- In each new graph, add blocks jumping off to the new procedures,
- -- and replace branches to procpoints with branches to the jump-off blocks
- let add_jump_block (env, bs) (pp, l) =
- do bid <- liftM mkBlockId getUniqueM
- let b = Block bid (ZLast (LastOther jump))
- (argSpace, _) = getStackInfo pp
- jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace 0 Nothing
- l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l
- return (extendBlockEnv env pp bid, b : bs)
- add_jumps (newGraphEnv) (ppId, blockEnv) =
- do let needed_jumps = -- find which procpoints we currently branch to
- foldBlockEnv' add_if_branch_to_pp [] blockEnv
- add_if_branch_to_pp block rst =
- case last (unzip block) of
- LastOther (LastBranch id) -> add_if_pp id rst
- LastOther (LastCondBranch _ ti fi) ->
- add_if_pp ti (add_if_pp fi rst)
- LastOther (LastSwitch _ tbl) -> foldr add_if_pp rst (catMaybes tbl)
- _ -> rst
- add_if_pp id rst = case Map.lookup id procLabels of
- Just x -> (id, x) : rst
- Nothing -> rst
- (jumpEnv, jumpBlocks) <-
- foldM add_jump_block (emptyBlockEnv, []) needed_jumps
- -- update the entry block
- let b = expectJust "block in env" $ lookupBlockEnv blockEnv ppId
- off = getStackInfo ppId
- blockEnv' = extendBlockEnv blockEnv ppId b
- -- replace branches to procpoints with branches to jumps
- LGraph _ blockEnv'' = replaceBranches jumpEnv $ LGraph ppId blockEnv'
- -- add the jump blocks to the graph
- blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks
- let g' = (off, LGraph ppId blockEnv''')
- -- pprTrace "g' pre jumps" (ppr g') $ do
- return (extendBlockEnv newGraphEnv ppId g')
- graphEnv <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv
- let to_proc (bid, g) | elemBlockSet bid callPPs =
- if bid == entry then
- CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args (replacePPIds g)
- else
- CmmProc emptyContInfoTable lbl [] (replacePPIds g)
- where lbl = expectJust "pp label" $ Map.lookup bid procLabels
- to_proc (bid, g) =
- CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] (replacePPIds g)
- where lbl = expectJust "pp label" $ Map.lookup bid procLabels
- -- References to procpoint IDs can now be replaced with the infotable's label
- replacePPIds (x, g) = (x, map_nodes id (mapExpMiddle repl) (mapExpLast repl) g)
- where repl e@(CmmLit (CmmBlock bid)) =
- case Map.lookup bid procLabels of
- Just l -> CmmLit (CmmLabel (entryLblToInfoLbl l))
- Nothing -> e
- repl e = e
- -- The C back end expects to see return continuations before the call sites.
- -- Here, we sort them in reverse order -- it gets reversed later.
- let (_, block_order) = foldl add_block_num (0::Int, emptyBlockEnv) (postorder_dfs g)
- add_block_num (i, map) (Block bid _) = (i+1, extendBlockEnv map bid i)
- sort_fn (bid, _) (bid', _) =
- compare (expectJust "block_order" $ lookupBlockEnv block_order bid)
- (expectJust "block_order" $ lookupBlockEnv block_order bid')
- procs <- return $ map to_proc $ sortBy sort_fn $ blockEnvToList graphEnv
- return -- pprTrace "procLabels" (ppr procLabels)
- -- pprTrace "splitting graphs" (ppr procs)
- procs
-splitAtProcPoints _ _ _ _ t@(CmmData _ _) = return [t]
-
-----------------------------------------------------------------
-
-{-
-Note [Direct reachability]
-
-Block B is directly reachable from proc point P iff control can flow
-from P to B without passing through an intervening proc point.
--}
-
-----------------------------------------------------------------
-
-{-
-Note [No simple dataflow]
-
-Sadly, it seems impossible to compute the proc points using a single
-dataflow pass. One might attempt to use this simple lattice:
-
- data Location = Unknown
- | InProc BlockId -- node is in procedure headed by the named proc point
- | ProcPoint -- node is itself a proc point
-
-At a join, a node in two different blocks becomes a proc point.
-The difficulty is that the change of information during iterative
-computation may promote a node prematurely. Here's a program that
-illustrates the difficulty:
-
- f () {
- entry:
- ....
- L1:
- if (...) { ... }
- else { ... }
-
- L2: if (...) { g(); goto L1; }
- return x + y;
- }
-
-The only proc-point needed (besides the entry) is L1. But in an
-iterative analysis, consider what happens to L2. On the first pass
-through, it rises from Unknown to 'InProc entry', but when L1 is
-promoted to a proc point (because it's the successor of g()), L1's
-successors will be promoted to 'InProc L1'. The problem hits when the
-new fact 'InProc L1' flows into L2 which is already bound to 'InProc entry'.
-The join operation makes it a proc point when in fact it needn't be,
-because its immediate dominator L1 is already a proc point and there
-are no other proc points that directly reach L2.
--}
-
-
-
-{- Note [Separate Adams optimization]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-It may be worthwhile to attempt the Adams optimization by rewriting
-the graph before the assignment of proc-point protocols. Here are a
-couple of rules:
-
- g() returns to k; g() returns to L;
- k: CopyIn c ress; goto L:
- ... ==> ...
- L: // no CopyIn node here L: CopyIn c ress;
-
-
-And when c == c' and ress == ress', this also:
-
- g() returns to k; g() returns to L;
- k: CopyIn c ress; goto L:
- ... ==> ...
- L: CopyIn c' ress' L: CopyIn c' ress' ;
-
-In both cases the goal is to eliminate k.
--}
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
where
import BlockId
+import Cmm
import CmmExpr
-import CmmTx
-import CmmLiveZ
-import DFMonad
-import MkZipCfg
-import PprCmm()
-import ZipCfg
-import ZipCfgCmmRep
-import ZipDataflow
+import CmmLive
+import OptimizationFuel
import Control.Monad
import Outputable hiding (empty)
import qualified Outputable as PP
import UniqSet
+import Compiler.Hoopl
import Data.Maybe
-import Prelude hiding (zip)
+import Prelude hiding (succ, zip)
{- Note [Overview of spill/reload]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
dualLiveLattice :: DataflowLattice DualLive
-dualLiveLattice =
- DataflowLattice "variables live in registers and on stack" empty add False
+dualLiveLattice = DataflowLattice "variables live in registers and on stack" empty add
where empty = DualLive emptyRegSet emptyRegSet
- -- | compute in the Tx monad to track whether anything has changed
- add new old = do stack <- add1 (on_stack new) (on_stack old)
- regs <- add1 (in_regs new) (in_regs old)
- return $ DualLive stack regs
- add1 = fact_add_to liveLattice
-
-type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a)
-
-dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-dualLivenessWithInsertion procPoints g@(LGraph entry _) =
- liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
- where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion"
- dualLiveLattice (dualLiveTransfers entry procPoints)
- (insertSpillAndReloadRewrites entry procPoints) empty g
- empty = fact_bot dualLiveLattice
-
-dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive)
-dualLiveness procPoints g@(LGraph entry _) =
- liftM zdfFpFacts $ (res :: LiveReloadFix ())
- where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice
- (dualLiveTransfers entry procPoints) empty g
- empty = fact_bot dualLiveLattice
-
-dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive
-dualLiveTransfers entry procPoints = BackwardTransfers first middle last
- where last = lastDualLiveness
- middle = middleDualLiveness
- first id live = check live id $ -- live at procPoint => spill
- if id /= entry && elemBlockSet id procPoints then
- DualLive { on_stack = on_stack live `plusRegSet` in_regs live
- , in_regs = emptyRegSet }
- else live
- check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
-
-middleDualLiveness :: Middle -> DualLive -> DualLive
-middleDualLiveness m live =
- changeStack updSlots $ changeRegs (middleLiveness m) (changeRegs regs_in live)
- where regs_in live = case m of MidForeignCall {} -> emptyRegSet
- _ -> live
- updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
- spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
- spill live _ = live
- reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
- reload live _ = live
- check (RegSlot (LocalReg _ ty), o, w) x
- | o == w && w == widthInBytes (typeWidth ty) = x
- check _ _ = panic "middleDualLiveness unsupported: slices"
-
-lastDualLiveness :: Last -> (BlockId -> DualLive) -> DualLive
-lastDualLiveness l env = last l
- where last (LastBranch id) = env id
- last l@(LastCall _ Nothing _ _ _) = changeRegs (gen l . kill l) empty
- last l@(LastCall _ (Just k) _ _ _) =
- -- nothing can be live in registers at this point, unless safe foreign call
- let live = env k
- live_in = DualLive (on_stack live) (gen l emptyRegSet)
- in if isEmptyUniqSet (in_regs live) then live_in
- else pprTrace "Offending party:" (ppr k <+> ppr live) $
- panic "live values in registers at call continuation"
- last l@(LastCondBranch _ t f) =
- changeRegs (gen l . kill l) $ dualUnion (env t) (env f)
- last l@(LastSwitch _ tbl) = changeRegs (gen l . kill l) $ dualUnionList $
- map env (catMaybes tbl)
- empty = fact_bot dualLiveLattice
-
+ add _ (OldFact old) (NewFact new) = (changeIf $ change1 || change2, DualLive stack regs)
+ where (change1, stack) = add1 (on_stack old) (on_stack new)
+ (change2, regs) = add1 (in_regs old) (in_regs new)
+ add1 old new = if sizeUniqSet join > sizeUniqSet old then (True, join) else (False, old)
+ where join = unionUniqSets old new
+
+dualLivenessWithInsertion :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
+dualLivenessWithInsertion procPoints g =
+ liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
+ (dualLiveTransfers (g_entry g) procPoints)
+ (insertSpillAndReloadRewrites g procPoints)
+
+dualLiveness :: BlockSet -> CmmGraph -> FuelUniqSM (BlockEnv DualLive)
+dualLiveness procPoints g =
+ liftM snd $ dataflowPassBwd g [] $ analBwd dualLiveLattice $ dualLiveTransfers (g_entry g) procPoints
+
+dualLiveTransfers :: BlockId -> BlockSet -> (BwdTransfer CmmNode DualLive)
+dualLiveTransfers entry procPoints = mkBTransfer3 first middle last
+ where first :: CmmNode C O -> DualLive -> DualLive
+ first (CmmEntry id) live = check live id $ -- live at procPoint => spill
+ if id /= entry && setMember id procPoints
+ then DualLive { on_stack = on_stack live `plusRegSet` in_regs live
+ , in_regs = emptyRegSet }
+ else live
+ where check live id x = if id == entry then noLiveOnEntry id (in_regs live) x else x
+
+ middle :: CmmNode O O -> DualLive -> DualLive
+ middle m live = changeStack updSlots $ changeRegs (xferLiveMiddle m) (changeRegs regs_in live)
+ where xferLiveMiddle = case getBTransfer3 xferLive of (_, middle, _) -> middle
+ regs_in :: RegSet -> RegSet
+ regs_in live = case m of CmmUnsafeForeignCall {} -> emptyRegSet
+ _ -> live
+ updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m
+ spill live s@(RegSlot r, _, _) = check s $ deleteFromRegSet live r
+ spill live _ = live
+ reload live s@(RegSlot r, _, _) = check s $ extendRegSet live r
+ reload live _ = live
+ check (RegSlot (LocalReg _ ty), o, w) x
+ | o == w && w == widthInBytes (typeWidth ty) = x
+ check _ _ = panic "middleDualLiveness unsupported: slices"
+ last :: CmmNode O C -> FactBase DualLive -> DualLive
+ last l fb = case l of
+ CmmBranch id -> lkp id
+ l@(CmmCall {cml_cont=Nothing}) -> changeRegs (gen l . kill l) empty
+ l@(CmmCall {cml_cont=Just k}) -> call l k
+ l@(CmmForeignCall {succ=k}) -> call l k
+ l@(CmmCondBranch _ t f) -> changeRegs (gen l . kill l) $ dualUnion (lkp t) (lkp f)
+ l@(CmmSwitch _ tbl) -> changeRegs (gen l . kill l) $ dualUnionList $ map lkp (catMaybes tbl)
+ where empty = fact_bot dualLiveLattice
+ lkp id = empty `fromMaybe` lookupFact id fb
+ call l k = DualLive (on_stack (lkp k)) (gen l emptyRegSet)
+
gen :: UserOfLocalRegs a => a -> RegSet -> RegSet
gen a live = foldRegsUsed extendRegSet live a
kill :: DefinerOfLocalRegs a => a -> RegSet -> RegSet
kill a live = foldRegsDefd deleteFromRegSet live a
-insertSpillAndReloadRewrites ::
- BlockId -> BlockSet -> BackwardRewrites Middle Last DualLive
-insertSpillAndReloadRewrites entry procPoints =
- BackwardRewrites first middle last exit
- where middle = middleInsertSpillsAndReloads
- last _ _ = Nothing
- exit = Nothing
- first id live =
- if id /= entry && elemBlockSet id procPoints then
- case map reload (uniqSetToList (in_regs live)) of
+insertSpillAndReloadRewrites :: CmmGraph -> BlockSet -> CmmBwdRewrite DualLive
+insertSpillAndReloadRewrites graph procPoints = deepBwdRw3 first middle nothing
+ -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
+ -- but GHC miscompiles it, see bug #4044.
+ where first :: CmmNode C O -> Fact O DualLive -> CmmReplGraph C O
+ first e@(CmmEntry id) live = return $
+ if id /= (g_entry graph) && setMember id procPoints then
+ case map reload (uniqSetToList spill_regs) of
[] -> Nothing
- is -> Just (mkMiddles is)
+ is -> Just $ mkFirst e <*> mkMiddles is
else Nothing
+ where
+ -- If we are splitting procedures, we need the LastForeignCall
+ -- to spill its results to the stack because they will only
+ -- be used by a separate procedure (so they can't stay in LocalRegs).
+ splitting = True
+ spill_regs = if splitting then in_regs live
+ else in_regs live `minusRegSet` defs
+ defs = case mapLookup id firstDefs of
+ Just defs -> defs
+ Nothing -> emptyRegSet
+ -- A LastForeignCall may contain some definitions, which take place
+ -- on return from the function call. Therefore, we build a map (firstDefs)
+ -- from BlockId to the set of variables defined on return to the BlockId.
+ firstDefs = mapFold addLive emptyBlockMap (toBlockMap graph)
+ addLive :: CmmBlock -> BlockEnv RegSet -> BlockEnv RegSet
+ addLive b env = case lastNode b of
+ CmmForeignCall {succ=k, res=defs} -> add k (mkRegSet defs) env
+ _ -> env
+ add bid defs env = mapInsert bid defs'' env
+ where defs'' = case mapLookup bid env of
+ Just defs' -> timesRegSet defs defs'
+ Nothing -> defs
+
+ middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
+ middle (CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _)) _ | reg == reg' = return Nothing
+ middle m@(CmmAssign (CmmLocal reg) _) live = return $
+ if reg `elemRegSet` on_stack live then -- must spill
+ my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
+ text "after"{-, ppr m-}]) $
+ Just $ mkMiddles $ [m, spill reg]
+ else Nothing
+ middle m@(CmmUnsafeForeignCall _ fs _) live = return $
+ case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
+ map reload (uniqSetToList (kill fs (in_regs live))) of
+ [] -> Nothing
+ reloads -> Just $ mkMiddles (m : reloads)
+ middle _ _ = return Nothing
+
+ nothing _ _ = return Nothing
-middleInsertSpillsAndReloads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
-middleInsertSpillsAndReloads m live = middle m
- where middle (MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg') _) _))
- | reg == reg' = Nothing
- middle (MidAssign (CmmLocal reg) _) =
- if reg `elemRegSet` on_stack live then -- must spill
- my_trace "Spilling" (f4sep [text "spill" <+> ppr reg,
- text "after", ppr m]) $
- Just $ mkMiddles $ [m, spill reg]
- else Nothing
- middle (MidForeignCall _ _ fs _) =
- case map spill (filter (flip elemRegSet (on_stack live)) fs) ++
- map reload (uniqSetToList (kill fs (in_regs live))) of
- [] -> Nothing
- reloads -> Just (mkMiddles (m : reloads))
- middle _ = Nothing
-
--- Generating spill and reload code
regSlot :: LocalReg -> CmmExpr
regSlot r = CmmStackSlot (RegSlot r) (widthInBytes $ typeWidth $ localRegType r)
-spill, reload :: LocalReg -> Middle
-spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r)
-reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
+spill, reload :: LocalReg -> CmmNode O O
+spill r = CmmStore (regSlot r) (CmmReg $ CmmLocal r)
+reload r = CmmAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r)
----------------------------------------------------------------
--- sinking reloads
availRegsLattice :: DataflowLattice AvailRegs
-availRegsLattice = DataflowLattice "register gotten from reloads" empty add False
+availRegsLattice = DataflowLattice "register gotten from reloads" empty add
where empty = UniverseMinus emptyRegSet
-- | compute in the Tx monad to track whether anything has changed
- add new old =
- let join = interAvail new old in
- if join `smallerAvail` old then aTx join else noTx join
+ add _ (OldFact old) (NewFact new) =
+ if join `smallerAvail` old then (SomeChange, join) else (NoChange, old)
+ where join = interAvail new old
interAvail :: AvailRegs -> AvailRegs -> AvailRegs
elemAvail (UniverseMinus s) r = not $ elemRegSet r s
elemAvail (AvailRegs s) r = elemRegSet r s
-type AvailFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs ())
+cmmAvailableReloads :: CmmGraph -> FuelUniqSM (BlockEnv AvailRegs)
+cmmAvailableReloads g =
+ liftM snd $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
+ analFwd availRegsLattice availReloadsTransfer
-cmmAvailableReloads :: LGraph Middle Last -> FuelMonad (BlockEnv AvailRegs)
-cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix)
- where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice
- avail_reloads_transfer empty g
- empty = fact_bot availRegsLattice
+availReloadsTransfer :: FwdTransfer CmmNode AvailRegs
+availReloadsTransfer = mkFTransfer3 (flip const) middleAvail ((mkFactBase availRegsLattice .) . lastAvail)
-avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs
-avail_reloads_transfer = ForwardTransfers (flip const) middleAvail lastAvail id
-
-middleAvail :: Middle -> AvailRegs -> AvailRegs
-middleAvail (MidAssign (CmmLocal r) (CmmLoad l _)) avail
+middleAvail :: CmmNode O O -> AvailRegs -> AvailRegs
+middleAvail (CmmAssign (CmmLocal r) (CmmLoad l _)) avail
| l `isStackSlotOf` r = extendAvail avail r
-middleAvail (MidAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
-middleAvail (MidStore l (CmmReg (CmmLocal r))) avail
+middleAvail (CmmAssign lhs _) avail = foldRegsDefd delFromAvail avail lhs
+middleAvail (CmmStore l (CmmReg (CmmLocal r))) avail
| l `isStackSlotOf` r = avail
-middleAvail (MidStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
-middleAvail (MidStore {}) avail = avail
-middleAvail (MidForeignCall {}) _ = AvailRegs emptyRegSet
-middleAvail (MidComment {}) avail = avail
-
-lastAvail :: Last -> AvailRegs -> LastOutFacts AvailRegs
-lastAvail (LastCall _ (Just k) _ _ _) _ = LastOutFacts [(k, AvailRegs emptyRegSet)]
-lastAvail l avail = LastOutFacts $ map (\id -> (id, avail)) $ succs l
-
-type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph)
-
-availRewrites :: ForwardRewrites Middle Last AvailRegs
-availRewrites = ForwardRewrites first middle last exit
- where first _ _ = Nothing
- middle m avail = maybe_reload_before avail m (mkMiddle m)
- last l avail = maybe_reload_before avail l (mkLast l)
- exit _ = Nothing
+middleAvail (CmmStore (CmmStackSlot (RegSlot r) _) _) avail = delFromAvail avail r
+middleAvail (CmmStore {}) avail = avail
+middleAvail (CmmUnsafeForeignCall {}) _ = AvailRegs emptyRegSet
+middleAvail (CmmComment {}) avail = avail
+
+lastAvail :: CmmNode O C -> AvailRegs -> [(Label, AvailRegs)]
+lastAvail (CmmCall _ (Just k) _ _ _) _ = [(k, AvailRegs emptyRegSet)]
+lastAvail (CmmForeignCall {succ=k}) _ = [(k, AvailRegs emptyRegSet)]
+lastAvail l avail = map (\id -> (id, avail)) $ successors l
+
+insertLateReloads :: CmmGraph -> FuelUniqSM CmmGraph
+insertLateReloads g =
+ liftM fst $ dataflowPassFwd g [(g_entry g, fact_bot availRegsLattice)] $
+ analRewFwd availRegsLattice availReloadsTransfer rewrites
+ where rewrites = mkFRewrite3 first middle last
+ first _ _ = return Nothing
+ middle m avail = return $ maybe_reload_before avail m (mkMiddle m)
+ last l avail = return $ maybe_reload_before avail l (mkLast l)
maybe_reload_before avail node tail =
let used = filterRegsUsed (elemAvail avail) node
in if isEmptyUniqSet used then Nothing
- else Just $ reloadTail used tail
+ else Just $ reloadTail used tail
reloadTail regset t = foldl rel t $ uniqSetToList regset
where rel t r = mkMiddle (reload r) <*> t
-
-insertLateReloads :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-insertLateReloads g = liftM zdfFpContents $ (res :: LateReloadFix)
- where res = zdfFRewriteFromL RewriteShallow emptyBlockEnv "insert late reloads"
- availRegsLattice avail_reloads_transfer availRewrites bot g
- bot = fact_bot availRegsLattice
-
-removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _) =
- liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last))
- where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim"
- dualLiveLattice (dualLiveTransfers entry procPoints)
- rewrites (fact_bot dualLiveLattice) g
- rewrites = BackwardRewrites nothing middleRemoveDeads nothing Nothing
- nothing _ _ = Nothing
-
-middleRemoveDeads :: Middle -> DualLive -> Maybe (AGraph Middle Last)
-middleRemoveDeads (MidAssign (CmmLocal reg') _) live
- | not (reg' `elemRegSet` in_regs live) = Just emptyAGraph
-middleRemoveDeads _ _ = Nothing
-
+removeDeadAssignmentsAndReloads :: BlockSet -> CmmGraph -> FuelUniqSM CmmGraph
+removeDeadAssignmentsAndReloads procPoints g =
+ liftM fst $ dataflowPassBwd g [] $ analRewBwd dualLiveLattice
+ (dualLiveTransfers (g_entry g) procPoints)
+ rewrites
+ where rewrites = deepBwdRw3 nothing middle nothing
+ -- Beware: deepBwdRw with one polymorphic function seems more reasonable here,
+ -- but GHC panics while compiling, see bug #4045.
+ middle :: CmmNode O O -> Fact O DualLive -> CmmReplGraph O O
+ middle (CmmAssign (CmmLocal reg') _) live | not (reg' `elemRegSet` in_regs live) = return $ Just emptyGraph
+ middle _ _ = return Nothing
+
+ nothing _ _ = return Nothing
---------------------
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
+{-# OPTIONS_GHC -XGADTs -XNoMonoLocalBinds #-}
-- Norman likes local bindings
-- If this module lives on I'd like to get rid of this flag in due course
+-- Todo: remove
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+
module CmmStackLayout
( SlotEnv, liveSlotAnal, liveSlotTransfers, removeLiveSlotDefs
, layout, manifestSP, igraph, areaBuilder
where
import Constants
-import Prelude hiding (zip, unzip, last)
+import Prelude hiding (succ, zip, unzip, last)
import BlockId
+import Cmm
import CmmExpr
-import CmmProcPointZ
-import CmmTx
-import DFMonad
+import CmmProcPoint
import Maybes
-import MkZipCfg
-import MkZipCfgCmm hiding (CmmBlock, CmmGraph)
+import MkGraph (stackStubExpr)
import Control.Monad
+import OptimizationFuel
import Outputable
import SMRep (ByteOff)
-import ZipCfg
-import ZipCfg as Z
-import ZipCfgCmmRep
-import ZipDataflow
+
+import Compiler.Hoopl
import Data.Map (Map)
import qualified Data.Map as Map
-- a single slot, on insertion.
slotLattice :: DataflowLattice SubAreaSet
-slotLattice = DataflowLattice "live slots" Map.empty add False
- where add new old = case Map.foldRightWithKey addArea (False, old) new of
- (True, x) -> aTx x
- (False, x) -> noTx x
+slotLattice = DataflowLattice "live slots" Map.empty add
+ where add _ (OldFact old) (NewFact new) = case Map.foldRightWithKey addArea (False, old) new of
+ (change, x) -> (changeIf change, x)
addArea a newSlots z = foldr (addSlot a) z newSlots
addSlot a slot (changed, map) =
let (c, live) = liveGen slot $ Map.findWithDefault [] a map
in (c || changed, Map.insert a live map)
+slotLatticeJoin :: [SubAreaSet] -> SubAreaSet
+slotLatticeJoin facts = foldr extend (fact_bot slotLattice) facts
+ where extend fact res = snd $ fact_join slotLattice undefined (OldFact fact) (NewFact res)
+
type SlotEnv = BlockEnv SubAreaSet
-- The sub-areas live on entry to the block
-type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a)
-
-liveSlotAnal :: LGraph Middle Last -> FuelMonad SlotEnv
-liveSlotAnal g = liftM zdfFpFacts (res :: SlotFix ())
- where res = zdfSolveFromL emptyBlockEnv "live slot analysis" slotLattice
- liveSlotTransfers (fact_bot slotLattice) g
+liveSlotAnal :: CmmGraph -> FuelUniqSM SlotEnv
+liveSlotAnal g = liftM snd $ dataflowPassBwd g [] $ analBwd slotLattice liveSlotTransfers
-- Add the subarea s to the subareas in the list-set (possibly coalescing it with
-- adjacent subareas), and also return whether s was a new addition.
-- considered live in to the block -- we treat the first node as a definition site.
-- BEWARE?: Am I being a little careless here in failing to check for the
-- entry Id (which would use the CallArea Old).
-liveSlotTransfers :: BackwardTransfers Middle Last SubAreaSet
-liveSlotTransfers =
- BackwardTransfers first liveInSlots liveLastIn
- where first id live = Map.delete (CallArea (Young id)) live
+liveSlotTransfers :: BwdTransfer CmmNode SubAreaSet
+liveSlotTransfers = mkBTransfer3 frt mid lst
+ where frt :: CmmNode C O -> SubAreaSet -> SubAreaSet
+ frt (CmmEntry l) f = Map.delete (CallArea (Young l)) f
+ mid :: CmmNode O O -> SubAreaSet -> SubAreaSet
+ mid n f = foldSlotsUsed addSlot (removeLiveSlotDefs f n) n
+ lst :: CmmNode O C -> FactBase SubAreaSet -> SubAreaSet
+ lst n f = liveInSlots n $ case n of
+ CmmCall {cml_cont=Nothing, cml_args=args} -> add_area (CallArea Old) args out
+ CmmCall {cml_cont=Just k, cml_args=args} -> add_area (CallArea Old) args (add_area (CallArea (Young k)) args out)
+ CmmForeignCall {succ=k, updfr=oldend} -> add_area (CallArea Old) oldend (add_area (CallArea (Young k)) wORD_SIZE out)
+ _ -> out
+ where out = joinOutFacts slotLattice n f
+ add_area _ n live | n == 0 = live
+ add_area a n live = Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live
-- Slot sets: adding slots, removing slots, and checking for membership.
liftToArea :: Area -> ([SubArea] -> [SubArea]) -> SubAreaSet -> SubAreaSet
liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => s -> SubAreaSet -> SubAreaSet
liveInSlots x live = foldSlotsUsed addSlot (removeLiveSlotDefs live x) x
-liveLastIn :: Last -> (BlockId -> SubAreaSet) -> SubAreaSet
+liveLastIn :: CmmNode O C -> (BlockId -> SubAreaSet) -> SubAreaSet
liveLastIn l env = liveInSlots l (liveLastOut env l)
-- Don't forget to keep the outgoing parameters in the CallArea live,
-- be a return to keep the update frame live. We'd still better keep the
-- info pointer in the update frame live at any call site;
-- otherwise we could screw up the garbage collector.
-liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet
+liveLastOut :: (BlockId -> SubAreaSet) -> CmmNode O C -> SubAreaSet
liveLastOut env l =
case l of
- LastCall _ Nothing n _ _ ->
+ CmmCall _ Nothing n _ _ ->
add_area (CallArea Old) n out -- add outgoing args (includes upd frame)
- LastCall _ (Just k) n _ (Just _) ->
+ CmmCall _ (Just k) n _ _ ->
add_area (CallArea Old) n (add_area (CallArea (Young k)) n out)
- LastCall _ (Just k) n _ Nothing ->
- add_area (CallArea (Young k)) n out
+ CmmForeignCall { succ = k, updfr = oldend } ->
+ add_area (CallArea Old) oldend (add_area (CallArea (Young k)) wORD_SIZE out)
_ -> out
- where out = joinOuts slotLattice env l
+ where out = slotLatticeJoin $ map env $ successors l
add_area _ n live | n == 0 = live
add_area a n live =
Map.insert a (snd $ liveGen (a, n, n) $ Map.findWithDefault [] a live) live
words areaSize areaMap a =
case Map.lookup a areaMap of
Just addr -> [addr .. addr + (Map.lookup a areaSize `orElse`
- pprPanic "wordsOccupied: unknown area" (ppr a))]
+ pprPanic "wordsOccupied: unknown area" (ppr areaSize <+> ppr a))]
Nothing -> []
--slotBuilder :: IGraphBuilder (Area, Int)
-- definitions.
type IGraph x = Map x (Set x)
type IGPair x = (IGraph x, IGraphBuilder x)
-igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> LGraph Middle Last -> IGraph x
-igraph builder env g = foldr interfere Map.empty (postorder_dfs g)
+igraph :: (Ord x) => IGraphBuilder x -> SlotEnv -> CmmGraph -> IGraph x
+igraph builder env g = foldr interfere Map.empty (postorderDfs g)
where foldN = foldNodes builder
- interfere block igraph =
- let (h, l) = goto_end (unzip block)
- --heads :: ZHead Middle -> (IGraph x, SubAreaSet) -> IGraph x
- heads (ZFirst _) (igraph, _) = igraph
- heads (ZHead h m) (igraph, liveOut) =
- heads h (addEdges igraph m liveOut, liveInSlots m liveOut)
- -- add edges between a def and the other defs and liveouts
- addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
- addDef (igraph, out) def@(a, _, _) =
- (foldN def (addDefN out) igraph,
- Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out)
- addDefN out n igraph =
- let addEdgeNO o igraph = foldN o addEdgeNN igraph
- addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph
- addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph
- where set = Map.findWithDefault Map.empty n igraph
- in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
- env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
- in heads h $ case l of LastExit -> (igraph, Map.empty)
- LastOther l -> (addEdges igraph l $ liveLastOut env' l,
- liveLastIn l env')
+ interfere block igraph = foldBlockNodesB3 (first, middle, last) block igraph
+ where first _ (igraph, _) = igraph
+ middle node (igraph, liveOut) =
+ (addEdges igraph node liveOut, liveInSlots node liveOut)
+ last node igraph =
+ (addEdges igraph node $ liveLastOut env' node, liveLastIn node env')
+
+ -- add edges between a def and the other defs and liveouts
+ addEdges igraph i out = fst $ foldSlotsDefd addDef (igraph, out) i
+ addDef (igraph, out) def@(a, _, _) =
+ (foldN def (addDefN out) igraph,
+ Map.insert a (snd $ liveGen def (Map.findWithDefault [] a out)) out)
+ addDefN out n igraph =
+ let addEdgeNO o igraph = foldN o addEdgeNN igraph
+ addEdgeNN n' igraph = addEdgeNN' n n' $ addEdgeNN' n' n igraph
+ addEdgeNN' n n' igraph = Map.insert n (Map.insert n' () set) igraph
+ where set = Map.findWithDefault Map.empty n igraph
+ in Map.foldRightWithKey (\ _ os igraph -> foldr addEdgeNO igraph os) igraph out
+ env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph"
-- Before allocating stack slots, we need to collect one more piece of information:
-- what's the highest offset (in bytes) used in each Area?
-- We'll need to allocate that much space for each Area.
-getAreaSize :: ByteOff -> LGraph Middle Last -> AreaMap
+
+-- JD: WHY CAN'T THIS COME FROM THE slot-liveness info?
+getAreaSize :: ByteOff -> CmmGraph -> AreaMap
-- The domain of the returned mapping consists only of Areas
-- used for (a) variable spill slots, and (b) parameter passing ares for calls
-getAreaSize entry_off g@(LGraph _ _) =
- fold_blocks (fold_fwd_block first add_regslots last)
+getAreaSize entry_off g =
+ foldGraphBlocks (foldBlockNodesF3 (first, add_regslots, last))
(Map.singleton (CallArea Old) entry_off) g
where first _ z = z
- last l@(LastOther (LastCall _ Nothing args res _)) z =
- add_regslots l (add (add z area args) area res)
+ last :: CmmNode O C -> Map Area Int -> Map Area Int
+ last l@(CmmCall _ Nothing args res _) z = add_regslots l (add (add z area args) area res)
where area = CallArea Old
- last l@(LastOther (LastCall _ (Just k) args res _)) z =
- add_regslots l (add (add z area args) area res)
+ last l@(CmmCall _ (Just k) args res _) z = add_regslots l (add (add z area args) area res)
+ where area = CallArea (Young k)
+ last l@(CmmForeignCall {succ = k}) z = add_regslots l (add z area wORD_SIZE)
where area = CallArea (Young k)
- last l z = add_regslots l z
+ last l z = add_regslots l z
add_regslots i z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z i) i
addSlot z (a@(RegSlot (LocalReg _ ty)), _, _) =
add z a $ widthInBytes $ typeWidth ty
-- Note: The stack pointer only has to be younger than the youngest live stack slot
-- at proc points. Otherwise, the stack pointer can point anywhere.
-layout :: ProcPointSet -> SlotEnv -> ByteOff -> LGraph Middle Last -> AreaMap
+layout :: ProcPointSet -> SlotEnv -> ByteOff -> CmmGraph -> AreaMap
-- The domain of the returned map includes an Area for EVERY block
-- including each block that is not the successor of a call (ie is not a proc-point)
-- That's how we return the info of what the SP should be at the entry of every block
layout procPoints env entry_off g =
let ig = (igraph areaBuilder env g, areaBuilder)
- env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph"
+ env' bid = mapLookup bid env `orElse` panic "unknown blockId in igraph"
areaSize = getAreaSize entry_off g
- -- Find the slots that are live-in to a block tail
- live_in (ZTail m l) = liveInSlots m (live_in l)
- live_in (ZLast (LastOther l)) = liveLastIn l env'
- live_in (ZLast LastExit) = Map.empty
-- Find the youngest live stack slot that has already been allocated
youngest_live :: AreaMap -- Already allocated
-- Update the successor's incoming SP.
setSuccSPs inSp bid areaMap =
- case (Map.lookup area areaMap, lookupBlockEnv (lg_blocks g) bid) of
+ case (Map.lookup area areaMap , mapLookup bid (toBlockMap g)) of
(Just _, _) -> areaMap -- succ already knows incoming SP
- (Nothing, Just (Block _ _)) ->
- if elemBlockSet bid procPoints then
+ (Nothing, Just _) ->
+ if setMember bid procPoints then
let young = youngest_live areaMap $ env' bid
-- start = case returnOff stackInfo of Just b -> max b young
-- Nothing -> young
(_, Nothing) -> panic "Block not found in cfg"
where area = CallArea (Young bid)
- allocLast (Block id _) areaMap l =
- fold_succs (setSuccSPs inSp) l areaMap
- where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap
-
- allocMidCall m@(MidForeignCall (Safe bid _ _) _ _ _) t areaMap =
- let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
- area = CallArea (Young bid)
- areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize
- in allocSlotFrom ig areaSize' young areaMap area
- allocMidCall _ _ areaMap = areaMap
-
- alloc m t areaMap =
- foldSlotsDefd alloc' (foldSlotsUsed alloc' (allocMidCall m t areaMap) m) m
- where alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
- alloc' areaMap _ = areaMap
-
- layoutAreas areaMap b@(Block _ t) = layout areaMap t
- where layout areaMap (ZTail m t) = layout (alloc m t areaMap) t
- layout areaMap (ZLast l) = allocLast b areaMap l
- initMap = Map.insert (CallArea (Young (lg_entry g))) 0
- (Map.insert (CallArea Old) 0 Map.empty)
- areaMap = foldl layoutAreas initMap (postorder_dfs g)
+ layoutAreas areaMap block = foldBlockNodesF3 (flip const, allocMid, allocLast (entryLabel block)) block areaMap
+ allocMid m areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap m) m
+ allocLast bid l areaMap =
+ foldr (setSuccSPs inSp) areaMap' (successors l)
+ where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young bid)) areaMap
+ areaMap' = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap l) l
+ alloc' areaMap (a@(RegSlot _), _, _) = allocVarSlot areaMap a
+ alloc' areaMap _ = areaMap
+
+ initMap = Map.insert (CallArea (Young (g_entry g))) 0 $
+ Map.insert (CallArea Old) 0 Map.empty
+
+ areaMap = foldl layoutAreas initMap (postorderDfs g)
in -- pprTrace "ProcPoints" (ppr procPoints) $
-- pprTrace "Area SizeMap" (ppr areaSize) $
-- pprTrace "Entry SP" (ppr entrySp) $
-- stack pointer to be younger than the live values on the stack at proc points.
-- 3. Compute the maximum stack offset used in the procedure and replace
-- the stack high-water mark with that offset.
-manifestSP :: AreaMap -> ByteOff -> LGraph Middle Last -> FuelMonad (LGraph Middle Last)
-manifestSP areaMap entry_off g@(LGraph entry _blocks) =
- liftM (LGraph entry) $ foldl replB (return emptyBlockEnv) (postorder_dfs g)
+manifestSP :: AreaMap -> ByteOff -> CmmGraph -> FuelUniqSM CmmGraph
+manifestSP areaMap entry_off g@(CmmGraph {g_entry=entry}) =
+ ofBlockMap entry `liftM` foldl replB (return mapEmpty) (postorderDfs g)
where slot a = -- pprTrace "slot" (ppr a) $
Map.lookup a areaMap `orElse` panic "unallocated Area"
slot' (Just id) = slot $ CallArea (Young id)
sp_high = maxSlot slot g
proc_entry_sp = slot (CallArea Old) + entry_off
+ add_sp_off :: CmmBlock -> BlockEnv Int -> BlockEnv Int
add_sp_off b env =
- case Z.last (unzip b) of
- LastOther (LastCall {cml_cont = Just succ, cml_ret_args = off}) ->
- extendBlockEnv env succ off
- _ -> env
- spEntryMap = fold_blocks add_sp_off (mkBlockEnv [(entry, entry_off)]) g
- spOffset id = lookupBlockEnv spEntryMap id `orElse` 0
+ case lastNode b of
+ CmmCall {cml_cont=Just succ, cml_ret_args=off} -> mapInsert succ off env
+ CmmForeignCall {succ=succ} -> mapInsert succ wORD_SIZE env
+ _ -> env
+ spEntryMap = foldGraphBlocks add_sp_off (mapInsert entry entry_off emptyBlockMap) g
+ spOffset id = mapLookup id spEntryMap `orElse` 0
sp_on_entry id | id == entry = proc_entry_sp
sp_on_entry id = slot' (Just id) + spOffset id
-- On entry to procpoints, the stack pointer is conventional;
-- otherwise, we check the SP set by predecessors.
- replB :: FuelMonad (BlockEnv CmmBlock) -> CmmBlock -> FuelMonad (BlockEnv CmmBlock)
- replB blocks (Block id t) =
- do bs <- replTail (Block id) spIn t
- -- pprTrace "spIn" (ppr id <+> ppr spIn) $ do
- liftM (flip (foldr insertBlock) bs) blocks
- where spIn = sp_on_entry id
- replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) ->
- FuelMonad ([CmmBlock])
- replTail h spOff (ZTail m@(MidForeignCall (Safe bid _ _) _ _ _) t) =
- replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t
- where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
- replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
- replTail h spOff (ZLast (LastOther l)) = fixSp h spOff l
- replTail h _ l@(ZLast LastExit) = return [h l]
- middle spOff m = mapExpDeepMiddle (replSlot spOff) m
- last spOff l = mapExpDeepLast (replSlot spOff) l
- replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
- replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
- CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
- replSlot _ e = e
- -- The block must establish the SP expected at each successsor.
- fixSp :: (ZTail Middle Last -> CmmBlock) -> Int -> Last -> FuelMonad ([CmmBlock])
- fixSp h spOff l@(LastCall _ k n _ _) = updSp h spOff (slot' k + n) l
- fixSp h spOff l@(LastBranch k) =
- let succSp = sp_on_entry k in
- if succSp /= spOff then
- -- pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $
- updSp h spOff succSp l
- else return $ [h (ZLast (LastOther (last spOff l)))]
- fixSp h spOff l = liftM (uncurry (:)) $ fold_succs succ l $ return (b, [])
- where b = h (ZLast (LastOther (last spOff l)))
- succ succId z =
- let succSp = sp_on_entry succId in
- if succSp /= spOff then
- do (b, bs) <- z
- (b', bs') <- insertBetween b [setSpMid spOff succSp] succId
- return (b', bs ++ bs')
- else z
- updSp h old new l = return [h $ setSp old new $ ZLast $ LastOther (last new l)]
- setSpMid sp sp' = MidAssign (CmmGlobal Sp) e
- where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
- off = CmmLit $ CmmInt (toInteger $ sp - sp') wordWidth
- setSp sp sp' t = if sp == sp' then t else ZTail (setSpMid sp sp') t
+ replB :: FuelUniqSM (BlockEnv CmmBlock) -> CmmBlock -> FuelUniqSM (BlockEnv CmmBlock)
+ replB blocks block =
+ do let (head, middles, JustC tail :: MaybeC C (CmmNode O C)) = blockToNodeList block
+ middles' = map (middle spIn) middles
+ bs <- replLast head middles' tail
+ flip (foldr insertBlock) bs `liftM` blocks
+ where spIn = sp_on_entry (entryLabel block)
+
+ middle spOff m = mapExpDeep (replSlot spOff) m
+ last spOff l = mapExpDeep (replSlot spOff) l
+ replSlot spOff (CmmStackSlot a i) = CmmRegOff (CmmGlobal Sp) (spOff - (slot a + i))
+ replSlot _ (CmmLit CmmHighStackMark) = -- replacing the high water mark
+ CmmLit (CmmInt (toInteger (max 0 (sp_high - proc_entry_sp))) (typeWidth bWord))
+ replSlot _ e = e
+
+ replLast :: MaybeC C (CmmNode C O) -> [CmmNode O O] -> CmmNode O C -> FuelUniqSM [CmmBlock]
+ replLast h m l@(CmmCall _ k n _ _) = updSp (slot' k + n) h m l
+ -- JD: LastForeignCall probably ought to have an outgoing
+ -- arg size, just like LastCall
+ replLast h m l@(CmmForeignCall {succ=k}) = updSp (slot' (Just k) + wORD_SIZE) h m l
+ replLast h m l@(CmmBranch k) = updSp (sp_on_entry k) h m l
+ replLast h m l = uncurry (:) `liftM` foldr succ (return (b, [])) (successors l)
+ where b :: CmmBlock
+ b = updSp' spIn h m l
+ succ succId z =
+ let succSp = sp_on_entry succId in
+ if succSp /= spIn then
+ do (b, bs) <- z
+ (b', bs') <- insertBetween b (adjustSp succSp) succId
+ return (b', bs' ++ bs)
+ else z
+
+ updSp sp h m l = return [updSp' sp h m l]
+ updSp' sp h m l | sp == spIn = blockOfNodeList (h, m, JustC $ last sp l)
+ | otherwise = blockOfNodeList (h, m ++ adjustSp sp, JustC $ last sp l)
+ adjustSp sp = [CmmAssign (CmmGlobal Sp) e]
+ where e = CmmMachOp (MO_Add wordWidth) [CmmReg (CmmGlobal Sp), off]
+ off = CmmLit $ CmmInt (toInteger $ spIn - sp) wordWidth
-- To compute the stack high-water mark, we fold over the graph and
-- compute the highest slot offset.
maxSlot :: (Area -> Int) -> CmmGraph -> Int
-maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) 0 g
+maxSlot slotOff g = foldGraphBlocks (foldBlockNodesF3 (flip const, highSlot, highSlot)) 0 g
where highSlot i z = foldSlotsUsed add (foldSlotsDefd add z i) i
add z (a, i, _) = max z (slotOff a + i)
-- This will miss stack slots that are last used in a Last node,
-- but it should do pretty well...
-type StubPtrFix = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet CmmGraph)
-
-stubSlotsOnDeath :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last)
-stubSlotsOnDeath g = liftM zdfFpContents $ (res :: StubPtrFix)
- where res = zdfBRewriteFromL RewriteShallow emptyBlockEnv "stub ptrs" slotLattice
- liveSlotTransfers rewrites (fact_bot slotLattice) g
- rewrites = BackwardRewrites first middle last Nothing
- first _ _ = Nothing
- last _ _ = Nothing
- middle m liveSlots = foldSlotsUsed (stub liveSlots m) Nothing m
+stubSlotsOnDeath :: CmmGraph -> FuelUniqSM CmmGraph
+stubSlotsOnDeath g = liftM fst $ dataflowPassBwd g [] $ analRewBwd slotLattice
+ liveSlotTransfers
+ rewrites
+ where rewrites = mkBRewrite3 frt mid lst
+ frt _ _ = return Nothing
+ mid m liveSlots = return $ foldSlotsUsed (stub liveSlots m) Nothing m
+ lst _ _ = return Nothing
stub liveSlots m rst subarea@(a, off, w) =
if elemSlot liveSlots subarea then rst
- else let store = mkStore (CmmStackSlot a off)
- (stackStubExpr (widthFromBytes w))
+ else let store = mkMiddle $ CmmStore (CmmStackSlot a off)
+ (stackStubExpr (widthFromBytes w))
in case rst of Nothing -> Just (mkMiddle m <*> store)
Just g -> Just (g <*> store)
+++ /dev/null
-module CmmTx where
-
-data ChangeFlag = NoChange | SomeChange
-
-type Tx a = a -> TxRes a
-data TxRes a = TxRes ChangeFlag a
-
-seqTx :: Tx a -> Tx a -> Tx a
-iterateTx :: Tx a -> Tx a
-runTx :: Tx a -> a -> a
-
-noTx, aTx :: a -> TxRes a
-noTx x = TxRes NoChange x
-aTx x = TxRes SomeChange x
-
-replaceTx :: a -> TxRes b -> TxRes a
-replaceTx a (TxRes change _) = TxRes change a
-
-txVal :: TxRes a -> a
-txVal (TxRes _ a) = a
-
-txHasChanged :: TxRes a -> Bool
-txHasChanged (TxRes NoChange _) = False
-txHasChanged (TxRes SomeChange _) = True
-
-plusTx :: (a -> b -> c) -> TxRes a -> TxRes b -> TxRes c
-plusTx f (TxRes c1 a) (TxRes c2 b) = TxRes (c1 `orChange` c2) (f a b)
-
-mapTx :: Tx a -> Tx [a]
-mapTx _ [] = noTx []
-mapTx f (x:xs) = plusTx (:) (f x) (mapTx f xs)
-
-runTx f = txVal . f
-
-seqTx f1 f2 a =
- let TxRes c1 a1 = f1 a
- TxRes c2 a2 = f2 a1
- in TxRes (c1 `orChange` c2) a2
-
-iterateTx f a
- = case f a of
- TxRes NoChange a' -> TxRes NoChange a'
- TxRes SomeChange a' -> let TxRes _ a'' = iterateTx f a'
- in TxRes SomeChange a''
-
-orChange :: ChangeFlag -> ChangeFlag -> ChangeFlag
-orChange NoChange c = c
-orChange SomeChange _ = SomeChange
-
-
-
-instance Functor TxRes where
- fmap f (TxRes ch a) = TxRes ch (f a)
-
-instance Monad TxRes where
- return = TxRes NoChange
- (TxRes NoChange a) >>= k = k a
- (TxRes SomeChange a) >>= k = let (TxRes _ a') = k a in TxRes SomeChange a'
--- /dev/null
+
+module CmmType
+ ( CmmType -- Abstract
+ , b8, b16, b32, b64, f32, f64, bWord, bHalfWord, gcWord
+ , cInt, cLong
+ , cmmBits, cmmFloat
+ , typeWidth, cmmEqType, cmmEqType_ignoring_ptrhood
+ , isFloatType, isGcPtrType, isWord32, isWord64, isFloat64, isFloat32
+
+ , Width(..)
+ , widthInBits, widthInBytes, widthInLog, widthFromBytes
+ , wordWidth, halfWordWidth, cIntWidth, cLongWidth
+ , narrowU, narrowS
+ )
+where
+
+#include "HsVersions.h"
+
+import Constants
+import FastString
+import Outputable
+
+import Data.Word
+import Data.Int
+
+-----------------------------------------------------------------------------
+-- CmmType
+-----------------------------------------------------------------------------
+
+ -- NOTE: CmmType is an abstract type, not exported from this
+ -- module so you can easily change its representation
+ --
+ -- However Width is exported in a concrete way,
+ -- and is used extensively in pattern-matching
+
+data CmmType -- The important one!
+ = CmmType CmmCat Width
+
+data CmmCat -- "Category" (not exported)
+ = GcPtrCat -- GC pointer
+ | BitsCat -- Non-pointer
+ | FloatCat -- Float
+ deriving( Eq )
+ -- See Note [Signed vs unsigned] at the end
+
+instance Outputable CmmType where
+ ppr (CmmType cat wid) = ppr cat <> ppr (widthInBits wid)
+
+instance Outputable CmmCat where
+ ppr FloatCat = ptext $ sLit("F")
+ ppr _ = ptext $ sLit("I")
+-- Temp Jan 08
+-- ppr FloatCat = ptext $ sLit("float")
+-- ppr BitsCat = ptext $ sLit("bits")
+-- ppr GcPtrCat = ptext $ sLit("gcptr")
+
+-- Why is CmmType stratified? For native code generation,
+-- most of the time you just want to know what sort of register
+-- to put the thing in, and for this you need to know how
+-- many bits thing has and whether it goes in a floating-point
+-- register. By contrast, the distinction between GcPtr and
+-- GcNonPtr is of interest to only a few parts of the code generator.
+
+-------- Equality on CmmType --------------
+-- CmmType is *not* an instance of Eq; sometimes we care about the
+-- Gc/NonGc distinction, and sometimes we don't
+-- So we use an explicit function to force you to think about it
+cmmEqType :: CmmType -> CmmType -> Bool -- Exact equality
+cmmEqType (CmmType c1 w1) (CmmType c2 w2) = c1==c2 && w1==w2
+
+cmmEqType_ignoring_ptrhood :: CmmType -> CmmType -> Bool
+ -- This equality is temporary; used in CmmLint
+ -- but the RTS files are not yet well-typed wrt pointers
+cmmEqType_ignoring_ptrhood (CmmType c1 w1) (CmmType c2 w2)
+ = c1 `weak_eq` c2 && w1==w2
+ where
+ FloatCat `weak_eq` FloatCat = True
+ FloatCat `weak_eq` _other = False
+ _other `weak_eq` FloatCat = False
+ _word1 `weak_eq` _word2 = True -- Ignores GcPtr
+
+--- Simple operations on CmmType -----
+typeWidth :: CmmType -> Width
+typeWidth (CmmType _ w) = w
+
+cmmBits, cmmFloat :: Width -> CmmType
+cmmBits = CmmType BitsCat
+cmmFloat = CmmType FloatCat
+
+-------- Common CmmTypes ------------
+-- Floats and words of specific widths
+b8, b16, b32, b64, f32, f64 :: CmmType
+b8 = cmmBits W8
+b16 = cmmBits W16
+b32 = cmmBits W32
+b64 = cmmBits W64
+f32 = cmmFloat W32
+f64 = cmmFloat W64
+
+-- CmmTypes of native word widths
+bWord, bHalfWord, gcWord :: CmmType
+bWord = cmmBits wordWidth
+bHalfWord = cmmBits halfWordWidth
+gcWord = CmmType GcPtrCat wordWidth
+
+cInt, cLong :: CmmType
+cInt = cmmBits cIntWidth
+cLong = cmmBits cLongWidth
+
+
+------------ Predicates ----------------
+isFloatType, isGcPtrType :: CmmType -> Bool
+isFloatType (CmmType FloatCat _) = True
+isFloatType _other = False
+
+isGcPtrType (CmmType GcPtrCat _) = True
+isGcPtrType _other = False
+
+isWord32, isWord64, isFloat32, isFloat64 :: CmmType -> Bool
+-- isWord64 is true of 64-bit non-floats (both gc-ptrs and otherwise)
+-- isFloat32 and 64 are obvious
+
+isWord64 (CmmType BitsCat W64) = True
+isWord64 (CmmType GcPtrCat W64) = True
+isWord64 _other = False
+
+isWord32 (CmmType BitsCat W32) = True
+isWord32 (CmmType GcPtrCat W32) = True
+isWord32 _other = False
+
+isFloat32 (CmmType FloatCat W32) = True
+isFloat32 _other = False
+
+isFloat64 (CmmType FloatCat W64) = True
+isFloat64 _other = False
+
+-----------------------------------------------------------------------------
+-- Width
+-----------------------------------------------------------------------------
+
+data Width = W8 | W16 | W32 | W64
+ | W80 -- Extended double-precision float,
+ -- used in x86 native codegen only.
+ -- (we use Ord, so it'd better be in this order)
+ | W128
+ deriving (Eq, Ord, Show)
+
+instance Outputable Width where
+ ppr rep = ptext (mrStr rep)
+
+mrStr :: Width -> LitString
+mrStr W8 = sLit("W8")
+mrStr W16 = sLit("W16")
+mrStr W32 = sLit("W32")
+mrStr W64 = sLit("W64")
+mrStr W128 = sLit("W128")
+mrStr W80 = sLit("W80")
+
+
+-------- Common Widths ------------
+wordWidth, halfWordWidth :: Width
+wordWidth | wORD_SIZE == 4 = W32
+ | wORD_SIZE == 8 = W64
+ | otherwise = panic "MachOp.wordRep: Unknown word size"
+
+halfWordWidth | wORD_SIZE == 4 = W16
+ | wORD_SIZE == 8 = W32
+ | otherwise = panic "MachOp.halfWordRep: Unknown word size"
+
+-- cIntRep is the Width for a C-language 'int'
+cIntWidth, cLongWidth :: Width
+#if SIZEOF_INT == 4
+cIntWidth = W32
+#elif SIZEOF_INT == 8
+cIntWidth = W64
+#endif
+
+#if SIZEOF_LONG == 4
+cLongWidth = W32
+#elif SIZEOF_LONG == 8
+cLongWidth = W64
+#endif
+
+widthInBits :: Width -> Int
+widthInBits W8 = 8
+widthInBits W16 = 16
+widthInBits W32 = 32
+widthInBits W64 = 64
+widthInBits W128 = 128
+widthInBits W80 = 80
+
+widthInBytes :: Width -> Int
+widthInBytes W8 = 1
+widthInBytes W16 = 2
+widthInBytes W32 = 4
+widthInBytes W64 = 8
+widthInBytes W128 = 16
+widthInBytes W80 = 10
+
+widthFromBytes :: Int -> Width
+widthFromBytes 1 = W8
+widthFromBytes 2 = W16
+widthFromBytes 4 = W32
+widthFromBytes 8 = W64
+widthFromBytes 16 = W128
+widthFromBytes 10 = W80
+widthFromBytes n = pprPanic "no width for given number of bytes" (ppr n)
+
+-- log_2 of the width in bytes, useful for generating shifts.
+widthInLog :: Width -> Int
+widthInLog W8 = 0
+widthInLog W16 = 1
+widthInLog W32 = 2
+widthInLog W64 = 3
+widthInLog W128 = 4
+widthInLog W80 = panic "widthInLog: F80"
+
+-- widening / narrowing
+
+narrowU :: Width -> Integer -> Integer
+narrowU W8 x = fromIntegral (fromIntegral x :: Word8)
+narrowU W16 x = fromIntegral (fromIntegral x :: Word16)
+narrowU W32 x = fromIntegral (fromIntegral x :: Word32)
+narrowU W64 x = fromIntegral (fromIntegral x :: Word64)
+narrowU _ _ = panic "narrowTo"
+
+narrowS :: Width -> Integer -> Integer
+narrowS W8 x = fromIntegral (fromIntegral x :: Int8)
+narrowS W16 x = fromIntegral (fromIntegral x :: Int16)
+narrowS W32 x = fromIntegral (fromIntegral x :: Int32)
+narrowS W64 x = fromIntegral (fromIntegral x :: Int64)
+narrowS _ _ = panic "narrowTo"
+
+-------------------------------------------------------------------------
+{- Note [Signed vs unsigned]
+ ~~~~~~~~~~~~~~~~~~~~~~~~~
+Should a CmmType include a signed vs. unsigned distinction?
+
+This is very much like a "hint" in C-- terminology: it isn't necessary
+in order to generate correct code, but it might be useful in that the
+compiler can generate better code if it has access to higher-level
+hints about data. This is important at call boundaries, because the
+definition of a function is not visible at all of its call sites, so
+the compiler cannot infer the hints.
+
+Here in Cmm, we're taking a slightly different approach. We include
+the int vs. float hint in the MachRep, because (a) the majority of
+platforms have a strong distinction between float and int registers,
+and (b) we don't want to do any heavyweight hint-inference in the
+native code backend in order to get good code. We're treating the
+hint more like a type: our Cmm is always completely consistent with
+respect to hints. All coercions between float and int are explicit.
+
+What about the signed vs. unsigned hint? This information might be
+useful if we want to keep sub-word-sized values in word-size
+registers, which we must do if we only have word-sized registers.
+
+On such a system, there are two straightforward conventions for
+representing sub-word-sized values:
+
+(a) Leave the upper bits undefined. Comparison operations must
+ sign- or zero-extend both operands before comparing them,
+ depending on whether the comparison is signed or unsigned.
+
+(b) Always keep the values sign- or zero-extended as appropriate.
+ Arithmetic operations must narrow the result to the appropriate
+ size.
+
+A clever compiler might not use either (a) or (b) exclusively, instead
+it would attempt to minimize the coercions by analysis: the same kind
+of analysis that propagates hints around. In Cmm we don't want to
+have to do this, so we plump for having richer types and keeping the
+type information consistent.
+
+If signed/unsigned hints are missing from MachRep, then the only
+choice we have is (a), because we don't know whether the result of an
+operation should be sign- or zero-extended.
+
+Many architectures have extending load operations, which work well
+with (b). To make use of them with (a), you need to know whether the
+value is going to be sign- or zero-extended by an enclosing comparison
+(for example), which involves knowing above the context. This is
+doable but more complex.
+
+Further complicating the issue is foreign calls: a foreign calling
+convention can specify that signed 8-bit quantities are passed as
+sign-extended 32 bit quantities, for example (this is the case on the
+PowerPC). So we *do* need sign information on foreign call arguments.
+
+Pros for adding signed vs. unsigned to MachRep:
+
+ - It would let us use convention (b) above, and get easier
+ code generation for extending loads.
+
+ - Less information required on foreign calls.
+
+ - MachOp type would be simpler
+
+Cons:
+
+ - More complexity
+
+ - What is the MachRep for a VanillaReg? Currently it is
+ always wordRep, but now we have to decide whether it is
+ signed or unsigned. The same VanillaReg can thus have
+ different MachReps in different parts of the program.
+
+ - Extra coercions cluttering up expressions.
+
+Currently for GHC, the foreign call point is moot, because we do our
+own promotion of sub-word-sized values to word-sized values. The Int8
+type is represnted by an Int# which is kept sign-extended at all times
+(this is slightly naughty, because we're making assumptions about the
+C calling convention rather early on in the compiler). However, given
+this, the cons outweigh the pros.
+
+-}
+
--
-----------------------------------------------------------------------------
-module CmmUtils(
- CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
- isNopStmt,
-
+module CmmUtils(
primRepCmmType, primRepForeignHint,
typeCmmType, typeForeignHint,
mkIntCLit, zeroCLit,
mkLblExpr,
-
- maybeAssignTemp, loadArgsIntoTemps
) where
#include "HsVersions.h"
import Type ( Type, typePrimRep )
import CLabel
-import Cmm
-import OrdList
+import CmmDecl
+import CmmExpr
import Outputable
-import Unique
---------------------------------------------------
--
---------------------------------------------------
--
--- CmmStmts
---
----------------------------------------------------
-
-type CmmStmts = OrdList CmmStmt
-
-noStmts :: CmmStmts
-noStmts = nilOL
-
-oneStmt :: CmmStmt -> CmmStmts
-oneStmt = unitOL
-
-mkStmts :: [CmmStmt] -> CmmStmts
-mkStmts = toOL
-
-plusStmts :: CmmStmts -> CmmStmts -> CmmStmts
-plusStmts = appOL
-
-stmtList :: CmmStmts -> [CmmStmt]
-stmtList = fromOL
-
-
----------------------------------------------------
---
--- CmmStmt
---
----------------------------------------------------
-
-isNopStmt :: CmmStmt -> Bool
--- If isNopStmt returns True, the stmt is definitely a no-op;
--- but it might be a no-op even if isNopStmt returns False
-isNopStmt CmmNop = True
-isNopStmt (CmmAssign r e) = cheapEqReg r e
-isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2
-isNopStmt _ = False
-
-cheapEqExpr :: CmmExpr -> CmmExpr -> Bool
-cheapEqExpr (CmmReg r) e = cheapEqReg r e
-cheapEqExpr (CmmRegOff r 0) e = cheapEqReg r e
-cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n'
-cheapEqExpr _ _ = False
-
-cheapEqReg :: CmmReg -> CmmExpr -> Bool
-cheapEqReg r (CmmReg r') = r==r'
-cheapEqReg r (CmmRegOff r' 0) = r==r'
-cheapEqReg _ _ = False
-
----------------------------------------------------
---
-- CmmExpr
--
---------------------------------------------------
mkLblExpr :: CLabel -> CmmExpr
mkLblExpr lbl = CmmLit (CmmLabel lbl)
-
----------------------------------------------------
---
--- Helpers for foreign call arguments
---
----------------------------------------------------
-
-loadArgsIntoTemps :: [Unique]
- -> HintedCmmActuals
- -> ([Unique], [CmmStmt], HintedCmmActuals)
-loadArgsIntoTemps uniques [] = (uniques, [], [])
-loadArgsIntoTemps uniques ((CmmHinted e hint):args) =
- (uniques'',
- new_stmts ++ remaining_stmts,
- (CmmHinted new_e hint) : remaining_e)
- where
- (uniques', new_stmts, new_e) = maybeAssignTemp uniques e
- (uniques'', remaining_stmts, remaining_e) =
- loadArgsIntoTemps uniques' args
-
-
-maybeAssignTemp :: [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr)
-maybeAssignTemp uniques e
- | hasNoGlobalRegs e = (uniques, [], e)
- | otherwise = (tail uniques, [CmmAssign local e], CmmReg local)
- where local = CmmLocal (LocalReg (head uniques) (cmmExprType e))
+++ /dev/null
-
-module CmmZipUtil
- ( zipPreds
- , givesUniquePredecessorTo
- )
-where
-import BlockId
-import Prelude hiding (last, unzip)
-import ZipCfg
-
-import Maybes
-
--- | Compute the predecessors of each /reachable/ block
-zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet
-zipPreds g = foldl add emptyBlockEnv (postorder_dfs g)
- where add env block@(Block id _) =
- foldl (\env sid ->
- let preds = lookupBlockEnv env sid `orElse` emptyBlockSet
- in extendBlockEnv env sid (extendBlockSet preds id))
- env (succs block)
-
--- | Tell if a graph gives a block a unique predecessor. For
--- efficiency, this function is designed to be partially applied.
-
-givesUniquePredecessorTo :: LastNode l => LGraph m l -> BlockId -> Bool
-givesUniquePredecessorTo g = \id -> elemBlockSet id singlePreds
- -- accumulates a pair of sets: the set of all blocks containing a single
- -- predecessor, and the set of all blocks containing at least two predecessors
- where (singlePreds, _) = fold_blocks add (emptyBlockSet, emptyBlockSet) g
- add b (single, multi) = foldl add_pred (single, multi) (succs b)
- add_pred pair@(single, multi) id =
- if elemBlockSet id multi then pair
- else if elemBlockSet id single then
- (removeBlockSet single id, extendBlockSet multi id)
- else
- (extendBlockSet single id, multi)
-
-
-
+++ /dev/null
-module DFMonad
- ( DataflowLattice(..) , DataflowAnalysis
- , markFactsUnchanged, factsStatus, getFact, setFact, getExitFact, setExitFact
- , forgetFact, botFact, setAllFacts, getAllFacts, factsEnv
- , addLastOutFact, bareLastOutFacts, forgetLastOutFacts, checkFactMatch
- , subAnalysis
-
- , DFM, runDFM, liftToDFM
- , markGraphRewritten, graphWasRewritten
- , module OptimizationFuel
- )
-where
-
-import BlockId
-import CmmTx
-import PprCmm()
-import OptimizationFuel
-
-import Maybes
-import Outputable
-import UniqSupply
-
-{-
-
-A dataflow monad maintains a mapping from BlockIds to dataflow facts,
-where a dataflow fact is a value of type [[a]]. Values of type [[a]]
-must form a lattice, as described by type [[Fact a]].
-
-The dataflow engine uses the lattice structure to compute a least
-solution to a set of dataflow equations. To compute a greatest
-solution, flip the lattice over.
-
-The engine works by starting at the bottom and iterating to a fixed
-point, so in principle we require the bottom element, a join (least
-upper bound) operation, and a comparison to find out if a value has
-changed (grown). In practice, the comparison is only ever used in
-conjunction with the join, so we have [[fact_add_to]]:
-
- fact_add_to new old =
- let j = join new old in
- if j <= old then noTx old -- nothing changed
- else aTx j -- the fact changed
-
--}
-
-data DataflowLattice a = DataflowLattice {
- fact_name :: String, -- documentation
- fact_bot :: a, -- lattice bottom element
- fact_add_to :: a -> a -> TxRes a, -- lattice join and compare
- -- ^ compute join of two args; something changed iff join is greater than 2nd arg
- fact_do_logging :: Bool -- log changes
-}
-
-
--- DFM is the monad of combined analysis and transformation,
--- which needs a UniqSupply and may consume optimization fuel
--- DFM is defined using a monad transformer, DFM', which is the general
--- case of DFM, parameterized over any monad.
--- In practice, we apply DFM' to the FuelMonad, which provides optimization fuel and
--- the unique supply.
-data DFState f = DFState { df_rewritten :: !ChangeFlag
- , df_facts :: !(BlockEnv f)
- , df_exit_fact :: !f
- , df_last_outs :: ![(BlockId, f)]
- , df_facts_change :: !ChangeFlag
- }
-
-newtype DFM' m fact a = DFM' (DataflowLattice fact -> DFState fact
- -> m (a, DFState fact))
-type DFM fact a = DFM' FuelMonad fact a
-
-
-runDFM :: Monad m => DataflowLattice f -> DFM' m f a -> m a
-runDFM lattice (DFM' f) =
- (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice) [] NoChange)
- >>= return . fst
-
-class DataflowAnalysis m where
- markFactsUnchanged :: m f () -- ^ Useful for starting a new iteration
- factsStatus :: m f ChangeFlag
- subAnalysis :: m f a -> m f a -- ^ Do a new analysis and then throw away
- -- /all/ the related state.
-
- getFact :: BlockId -> m f f
- setFact :: Outputable f => BlockId -> f -> m f ()
- getExitFact :: m f f
- setExitFact :: Outputable f => f -> m f ()
- checkFactMatch :: Outputable f =>
- BlockId -> f -> m f () -- ^ assert fact already at this val
- botFact :: m f f
- forgetFact :: BlockId -> m f ()
- -- | It might be surprising these next two are needed in a pure analysis,
- -- but for some problems we do a 'shallow' rewriting in which a rewritten
- -- graph is not itself considered for further rewriting but merely undergoes
- -- an analysis. In this case the results of a forward analysis might produce
- -- new facts that go on BlockId's that reside outside the graph being analyzed.
- -- Thus these 'lastOutFacts' need to be available even in a pure analysis.
- addLastOutFact :: (BlockId, f) -> m f ()
- bareLastOutFacts :: m f [(BlockId, f)]
- forgetLastOutFacts :: m f ()
- getAllFacts :: m f (BlockEnv f)
- setAllFacts :: BlockEnv f -> m f ()
- factsEnv :: Monad (m f) => m f (BlockId -> f)
-
- lattice :: m f (DataflowLattice f)
- factsEnv = do { map <- getAllFacts
- ; bot <- botFact
- ; return $ \id -> lookupBlockEnv map id `orElse` bot }
-
-instance Monad m => DataflowAnalysis (DFM' m) where
- markFactsUnchanged = DFM' f
- where f _ s = return ((), s {df_facts_change = NoChange})
- factsStatus = DFM' f'
- where f' _ s = return (df_facts_change s, s)
- subAnalysis (DFM' f) = DFM' f'
- where f' l s = do (a, _) <- f l (subAnalysisState s)
- return (a, s)
- getFact id = DFM' get
- where get lattice s =
- return (lookupBlockEnv (df_facts s) id `orElse` fact_bot lattice, s)
- setFact id a = DFM' set
- where set (DataflowLattice name bot add_fact log) s =
- case add_fact a old of
- TxRes NoChange _ -> if initialized then return ((), s) else update old old
- TxRes SomeChange join -> update join old
- where (old, initialized) =
- case lookupBlockEnv (df_facts s) id of
- Just f -> (f, True)
- Nothing -> (bot, False)
- update join old =
- let facts' = extendBlockEnv (df_facts s) id join
- debug = if log then pprTrace else \_ _ a -> a
- in debug name (pprSetFact id old a join) $
- return ((), s { df_facts = facts', df_facts_change = SomeChange })
- getExitFact = DFM' get
- where get _ s = return (df_exit_fact s, s)
- setExitFact a =
- do DataflowLattice { fact_name = name, fact_do_logging = log} <- lattice
- DFM' $ \_ s ->
- let debug = if log then pprTrace else \_ _ a -> a
- in debug name (pprSetFact "exit" a a a) $
- return ((), s { df_exit_fact = a })
- getAllFacts = DFM' f
- where f _ s = return (df_facts s, s)
- setAllFacts env = DFM' f
- where f _ s = return ((), s { df_facts = env})
- botFact = DFM' f
- where f lattice s = return (fact_bot lattice, s)
- forgetFact id = DFM' f
- where f _ s = return ((), s { df_facts = delFromBlockEnv (df_facts s) id })
- addLastOutFact pair = DFM' f
- where f _ s = return ((), s { df_last_outs = pair : df_last_outs s })
- bareLastOutFacts = DFM' f
- where f _ s = return (df_last_outs s, s)
- forgetLastOutFacts = DFM' f
- where f _ s = return ((), s { df_last_outs = [] })
- checkFactMatch id a =
- do { fact <- lattice
- ; old_a <- getFact id
- ; case fact_add_to fact a old_a of
- TxRes NoChange _ -> return ()
- TxRes SomeChange new ->
- do { facts <- getAllFacts
- ; pprPanic "checkFactMatch"
- (f4sep [text (fact_name fact), text "at id" <+> ppr id,
- text "changed from", nest 4 (ppr old_a), text "to",
- nest 4 (ppr new),
- text "after supposedly reaching fixed point;",
- text "env is", pprFacts facts]) }
- }
- where pprFacts env = vcat (map pprFact (blockEnvToList env))
- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-
- lattice = DFM' f
- where f l s = return (l, s)
-
-subAnalysisState :: DFState f -> DFState f
-subAnalysisState s = s {df_facts_change = NoChange}
-
-
-markGraphRewritten :: Monad m => DFM' m f ()
-markGraphRewritten = DFM' f
- where f _ s = return ((), s {df_rewritten = SomeChange})
-
-graphWasRewritten :: DFM f ChangeFlag
-graphWasRewritten = DFM' f
- where f _ s = return (df_rewritten s, s)
-
-instance Monad m => Monad (DFM' m f) where
- DFM' f >>= k = DFM' (\l s -> do (a, s') <- f l s
- s' `seq` case k a of DFM' f' -> f' l s')
- return a = DFM' (\_ s -> return (a, s))
- -- The `seq` is essential to ensure that entire passes of the dataflow engine
- -- aren't postponed in a thunk. By making the sequence strict in the state,
- -- we ensure that each action in the monad is executed immediately, preventing
- -- stack overflows that previously occurred when finally forcing the old state thunks.
-
-instance FuelUsingMonad (DFM' FuelMonad f) where
- fuelRemaining = liftToDFM' fuelRemaining
- lastFuelPass = liftToDFM' lastFuelPass
- fuelExhausted = liftToDFM' fuelExhausted
- fuelDecrement p f f' = liftToDFM' (fuelDecrement p f f')
- fuelDec1 = liftToDFM' fuelDec1
-instance MonadUnique (DFM' FuelMonad f) where
- getUniqueSupplyM = liftToDFM' getUniqueSupplyM
- getUniqueM = liftToDFM' getUniqueM
- getUniquesM = liftToDFM' getUniquesM
-
-liftToDFM' :: Monad m => m x -> DFM' m f x
-liftToDFM' m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
-liftToDFM :: FuelMonad x -> DFM f x
-liftToDFM m = DFM' (\ _ s -> m >>= (\a -> return (a, s)))
-
-
-pprSetFact :: (Show a, Outputable f) => a -> f -> f -> f -> SDoc
-pprSetFact id old a join =
- f4sep [text "at" <+> text (show id),
- text "added" <+> ppr a, text "to" <+> ppr old,
- text "yielding" <+> ppr join]
-
-f4sep :: [SDoc] -> SDoc
-f4sep [] = fsep []
-f4sep (d:ds) = fsep (d : map (nest 4) ds)
+++ /dev/null
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-
-module Dataflow (
- fixedpoint
- ) where
-
------------------------------------------------------------------------------
--- | Solve the fixed-point of a dataflow problem.
---
--- Complexity: O(N+H*E) calls to the update function where:
--- N = number of nodes,
--- E = number of edges,
--- H = maximum height of the lattice for any particular node.
---
--- Sketch for proof of complexity:
--- Note that the state is threaded through the entire execution.
--- Also note that the height of the latice at any particular node
--- is the number of times 'update' can return non-Nothing for a
--- particular node. Every call (except for the top level one)
--- must be caused by a non-Nothing result and each non-Nothing
--- result causes as many calls as it has out-going edges.
--- Thus any particular node, n, may cause in total at
--- most H*out(n) further calls. When summed over all nodes,
--- that is H*E. The N term of the complexity is from the initial call
--- when 'update' will be passed 'Nothing'.
-fixedpoint ::
- (node -> [node]) -- map from nodes to those who's
- -- value depend on the argument node
- -> (node -> Maybe node -> s -> Maybe s)
- -- Given the node which needs to be
- -- updated, and which node caused that node
- -- to need to be updated, update the state.
- --
- -- The causing node will be 'Nothing' if
- -- this is the initial/bootstrapping update.
- --
- -- Must return 'Nothing' if no change,
- -- otherwise returrn 'Just' of the new state.
-
- -> [node] -- Nodes that should initially be updated
-
- -> s -- Initial state
- -- (usually a map from node to
- -- the value for that node)
-
- -> s -- Final state
-fixedpoint dependants update nodes state =
- foldr (fixedpoint' Nothing) state nodes where
- -- Use a depth first traversal of nodes based on the update graph.
- -- Terminate the traversal when the update doesn't change anything.
- fixedpoint' cause node state =
- case update node cause state of
- Nothing -> state
- Just state' ->
- foldr (fixedpoint' (Just node)) state' (dependants node)
--- /dev/null
+{-# LANGUAGE GADTs #-}
+{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-}
+-- ToDo: remove
+{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
+
+-- Module for building CmmAGraphs.
+
+-- As the CmmAGraph is a wrapper over Graph CmmNode O x, it is different
+-- from Hoopl's AGraph. The current clients expect functions with the
+-- same names Hoopl uses, so this module cannot be in the same namespace
+-- as Compiler.Hoopl.
+
+module MkGraph
+ ( CmmAGraph
+ , emptyAGraph, (<*>), catAGraphs, outOfLine
+ , mkLabel, mkMiddle, mkLast
+ , withFreshLabel, withUnique, lgraphOfAGraph, labelAGraph
+
+ , stackStubExpr
+ , mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
+ , mkJump, mkDirectJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch
+ , mkReturn, mkReturnSimple, mkComment, mkCallEntry
+ , mkBranch, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
+ , copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
+ -- Reexport of needed Cmm stuff
+ , Convention(..), ForeignConvention(..), ForeignTarget(..)
+ , CmmStackInfo(..), CmmTopInfo(..), CmmGraph(..)
+ , Cmm, CmmTop
+ )
+where
+
+import BlockId
+import Cmm
+import CmmDecl
+import CmmExpr
+import CmmCallConv (assignArgumentsPos, ParamLocation(..))
+
+import Compiler.Hoopl hiding (Unique, (<*>), mkFirst, mkMiddle, mkLast, mkLabel, mkBranch, Shape(..))
+import qualified Compiler.Hoopl as H
+import Compiler.Hoopl.GHC (uniqueToLbl)
+import FastString
+import ForeignCall
+import Outputable
+import Prelude hiding (succ)
+import SMRep (ByteOff)
+import StaticFlags
+import Unique
+import UniqSupply
+
+#include "HsVersions.h"
+
+{-
+A 'CmmAGraph' is an abstract version of a 'Graph CmmNode O x' from module
+'Cmm'. The difference is that the 'CmmAGraph' can be eigher open of closed at
+exit and it can supply fresh Labels and Uniques.
+
+It also supports a splicing operation <*>, which is different from the Hoopl's
+<*>, because it splices two CmmAGraphs. Specifically, it can splice Graph
+O C and Graph O x. In this case, the open beginning of the second graph is
+thrown away. In the debug mode this sequence is checked to be empty or
+containing a branch (see note [Branch follows branch]).
+
+When an CmmAGraph open at exit is being converted to a CmmGraph, the output
+exit sequence is considered unreachable. If the graph consist of one block
+only, if it not the case and we crash. Otherwise we just throw the exit
+sequence away (and in debug mode we test that it really was unreachable).
+-}
+
+{-
+Node [Branch follows branch]
+============================
+Why do we say it's ok for a Branch to follow a Branch?
+Because the standard constructor mkLabel has fall-through
+semantics. So if you do a mkLabel, you finish the current block,
+giving it a label, and start a new one that branches to that label.
+Emitting a Branch at this point is fine:
+ goto L1; L2: ...stuff...
+-}
+
+data CmmGraphOC = Opened (Graph CmmNode O O)
+ | Closed (Graph CmmNode O C)
+type CmmAGraph = UniqSM CmmGraphOC -- Graph open at entry
+
+{-
+MS: I began with
+ newtype CmmAGraph = forall x. AG (UniqSM (Graph CmmNode O x))
+but that does not work well, because we cannot take the graph
+out of the monad -- we do not know the type of what we would take
+out and pattern matching does not help, as we cannot pattern match
+on a graph inside the monad.
+-}
+
+data Transfer = Call | Jump | Ret deriving Eq
+
+---------- AGraph manipulation
+
+emptyAGraph :: CmmAGraph
+(<*>) :: CmmAGraph -> CmmAGraph -> CmmAGraph
+catAGraphs :: [CmmAGraph] -> CmmAGraph
+
+mkLabel :: BlockId -> CmmAGraph -- created a sequence "goto id; id:" as an AGraph
+mkMiddle :: CmmNode O O -> CmmAGraph -- creates an open AGraph from a given node
+mkLast :: CmmNode O C -> CmmAGraph -- created a closed AGraph from a given node
+
+withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
+withUnique :: (Unique -> CmmAGraph) -> CmmAGraph
+
+lgraphOfAGraph :: CmmAGraph -> UniqSM CmmGraph
+ -- ^ allocate a fresh label for the entry point
+labelAGraph :: BlockId -> CmmAGraph -> UniqSM CmmGraph
+ -- ^ use the given BlockId as the label of the entry point
+
+---------- No-ops
+mkNop :: CmmAGraph
+mkComment :: FastString -> CmmAGraph
+
+---------- Assignment and store
+mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
+mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
+
+---------- Calls
+mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
+ UpdFrameOffset -> CmmAGraph
+mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
+ UpdFrameOffset -> CmmAGraph
+ -- Native C-- calling convention
+mkSafeCall :: ForeignTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
+mkUnsafeCall :: ForeignTarget -> CmmFormals -> CmmActuals -> CmmAGraph
+mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+ -- Never returns; like exit() or barf()
+
+---------- Control transfer
+mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkDirectJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
+mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
+mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph
+
+mkBranch :: BlockId -> CmmAGraph
+mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
+mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
+mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
+
+outOfLine :: CmmAGraph -> CmmAGraph
+-- ^ The argument is an CmmAGraph that must have an
+-- empty entry sequence and be closed at the end.
+-- The result is a new CmmAGraph that is open at the
+-- end and goes directly from entry to exit, with the
+-- original graph sitting to the side out-of-line.
+--
+-- Example: mkMiddle (x = 3)
+-- <*> outOfLine (mkLabel L <*> ...stuff...)
+-- <*> mkMiddle (y = x)
+-- Control will flow directly from x=3 to y=x;
+-- the block starting with L is "on the side".
+--
+-- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
+
+--------------------------------------------------------------------------
+
+-- ================ IMPLEMENTATION ================--
+
+--------------------------------------------------
+-- Raw CmmAGraph handling
+
+emptyAGraph = return $ Opened emptyGraph
+ag <*> ah = do g <- ag
+ h <- ah
+ return (case (g, h) of
+ (Opened g, Opened h) -> Opened $ g H.<*> h
+ (Opened g, Closed h) -> Closed $ g H.<*> h
+ (Closed g, Opened GNil) -> Closed g
+ (Closed g, Opened (GUnit e)) -> note_unreachable e $ Closed g
+ (Closed g, Opened (GMany (JustO e) b x)) -> note_unreachable e $ Opened $ g H.|*><*| GMany NothingO b x
+ (Closed g, Closed (GMany (JustO e) b x)) -> note_unreachable e $ Closed $ g H.|*><*| GMany NothingO b x
+ :: CmmGraphOC)
+catAGraphs = foldl (<*>) emptyAGraph
+
+outOfLine ag = withFreshLabel "outOfLine" $ \l ->
+ do g <- ag
+ return (case g of
+ Closed (GMany (JustO e) b _) -> note_unreachable e $ Opened $
+ GMany (JustO $ BLast $ CmmBranch l) b (JustO $ BFirst $ CmmEntry l)
+ _ -> panic "outOfLine"
+ :: CmmGraphOC)
+
+note_unreachable :: Block CmmNode O x -> a -> a
+note_unreachable block graph =
+ ASSERT (block_is_empty_or_label) -- Note [Branch follows branch]
+ graph
+ where block_is_empty_or_label :: Bool
+ block_is_empty_or_label = case blockToNodeList block of
+ (NothingC, [], NothingC) -> True
+ (NothingC, [], JustC (CmmBranch _)) -> True
+ _ -> False
+
+mkLabel bid = return $ Opened $ H.mkLast (CmmBranch bid) |*><*| H.mkFirst (CmmEntry bid)
+mkMiddle middle = return $ Opened $ H.mkMiddle middle
+mkLast last = return $ Closed $ H.mkLast last
+
+withUnique f = getUniqueM >>= f
+withFreshLabel _name f = getUniqueM >>= f . uniqueToLbl . intToUnique . getKey
+
+lgraphOfAGraph g = do u <- getUniqueM
+ labelAGraph (mkBlockId u) g
+
+labelAGraph lbl ag = do g <- ag
+ return $ CmmGraph {g_entry=lbl, g_graph=H.mkFirst (CmmEntry lbl) H.<*> closed g}
+ where closed :: CmmGraphOC -> Graph CmmNode O C
+ closed (Closed g) = g
+ closed (Opened g@(GMany entry body (JustO exit))) =
+ ASSERT (entryLabel exit `notElem` map entryLabel (postorder_dfs g))
+ GMany entry body NothingO
+ closed (Opened _) = panic "labelAGraph"
+
+--------------------------------------------------
+-- CmmAGraph constructions
+
+mkNop = emptyAGraph
+mkComment fs = mkMiddle $ CmmComment fs
+mkStore l r = mkMiddle $ CmmStore l r
+
+-- NEED A COMPILER-DEBUGGING FLAG HERE
+-- Sanity check: any value assigned to a pointer must be non-zero.
+-- If it's 0, cause a crash immediately.
+mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
+ where assign l r = mkMiddle (CmmAssign l r)
+ check (CmmGlobal _) = mkNop
+ check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
+ if isGcPtrType ty then
+ mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
+ (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
+ else mkNop
+ where ty = localRegType reg
+ w = typeWidth ty
+ r = CmmReg l
+
+
+-- Why are we inserting extra blocks that simply branch to the successors?
+-- Because in addition to the branch instruction, @mkBranch@ will insert
+-- a necessary adjustment to the stack pointer.
+mkCbranch pred ifso ifnot = mkLast (CmmCondBranch pred ifso ifnot)
+mkSwitch e tbl = mkLast $ CmmSwitch e tbl
+
+mkSafeCall t fs as upd i = withFreshLabel "safe call" $ body
+ where
+ body k =
+ ( mkStore (CmmStackSlot (CallArea (Young k)) (widthInBytes wordWidth))
+ (CmmLit (CmmBlock k))
+ <*> mkLast (CmmForeignCall {tgt=t, res=fs, args=as, succ=k, updfr=upd, intrbl=i})
+ <*> mkLabel k)
+mkUnsafeCall t fs as = mkMiddle $ CmmUnsafeForeignCall t fs as
+
+mkBranch bid = mkLast (CmmBranch bid)
+
+mkCmmIfThenElse e tbranch fbranch =
+ withFreshLabel "end of if" $ \endif ->
+ withFreshLabel "start of then" $ \tid ->
+ withFreshLabel "start of else" $ \fid ->
+ mkCbranch e tid fid <*>
+ mkLabel tid <*> tbranch <*> mkBranch endif <*>
+ mkLabel fid <*> fbranch <*> mkLabel endif
+
+mkCmmIfThen e tbranch
+ = withFreshLabel "end of if" $ \endif ->
+ withFreshLabel "start of then" $ \tid ->
+ mkCbranch e tid endif <*>
+ mkLabel tid <*> tbranch <*> mkLabel endif
+
+mkCmmWhileDo e body =
+ withFreshLabel "loop test" $ \test ->
+ withFreshLabel "loop head" $ \head ->
+ withFreshLabel "end while" $ \endwhile ->
+ -- Forrest Baskett's while-loop layout
+ mkBranch test <*> mkLabel head <*> body
+ <*> mkLabel test <*> mkCbranch e head endwhile
+ <*> mkLabel endwhile
+
+-- For debugging purposes, we can stub out dead stack slots:
+stackStubExpr :: Width -> CmmExpr
+stackStubExpr w = CmmLit (CmmInt 0 w)
+
+-- When we copy in parameters, we usually want to put overflow
+-- parameters on the stack, but sometimes we want to pass
+-- the variables in their spill slots.
+-- Therefore, for copying arguments and results, we provide different
+-- functions to pass the arguments in an overflow area and to pass them in spill slots.
+copyInOflow :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
+copyInSlot :: Convention -> CmmFormals -> [CmmNode O O]
+copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
+ (Int, CmmAGraph)
+copyOutSlot :: Convention -> [LocalReg] -> [CmmNode O O]
+
+copyInOflow conv area formals = (offset, catAGraphs $ map mkMiddle nodes)
+ where (offset, nodes) = copyIn oneCopyOflowI conv area formals
+copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
+
+type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, [CmmNode O O]) ->
+ (ByteOff, [CmmNode O O])
+type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, [CmmNode O O])
+
+-- Return the number of bytes used for copying arguments, as well as the
+-- instructions to copy the arguments.
+copyIn :: CopyIn
+copyIn oflow conv area formals =
+ foldr ci (init_offset, []) args'
+ where ci (reg, RegisterParam r) (n, ms) =
+ (n, CmmAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms)
+ ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
+ init_offset = widthInBytes wordWidth -- infotable
+ args = assignArgumentsPos conv localRegType formals
+ args' = foldl adjust [] args
+ where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
+ adjust rst x@(_, RegisterParam _) = x : rst
+
+-- Copy-in one arg, using overflow space if needed.
+oneCopyOflowI, oneCopySlotI :: SlotCopier
+oneCopyOflowI area (reg, off) (n, ms) =
+ (max n off, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) : ms)
+ where ty = localRegType reg
+
+-- Copy-in one arg, using spill slots if needed -- used for calling conventions at
+-- a procpoint that is not a return point. The offset is irrelevant here...
+oneCopySlotI _ (reg, _) (n, ms) =
+ (n, CmmAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) : ms)
+ where ty = localRegType reg
+ w = widthInBytes (typeWidth ty)
+
+
+-- Factoring out the common parts of the copyout functions yielded something
+-- more complicated:
+
+-- The argument layout function ignores the pointer to the info table, so we slot that
+-- in here. When copying-out to a young area, we set the info table for return
+-- and adjust the offsets of the other parameters.
+-- If this is a call instruction, we adjust the offsets of the other parameters.
+copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
+ foldr co (init_offset, emptyAGraph) args'
+ where co (v, RegisterParam r) (n, ms) = (n, mkAssign (CmmGlobal r) v <*> ms)
+ co (v, StackParam off) (n, ms) =
+ (max n off, mkStore (CmmStackSlot area off) v <*> ms)
+ (setRA, init_offset) =
+ case a of Young id -> id `seq` -- set RA if making a call
+ if transfer == Call then
+ ([(CmmLit (CmmBlock id), StackParam init_offset)],
+ widthInBytes wordWidth)
+ else ([], 0)
+ Old -> ([], updfr_off)
+ args = assignArgumentsPos conv cmmExprType actuals
+ args' = foldl adjust setRA args
+ where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
+ adjust rst x@(_, RegisterParam _) = x : rst
+copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
+
+-- Args passed only in registers and stack slots; no overflow space.
+-- No return address may apply!
+copyOutSlot conv actuals = foldr co [] args
+ where co (v, RegisterParam r) ms = CmmAssign (CmmGlobal r) (toExp v) : ms
+ co (v, StackParam off) ms = CmmStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
+ toExp r = CmmReg (CmmLocal r)
+ args = assignArgumentsPos conv localRegType actuals
+
+mkCallEntry :: Convention -> CmmFormals -> (Int, CmmAGraph)
+mkCallEntry conv formals = copyInOflow conv (CallArea Old) formals
+
+lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
+ (ByteOff -> CmmAGraph) -> CmmAGraph
+lastWithArgs transfer area conv actuals updfr_off last =
+ let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
+ copies <*> last outArgs
+
+-- The area created for the jump and return arguments is the same area as the
+-- procedure entry.
+old :: Area
+old = CallArea Old
+toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> CmmAGraph
+toCall e cont updfr_off res_space arg_space =
+ mkLast $ CmmCall e cont arg_space res_space updfr_off
+mkJump e actuals updfr_off =
+ lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
+mkDirectJump e actuals updfr_off =
+ lastWithArgs Jump old NativeDirectCall actuals updfr_off $ toCall e Nothing updfr_off 0
+mkJumpGC e actuals updfr_off =
+ lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
+mkForeignJump conv e actuals updfr_off =
+ lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
+mkReturn e actuals updfr_off =
+ lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
+ -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
+mkReturnSimple actuals updfr_off =
+ lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
+ where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
+
+mkFinalCall f _ actuals updfr_off =
+ lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
+
+mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
+
+-- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
+mkCall f (callConv, retConv) results actuals updfr_off =
+ withFreshLabel "call successor" $ \k ->
+ let area = CallArea $ Young k
+ (off, copyin) = copyInOflow retConv area results
+ copyout = lastWithArgs Call area callConv actuals updfr_off
+ (toCall f (Just k) updfr_off off)
+ in (copyout <*> mkLabel k <*> copyin)
+++ /dev/null
-{-# LANGUAGE ScopedTypeVariables #-}
-module MkZipCfg
- ( AGraph, (<*>), catAGraphs
- , freshBlockId
- , emptyAGraph, withFreshLabel, withUnique
- , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo
- , outOfLine
- , emptyGraph, graphOfMiddles, graphOfZTail
- , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph
- )
-where
-
-import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv)
-import ZipCfg
-
-import Outputable
-import Unique
-import UniqSupply
-import Util
-
-import Prelude hiding (zip, unzip, last)
-
-#include "HsVersions.h"
-
--------------------------------------------------------------------------
--- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH (CONSTRUCTOR VIEW) --
--------------------------------------------------------------------------
-
-{-
-
-You can think of an AGraph like this: it is the program built by
-composing in sequence three kinds of nodes:
- * Label nodes (e.g. L2:)
- * Middle nodes (e.g. x = y*3)
- * Last nodes (e.g. if b then goto L1 else goto L2)
-
-The constructors mkLabel, mkMiddle, and mkLast build single-node
-AGraphs of the indicated type. The composition operator <*> glues
-AGraphs together in sequence (in constant time).
-
-For example:
- x = 0
- L1:
- x = x+1
- if x<10 then goto L1 else goto L2
- L2:
- y = y*x
- x = 0
-
-Notice that the AGraph may begin without a label, and may end without
-a control transfer. Control *always* falls through a label and middle
-node, and *never* falls through a Last node.
-
-A 'AGraph m l' is simply an abstract version of a 'Graph m l' from
-module 'ZipCfg'. The only difference is that the 'AGraph m l'
-supports a constant-time splicing operation, written infix <*>.
-That splicing operation, together with the constructor functions in
-this module (and with 'labelAGraph'), is the recommended way to build
-large graphs. Each construction or splice has constant cost, and to
-turn an AGraph into a Graph requires time linear in the number of
-nodes and N log N in the number of basic blocks.
-
-The splicing operation warrants careful explanation. Like a Graph, an
-AGraph is a control-flow graph which begins with a distinguished,
-unlabelled sequence of middle nodes called the *entry*. An unlabelled
-graph may also end with a sequence of middle nodes called the *exit*.
-The entry may fall straight through to the exit, or it may fall into
-the rest of the graph, which may include arbitrary control flow.
-
-Using ASCII art, here are examples of the two kinds of graph. On the
-left, the entry and exit sequences are labelled A and B, where the
-control flow in the middle is labelled X. On the right, there is no
-exit sequence:
-
- | |
- | A | C
- | |
- / \ / \
- / \ / \
- | X | | Y |
- \ / \ /
- \ / \_/
- |
- | B
- |
-
-
-The AGraph has these properties:
-
- * A AGraph is opaque; nothing about its structure can be observed.
-
- * A AGraph may be turned into a LGraph in time linear in the number
- of nodes and O(N log N) in the number of basic blocks.
-
- * Two AGraphs may be spliced in constant time by writing g1 <*> g2
-
-There are two rules for splicing, depending on whether the left-hand
-graph falls through. If it does, the rule is as follows:
-
- | | |
- | A | C | A
- | | |
- / \ / \ / \
- / \ / \ / \
- | X | <*> | Y | = | X |
- \ / \ / \ /
- \ / \_/ \ /
- | | |
- | B | D | B
- | | |
- |
- | C
- |
- / \
- / \
- | Y |
- \ /
- \ /
- |
- | D
- |
-
-And in the case where the left-hand graph does not fall through, the
-rule is
-
-
- | | |
- | A | C | A
- | | |
- / \ / \ / \
- / \ / \ / \
- | X | <*> | Y | = | X |
- \ / \ / \ /
- \_/ \_/ \_/
- |
- | D _
- | / \
- / \
- | Y |
- \ /
- \ /
- |
- | D
- |
-
-In this case C will become unreachable and is lost; when such a graph
-is converted into a data structure, the system will bleat about
-unreachable code. Also it must be assumed that there are branches
-from somewhere in X to labelled blocks in Y; otherwise Y and D are
-unreachable as well. (However, it may be the case that X branches
-into some third AGraph, which in turn branches into D; the
-representation is agnostic on this point.)
-
--}
-
-infixr 3 <*>
-(<*>) :: AGraph m l -> AGraph m l -> AGraph m l
-
-catAGraphs :: [AGraph m l] -> AGraph m l
-
--- | A graph is built up by splicing together graphs each containing a
--- single node (where a label is considered a 'first' node. The empty
--- graph is a left and right unit for splicing. All of the AGraph
--- constructors (even complex ones like 'mkIfThenElse', as well as the
--- splicing operation <*>, are constant-time operations.
-
-emptyAGraph :: AGraph m l
-mkLabel :: (LastNode l) => BlockId -> AGraph m l -- graph contains the label
-mkMiddle :: m -> AGraph m l -- graph contains the node
-mkLast :: (Outputable m, Outputable l, LastNode l) =>
- l -> AGraph m l -- graph contains the node
-
--- | This function provides access to fresh labels without requiring
--- clients to be programmed monadically.
-withFreshLabel :: String -> (BlockId -> AGraph m l) -> AGraph m l
-withUnique :: (Unique -> AGraph m l) -> AGraph m l
-
-
-outOfLine :: (LastNode l, Outputable m, Outputable l)
- => AGraph m l -> AGraph m l
--- ^ The argument is an AGraph that has an
--- empty entry sequence and no exit sequence.
--- The result is a new AGraph that has an empty entry sequence
--- connected to an empty exit sequence, with the original graph
--- sitting to the side out-of-line.
---
--- Example: mkMiddle (x = 3)
--- <*> outOfLine (mkLabel L <*> ...stuff...)
--- <*> mkMiddle (y = x)
--- Control will flow directly from x=3 to y=x;
--- the block starting with L is "on the side".
---
--- N.B. algebraically forall g g' : g <*> outOfLine g' == outOfLine g' <*> g
-
-
-
--- below for convenience
-mkMiddles :: [m] -> AGraph m l
-mkZTail :: (Outputable m, Outputable l, LastNode l) =>
- ZTail m l -> AGraph m l
-mkBranch :: (Outputable m, Outputable l, LastNode l) =>
- BlockId -> AGraph m l
-
--- | For the structured control-flow constructs, a condition is
--- represented as a function that takes as arguments the labels to
--- goto on truth or falsehood.
---
--- mkIfThenElse mk_cond then else
--- = (mk_cond L1 L2) <*> L1: then <*> goto J
--- <*> L2: else <*> goto J
--- <*> J:
---
--- where L1, L2, J are fresh
-
-mkIfThenElse :: (Outputable m, Outputable l, LastNode l)
- => (BlockId -> BlockId -> AGraph m l) -- branch condition
- -> AGraph m l -- code in the 'then' branch
- -> AGraph m l -- code in the 'else' branch
- -> AGraph m l -- resulting if-then-else construct
-
-mkWhileDo :: (Outputable m, Outputable l, LastNode l)
- => (BlockId -> BlockId -> AGraph m l) -- loop condition
- -> AGraph m l -- body of the bloop
- -> AGraph m l -- the final while loop
-
--- | Converting an abstract graph to a concrete form is expensive: the
--- cost is linear in the number of nodes in the answer, plus N log N
--- in the number of basic blocks. The conversion is also monadic
--- because it may require the allocation of fresh, unique labels.
-
-graphOfAGraph :: AGraph m l -> UniqSM (Graph m l)
-lgraphOfAGraph :: AGraph m l -> UniqSM (LGraph m l)
- -- ^ allocate a fresh label for the entry point
-labelAGraph :: BlockId -> AGraph m l -> UniqSM (LGraph m l)
- -- ^ use the given BlockId as the label of the entry point
-
-
--- | The functions below build Graphs directly; for convenience, they
--- are included here with the rest of the constructor functions.
-
-emptyGraph :: Graph m l
-graphOfMiddles :: [m] -> Graph m l
-graphOfZTail :: ZTail m l -> Graph m l
-
-
--- ================================================================
--- IMPLEMENTATION
--- ================================================================
-
-newtype AGraph m l = AGraph (Graph m l -> UniqSM (Graph m l))
- -- an AGraph is a monadic function from a successor Graph to a new Graph
-
-AGraph f1 <*> AGraph f2 = AGraph f
- where f g = f2 g >>= f1 -- note right associativity
-
-catAGraphs = foldr (<*>) emptyAGraph
-
-emptyAGraph = AGraph return
-
-graphOfAGraph (AGraph f) = f emptyGraph
-emptyGraph = Graph (ZLast LastExit) emptyBlockEnv
-
-labelAGraph id g =
- do Graph tail blocks <- graphOfAGraph g
- return $ LGraph id $ insertBlock (Block id tail) blocks
-
-lgraphOfAGraph g = do id <- freshBlockId "graph entry"
- labelAGraph id g
-
--------------------------------------
--- constructors
-
-mkLabel id = AGraph f
- where f (Graph tail blocks) =
- return $ Graph (ZLast (mkBranchNode id))
- (insertBlock (Block id tail) blocks)
-
-mkBranch target = mkLast $ mkBranchNode target
-
-mkMiddle m = AGraph f
- where f (Graph tail blocks) = return $ Graph (ZTail m tail) blocks
-
-mkMiddles ms = AGraph f
- where f (Graph tail blocks) = return $ Graph (foldr ZTail tail ms) blocks
-
-graphOfMiddles ms = Graph (foldr ZTail (ZLast LastExit) ms) emptyBlockEnv
-graphOfZTail t = Graph t emptyBlockEnv
-
-
-mkLast l = AGraph f
- where f (Graph tail blocks) =
- do note_this_code_becomes_unreachable "mkLast" (ppr l <+> ppr blocks) tail
- return $ Graph (ZLast (LastOther l)) blocks
-
-mkZTail tail = AGraph f
- where f (Graph utail blocks) =
- do note_this_code_becomes_unreachable "mkZTail" (ppr tail) utail
- return $ Graph tail blocks
-
-withFreshLabel name ofId = AGraph f
- where f g = do id <- freshBlockId name
- let AGraph f' = ofId id
- f' g
-
-withUnique ofU = AGraph f
- where f g = do u <- getUniqueM
- let AGraph f' = ofU u
- f' g
-
-outOfLine (AGraph f) = AGraph f'
- where f' (Graph tail' blocks') =
- do Graph emptyEntrance blocks <- f emptyGraph
- note_this_code_becomes_unreachable "outOfLine" (ppr tail') emptyEntrance
- return $ Graph tail' (blocks `plusBlockEnv` blocks')
-
-mkIfThenElse cbranch tbranch fbranch =
- withFreshLabel "end of if" $ \endif ->
- withFreshLabel "start of then" $ \tid ->
- withFreshLabel "start of else" $ \fid ->
- cbranch tid fid <*>
- mkLabel tid <*> tbranch <*> mkBranch endif <*>
- mkLabel fid <*> fbranch <*>
- mkLabel endif
-
-mkWhileDo cbranch body =
- withFreshLabel "loop test" $ \test ->
- withFreshLabel "loop head" $ \head ->
- withFreshLabel "end while" $ \endwhile ->
- -- Forrest Baskett's while-loop layout
- mkBranch test <*> mkLabel head <*> body
- <*> mkLabel test <*> cbranch head endwhile
- <*> mkLabel endwhile
-
--- | Bleat if the insertion of a last node will create unreachable code
-note_this_code_becomes_unreachable ::
- (Monad m, LastNode l, Outputable middle, Outputable l) =>
- String -> SDoc -> ZTail middle l -> m ()
-
-note_this_code_becomes_unreachable str old = if debugIsOn then u else \_ -> return ()
- where u (ZLast LastExit) = return ()
- u (ZLast (LastOther l)) | isBranchNode l = return ()
- -- Note [Branch follows branch]
- u tail = fail ("unreachable code in " ++ str ++ ": " ++
- (showSDoc ((ppr tail) <+> old)))
-
--- | The string argument to 'freshBlockId' was originally helpful in debugging
--- the Quick C-- compiler, so I have kept it here even though at present it is
--- thrown away at this spot---there's no reason a BlockId couldn't one day carry
--- a string.
-
-freshBlockId :: MonadUnique m => String -> m BlockId
-freshBlockId _s = getUniqueM >>= return . BlockId
-
--------------------------------------
--- Debugging
-
-pprAGraph :: (Outputable m, LastNode l, Outputable l) => AGraph m l -> UniqSM SDoc
-pprAGraph g = graphOfAGraph g >>= return . ppr
-
-{-
-Note [Branch follows branch]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-Why do we say it's ok for a Branch to follow a Branch?
-Because the standard constructor mkLabel-- has fall-through
-semantics. So if you do a mkLabel, you finish the current block,
-giving it a label, and start a new one that branches to that label.
-Emitting a Branch at this point is fine:
- goto L1; L2: ...stuff...
--}
-
-
+++ /dev/null
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-
--- This is the module to import to be able to build C-- programs.
--- It should not be necessary to import MkZipCfg or ZipCfgCmmRep.
--- If you find it necessary to import these other modules, please
--- complain to Norman Ramsey.
-
-module MkZipCfgCmm
- ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall
- , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn
- , mkReturnSimple, mkComment, copyInOflow, copyInSlot, copyOutOflow, copyOutSlot
- , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo
- , (<*>), catAGraphs, mkLabel, mkBranch
- , emptyAGraph, withFreshLabel, withUnique, outOfLine
- , lgraphOfAGraph, graphOfAGraph, labelAGraph
- , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph, CmmStackInfo
- , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..)
- , stackStubExpr, pprAGraph
- )
-where
-
-#include "HsVersions.h"
-
-import BlockId
-import CmmExpr
-import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
- , CmmActuals, CmmFormals
- )
-import CmmCallConv (assignArgumentsPos, ParamLocation(..))
-import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ)
- -- to make this module more self-contained, the above definitions are
- -- duplicated below
-import PprCmm()
-
-import FastString
-import ForeignCall
-import MkZipCfg
-import Panic
-import SMRep (ByteOff)
-import StaticFlags
-import ZipCfg
-
-type CmmGraph = LGraph Middle Last
-type CmmAGraph = AGraph Middle Last
-type CmmBlock = Block Middle Last
-type CmmStackInfo = (ByteOff, Maybe ByteOff)
- -- probably want a record; (SP offset on entry, update frame space)
-type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
-type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
-
-data Transfer = Call | Jump | Ret deriving Eq
-
----------- No-ops
-mkNop :: CmmAGraph
-mkComment :: FastString -> CmmAGraph
-
----------- Assignment and store
-mkAssign :: CmmReg -> CmmExpr -> CmmAGraph
-mkStore :: CmmExpr -> CmmExpr -> CmmAGraph
-
----------- Calls
-mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ->
- UpdFrameOffset -> CmmAGraph
-mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
- UpdFrameOffset -> CmmAGraph
- -- Native C-- calling convention
-mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
-mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
-mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
- -- Never returns; like exit() or barf()
-
----------- Control transfer
-mkJump :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
-mkJumpGC :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
-mkForeignJump :: Convention -> CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
-mkCbranch :: CmmExpr -> BlockId -> BlockId -> CmmAGraph
-mkSwitch :: CmmExpr -> [Maybe BlockId] -> CmmAGraph
-mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph
-mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph
-
-mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph
-mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph
-mkCmmWhileDo :: CmmExpr -> CmmAGraph -> CmmAGraph
-
--- Not to be forgotten, but exported by MkZipCfg:
--- mkBranch :: BlockId -> CmmAGraph
--- mkLabel :: BlockId -> Maybe Int -> CmmAGraph
--- outOfLine :: CmmAGraph -> CmmAGraph
--- withUnique :: (Unique -> CmmAGraph) -> CmmAGraph
--- withFreshLabel :: String -> (BlockId -> CmmAGraph) -> CmmAGraph
-
---------------------------------------------------------------------------
-
-mkCmmWhileDo e = mkWhileDo (mkCbranch e)
-mkCmmIfThenElse e = mkIfThenElse (mkCbranch e)
-
-mkCmmIfThen e tbranch
- = withFreshLabel "end of if" $ \endif ->
- withFreshLabel "start of then" $ \tid ->
- mkCbranch e tid endif <*>
- mkLabel tid <*> tbranch <*> mkBranch endif <*>
- mkLabel endif
-
-
-
--- ================ IMPLEMENTATION ================--
-
-mkNop = emptyAGraph
-mkComment fs = mkMiddle $ MidComment fs
-mkStore l r = mkMiddle $ MidStore l r
-
--- NEED A COMPILER-DEBUGGING FLAG HERE
--- Sanity check: any value assigned to a pointer must be non-zero.
--- If it's 0, cause a crash immediately.
-mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
- where assign l r = mkMiddle (MidAssign l r)
- check (CmmGlobal _) = mkNop
- check l@(CmmLocal reg) = -- if a ptr arg is NULL, cause a crash!
- if isGcPtrType ty then
- mkCmmIfThen (CmmMachOp (MO_Eq w) [r, stackStubExpr w])
- (assign l (CmmLoad (CmmLit (CmmInt 0 w)) ty))
- else mkNop
- where ty = localRegType reg
- w = typeWidth ty
- r = CmmReg l
-
-
--- Why are we inserting extra blocks that simply branch to the successors?
--- Because in addition to the branch instruction, @mkBranch@ will insert
--- a necessary adjustment to the stack pointer.
-mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
-mkSwitch e tbl = mkLast $ LastSwitch e tbl
-
-mkSafeCall t fs as upd interruptible =
- withFreshLabel "safe call" $ \k ->
- mkMiddle $ MidForeignCall (Safe k upd interruptible) t fs as
-mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
-
--- For debugging purposes, we can stub out dead stack slots:
-stackStubExpr :: Width -> CmmExpr
-stackStubExpr w = CmmLit (CmmInt 0 w)
-
--- When we copy in parameters, we usually want to put overflow
--- parameters on the stack, but sometimes we want to pass
--- the variables in their spill slots.
--- Therefore, for copying arguments and results, we provide different
--- functions to pass the arguments in an overflow area and to pass them in spill slots.
-copyInOflow :: Convention -> Area -> CmmFormals -> (Int, CmmAGraph)
-copyInSlot :: Convention -> CmmFormals -> CmmAGraph
-copyOutOflow :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset ->
- (Int, [Middle])
-copyOutSlot :: Convention -> [LocalReg] -> [Middle]
- -- why a list of middles here instead of an AGraph?
-
-copyInOflow = copyIn oneCopyOflowI
-copyInSlot c f = snd $ copyIn oneCopySlotI c (panic "no area for copying to slots") f
-
-type SlotCopier = Area -> (LocalReg, ByteOff) -> (ByteOff, CmmAGraph) ->
- (ByteOff, CmmAGraph)
-type CopyIn = SlotCopier -> Convention -> Area -> CmmFormals -> (ByteOff, CmmAGraph)
-
--- Return the number of bytes used for copying arguments, as well as the
--- instructions to copy the arguments.
-copyIn :: CopyIn
-copyIn oflow conv area formals =
- foldr ci (init_offset, mkNop) args'
- where ci (reg, RegisterParam r) (n, ms) =
- (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms)
- ci (r, StackParam off) (n, ms) = oflow area (r, off) (n, ms)
- init_offset = widthInBytes wordWidth -- infotable
- args = assignArgumentsPos conv localRegType formals
- args' = foldl adjust [] args
- where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
- adjust rst x@(_, RegisterParam _) = x : rst
-
--- Copy-in one arg, using overflow space if needed.
-oneCopyOflowI, oneCopySlotI :: SlotCopier
-oneCopyOflowI area (reg, off) (n, ms) =
- (max n off, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off) ty) <*> ms)
- where ty = localRegType reg
-
--- Copy-in one arg, using spill slots if needed -- used for calling conventions at
--- a procpoint that is not a return point. The offset is irrelevant here...
-oneCopySlotI _ (reg, _) (n, ms) =
- (n, mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot (RegSlot reg) w) ty) <*> ms)
- where ty = localRegType reg
- w = widthInBytes (typeWidth ty)
-
-
--- Factoring out the common parts of the copyout functions yielded something
--- more complicated:
-
--- The argument layout function ignores the pointer to the info table, so we slot that
--- in here. When copying-out to a young area, we set the info table for return
--- and adjust the offsets of the other parameters.
--- If this is a call instruction, we adjust the offsets of the other parameters.
-copyOutOflow conv transfer area@(CallArea a) actuals updfr_off =
- foldr co (init_offset, []) args'
- where co (v, RegisterParam r) (n, ms) = (n, MidAssign (CmmGlobal r) v : ms)
- co (v, StackParam off) (n, ms) =
- (max n off, MidStore (CmmStackSlot area off) v : ms)
- (setRA, init_offset) =
- case a of Young id@(BlockId _) -> -- set RA if making a call
- if transfer == Call then
- ([(CmmLit (CmmBlock id), StackParam init_offset)],
- widthInBytes wordWidth)
- else ([], 0)
- Old -> ([], updfr_off)
- args = assignArgumentsPos conv cmmExprType actuals
- args' = foldl adjust setRA args
- where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst
- adjust rst x@(_, RegisterParam _) = x : rst
-copyOutOflow _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot"
-
--- Args passed only in registers and stack slots; no overflow space.
--- No return address may apply!
-copyOutSlot conv actuals = foldr co [] args
- where co (v, RegisterParam r) ms = MidAssign (CmmGlobal r) (toExp v) : ms
- co (v, StackParam off) ms =
- MidStore (CmmStackSlot (RegSlot v) off) (toExp v) : ms
- toExp r = CmmReg (CmmLocal r)
- args = assignArgumentsPos conv localRegType actuals
-
--- oneCopySlotO _ (reg, _) (n, ms) =
--- (n, MidStore (CmmStackSlot (RegSlot reg) w) reg : ms)
--- where w = widthInBytes (typeWidth (localRegType reg))
-
-mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph)
-mkEntry _ conv formals = copyInOflow conv (CallArea Old) formals
-
-lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset ->
- (ByteOff -> Last) -> CmmAGraph
-lastWithArgs transfer area conv actuals updfr_off last =
- let (outArgs, copies) = copyOutOflow conv transfer area actuals updfr_off in
- mkMiddles copies <*> mkLast (last outArgs)
-
--- The area created for the jump and return arguments is the same area as the
--- procedure entry.
-old :: Area
-old = CallArea Old
-toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> ByteOff -> ByteOff -> Last
-toCall e cont updfr_off res_space arg_space =
- LastCall e cont arg_space res_space (Just updfr_off)
-mkJump e actuals updfr_off =
- lastWithArgs Jump old NativeNodeCall actuals updfr_off $ toCall e Nothing updfr_off 0
-mkJumpGC e actuals updfr_off =
- lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off 0
-mkForeignJump conv e actuals updfr_off =
- lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off 0
-mkReturn e actuals updfr_off =
- lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
- -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
-mkReturnSimple actuals updfr_off =
- lastWithArgs Ret old NativeReturn actuals updfr_off $ toCall e Nothing updfr_off 0
- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord
-
-mkFinalCall f _ actuals updfr_off =
- lastWithArgs Call old NativeDirectCall actuals updfr_off $ toCall f Nothing updfr_off 0
-
-mkCmmCall f results actuals = mkCall f (NativeDirectCall, NativeReturn) results actuals
-
--- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later.
-mkCall f (callConv, retConv) results actuals updfr_off =
- withFreshLabel "call successor" $ \k ->
- let area = CallArea $ Young k
- (off, copyin) = copyInOflow retConv area results
- copyout = lastWithArgs Call area callConv actuals updfr_off
- (toCall f (Just k) updfr_off off)
- in (copyout <*> mkLabel k <*> copyin)
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Old-style Cmm data types
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module OldCmm (
+ Cmm, RawCmm, CmmTop, RawCmmTop,
+ ListGraph(..),
+ CmmInfo(..), UpdateFrame(..),
+ cmmMapGraph, cmmTopMapGraph,
+ cmmMapGraphM, cmmTopMapGraphM,
+ GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts,
+ CmmStmt(..), CmmReturnInfo(..), CmmHinted(..),
+ HintedCmmFormal, HintedCmmFormals, HintedCmmActual, HintedCmmActuals,
+ CmmSafety(..), CmmCallTarget(..),
+ module CmmDecl,
+ module CmmExpr,
+ ) where
+
+#include "HsVersions.h"
+
+import BlockId
+import CmmDecl
+import CmmExpr
+import ForeignCall
+
+import ClosureInfo
+import Outputable
+import FastString
+
+
+-- 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.
+
+-----------------------------------------------------------------------------
+-- Info Tables
+-----------------------------------------------------------------------------
+
+data CmmInfo
+ = CmmInfo
+ (Maybe BlockId) -- GC target. Nothing <=> CPS won't do stack check
+ -- JD: NOT USED BY NEW CODE GEN
+ (Maybe UpdateFrame) -- Update frame
+ CmmInfoTable -- Info table
+
+-- | A frame that is to be pushed before entry to the function.
+-- Used to handle 'update' frames.
+data UpdateFrame =
+ UpdateFrame
+ CmmExpr -- Frame header. Behaves like the target of a 'jump'.
+ [CmmExpr] -- Frame remainder. Behaves like the arguments of a 'jump'.
+
+-----------------------------------------------------------------------------
+-- Cmm, CmmTop, CmmBasicBlock
+-----------------------------------------------------------------------------
+
+-- A file is a list of top-level chunks. These may be arbitrarily
+-- re-orderd during code generation.
+
+-- | A control-flow graph represented as a list of extended basic blocks.
+newtype ListGraph i = ListGraph [GenBasicBlock i]
+ -- ^ Code, may be empty. The first block is the entry point. The
+ -- order is otherwise initially unimportant, but at some point the
+ -- code gen will fix the order.
+
+ -- BlockIds must be unique across an entire compilation unit, since
+ -- they are translated to assembly-language labels, which scope
+ -- across a whole compilation unit.
+
+-- | Cmm with the info table as a data type
+type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt)
+type CmmTop = GenCmmTop CmmStatic CmmInfo (ListGraph CmmStmt)
+
+-- | Cmm with the info tables converted to a list of 'CmmStatic'
+type RawCmm = GenCmm CmmStatic [CmmStatic] (ListGraph CmmStmt)
+type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] (ListGraph CmmStmt)
+
+
+-- A basic block containing a single label, at the beginning.
+-- The list of basic blocks in a top-level code block may be re-ordered.
+-- Fall-through is not allowed: there must be an explicit jump at the
+-- end of each basic block, but the code generator might rearrange basic
+-- blocks in order to turn some jumps into fallthroughs.
+
+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
+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 g) = CmmProc h l (f g)
+cmmTopMapGraph _ (CmmData s ds) = CmmData s ds
+
+cmmMapGraphM f (Cmm tops) = mapM (cmmTopMapGraphM f) tops >>= return . Cmm
+cmmTopMapGraphM f (CmmProc h l g) =
+ f (showSDoc $ ppr l) g >>= return . CmmProc h l
+cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds
+
+
+data CmmReturnInfo = CmmMayReturn
+ | CmmNeverReturns
+ deriving ( Eq )
+
+-----------------------------------------------------------------------------
+-- CmmStmt
+-- A "statement". Note that all branches are explicit: there are no
+-- control transfers to computed addresses, except when transfering
+-- control to a new function.
+-----------------------------------------------------------------------------
+
+data CmmStmt -- Old-style
+ = CmmNop
+ | CmmComment FastString
+
+ | CmmAssign CmmReg CmmExpr -- Assign to register
+
+ | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is
+ -- given by cmmExprType of the rhs.
+
+ | CmmCall -- A call (forign, native or primitive), with
+ CmmCallTarget
+ HintedCmmFormals -- zero or more results
+ HintedCmmActuals -- zero or more arguments
+ CmmSafety -- whether to build a continuation
+ CmmReturnInfo
+
+ | CmmBranch BlockId -- branch to another BB in this fn
+
+ | CmmCondBranch CmmExpr BlockId -- conditional branch
+
+ | CmmSwitch CmmExpr [Maybe BlockId] -- Table branch
+ -- The scrutinee is zero-based;
+ -- zero -> first block
+ -- one -> second block etc
+ -- Undefined outside range, and when there's a Nothing
+
+ | CmmJump CmmExpr -- Jump to another C-- function,
+ HintedCmmActuals -- with these parameters. (parameters never used)
+
+ | CmmReturn -- Return from a native C-- function,
+ HintedCmmActuals -- with these return values. (parameters never used)
+
+data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: ForeignHint }
+ deriving( Eq )
+
+type HintedCmmActuals = [HintedCmmActual]
+type HintedCmmFormals = [HintedCmmFormal]
+type HintedCmmFormal = CmmHinted CmmFormal
+type HintedCmmActual = CmmHinted CmmActual
+
+data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible
+
+-- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
+instance UserOfLocalRegs CmmStmt where
+ foldRegsUsed f (set::b) s = stmt s set
+ where
+ stmt :: CmmStmt -> b -> b
+ 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 :: UserOfLocalRegs a => a -> b -> b
+ gen a set = foldRegsUsed f set a
+
+instance UserOfLocalRegs CmmCallTarget where
+ foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e
+ foldRegsUsed _ set (CmmPrim {}) = set
+
+instance UserOfSlots CmmCallTarget where
+ foldSlotsUsed f set (CmmCallee e _) = foldSlotsUsed f set e
+ foldSlotsUsed _ set (CmmPrim {}) = set
+
+instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where
+ foldRegsUsed f set a = foldRegsUsed f set (hintlessCmm a)
+
+instance UserOfSlots a => UserOfSlots (CmmHinted a) where
+ foldSlotsUsed f set a = foldSlotsUsed f set (hintlessCmm a)
+
+instance DefinerOfLocalRegs a => DefinerOfLocalRegs (CmmHinted a) where
+ foldRegsDefd f set a = foldRegsDefd f set (hintlessCmm a)
+
+{-
+Discussion
+~~~~~~~~~~
+
+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 =
+ ...
+ | CmmJump CmmBranchDest
+ | CmmCondJump CmmExpr CmmBranchDest
+ ...
+
+data CmmBranchDest
+ = Local BlockId
+ | NonLocal CmmExpr [LocalReg]
+
+In favour:
+
++ one fewer constructors in CmmStmt
++ allows both cond branch and switch to jump to non-local destinations
+
+Against:
+
+- not strictly necessary: can already encode as branch+jump
+- not always possible to implement any better in the back end
+- could do the optimisation in the back end (but then plat-specific?)
+- C-- doesn't have it
+- back-end optimisation might be more general (jump shortcutting)
+
+So we'll stick with the way it is, and add the optimisation to the NCG.
+-}
+
+-----------------------------------------------------------------------------
+-- CmmCallTarget
+--
+-- The target of a CmmCall.
+-----------------------------------------------------------------------------
+
+data CmmCallTarget
+ = CmmCallee -- Call a function (foreign or native)
+ CmmExpr -- literal label <=> static call
+ -- other expression <=> dynamic call
+ CCallConv -- The calling convention
+
+ | CmmPrim -- Call a "primitive" (eg. sin, cos)
+ CallishMachOp -- These might be implemented as inline
+ -- code by the backend.
+ deriving Eq
--- /dev/null
+-----------------------------------------------------------------------------
+--
+-- Old-style Cmm utilities.
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+module OldCmmUtils(
+ CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList,
+ isNopStmt,
+
+ maybeAssignTemp, loadArgsIntoTemps,
+
+ module CmmUtils,
+ ) where
+
+#include "HsVersions.h"
+
+import OldCmm
+import CmmUtils
+import OrdList
+import Unique
+
+---------------------------------------------------
+--
+-- CmmStmts
+--
+---------------------------------------------------
+
+type CmmStmts = OrdList CmmStmt
+
+noStmts :: CmmStmts
+noStmts = nilOL
+
+oneStmt :: CmmStmt -> CmmStmts
+oneStmt = unitOL
+
+mkStmts :: [CmmStmt] -> CmmStmts
+mkStmts = toOL
+
+plusStmts :: CmmStmts -> CmmStmts -> CmmStmts
+plusStmts = appOL
+
+stmtList :: CmmStmts -> [CmmStmt]
+stmtList = fromOL
+
+
+---------------------------------------------------
+--
+-- CmmStmt
+--
+---------------------------------------------------
+
+isNopStmt :: CmmStmt -> Bool
+-- If isNopStmt returns True, the stmt is definitely a no-op;
+-- but it might be a no-op even if isNopStmt returns False
+isNopStmt CmmNop = True
+isNopStmt (CmmAssign r e) = cheapEqReg r e
+isNopStmt (CmmStore e1 (CmmLoad e2 _)) = cheapEqExpr e1 e2
+isNopStmt _ = False
+
+cheapEqExpr :: CmmExpr -> CmmExpr -> Bool
+cheapEqExpr (CmmReg r) e = cheapEqReg r e
+cheapEqExpr (CmmRegOff r 0) e = cheapEqReg r e
+cheapEqExpr (CmmRegOff r n) (CmmRegOff r' n') = r==r' && n==n'
+cheapEqExpr _ _ = False
+
+cheapEqReg :: CmmReg -> CmmExpr -> Bool
+cheapEqReg r (CmmReg r') = r==r'
+cheapEqReg r (CmmRegOff r' 0) = r==r'
+cheapEqReg _ _ = False
+
+---------------------------------------------------
+--
+-- Helpers for foreign call arguments
+--
+---------------------------------------------------
+
+loadArgsIntoTemps :: [Unique]
+ -> HintedCmmActuals
+ -> ([Unique], [CmmStmt], HintedCmmActuals)
+loadArgsIntoTemps uniques [] = (uniques, [], [])
+loadArgsIntoTemps uniques ((CmmHinted e hint):args) =
+ (uniques'',
+ new_stmts ++ remaining_stmts,
+ (CmmHinted new_e hint) : remaining_e)
+ where
+ (uniques', new_stmts, new_e) = maybeAssignTemp uniques e
+ (uniques'', remaining_stmts, remaining_e) =
+ loadArgsIntoTemps uniques' args
+
+
+maybeAssignTemp :: [Unique] -> CmmExpr -> ([Unique], [CmmStmt], CmmExpr)
+maybeAssignTemp uniques e
+ | hasNoGlobalRegs e = (uniques, [], e)
+ | otherwise = (tail uniques, [CmmAssign local e], CmmReg local)
+ where local = CmmLocal (LocalReg (head uniques) (cmmExprType e))
--- /dev/null
+----------------------------------------------------------------------------
+--
+-- Pretty-printing of old-style Cmm as (a superset of) C--
+--
+-- (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.cminusminus.org/. 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 OldPprCmm
+ ( pprStmt
+ , module PprCmmDecl
+ , module PprCmmExpr
+ )
+where
+
+import BlockId
+import CLabel
+import CmmUtils
+import OldCmm
+import PprCmmDecl
+import PprCmmExpr
+
+
+import BasicTypes
+import ForeignCall
+import Outputable
+import FastString
+
+import Data.List
+
+-----------------------------------------------------------------------------
+
+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 CmmStmt where
+ ppr s = pprStmt s
+
+instance Outputable CmmInfo where
+ ppr e = pprInfo e
+
+
+-- --------------------------------------------------------------------------
+instance Outputable CmmSafety where
+ ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
+ ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
+ ppr (CmmSafe srt) = ppr srt
+
+-- --------------------------------------------------------------------------
+-- Info tables. The current pretty printer needs refinement
+-- but will work for now.
+--
+-- For ideas on how to refine it, they used to be printed in the
+-- style of C--'s 'stackdata' declaration, just inside the proc body,
+-- and were labelled with the procedure name ++ "_info".
+pprInfo :: CmmInfo -> SDoc
+pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
+ vcat [{-ptext (sLit "gc_target: ") <>
+ maybe (ptext (sLit "<none>")) ppr gc_target,-}
+ ptext (sLit "update_frame: ") <>
+ maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
+pprInfo (CmmInfo _gc_target update_frame info_table@(CmmInfoTable _ _ _ _)) =
+ vcat [{-ptext (sLit "gc_target: ") <>
+ maybe (ptext (sLit "<none>")) ppr gc_target,-}
+ ptext (sLit "update_frame: ") <>
+ maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
+ ppr info_table]
+
+
+-- --------------------------------------------------------------------------
+-- Basic blocks look like assembly blocks.
+-- lbl: stmt ; stmt ; ..
+pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
+pprBBlock (BasicBlock ident stmts) =
+ hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
+
+-- --------------------------------------------------------------------------
+-- Statements. C-- usually, exceptions to this should be obvious.
+--
+pprStmt :: CmmStmt -> SDoc
+pprStmt stmt = case stmt of
+
+ -- ;
+ CmmNop -> semi
+
+ -- // text
+ CmmComment s -> text "//" <+> ftext s
+
+ -- reg = expr;
+ CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+ -- rep[lv] = expr;
+ CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+ where
+ rep = ppr ( cmmExprType expr )
+
+ -- call "ccall" foo(x, y)[r1, r2];
+ -- ToDo ppr volatile
+ CmmCall (CmmCallee fn cconv) results args safety ret ->
+ sep [ pp_lhs <+> pp_conv
+ , nest 2 (pprExpr9 fn <>
+ parens (commafy (map ppr_ar args)))
+ <> brackets (ppr safety)
+ , case ret of CmmMayReturn -> empty
+ CmmNeverReturns -> ptext $ sLit (" never returns")
+ ] <> semi
+ where
+ pp_lhs | null results = empty
+ | otherwise = commafy (map ppr_ar results) <+> equals
+ -- Don't print the hints on a native C-- call
+ ppr_ar (CmmHinted ar k) = case cconv of
+ CmmCallConv -> ppr ar
+ _ -> ppr (ar,k)
+ pp_conv = case cconv of
+ CmmCallConv -> empty
+ _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
+
+ -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
+ CmmCall (CmmPrim op) results args safety ret ->
+ pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
+ results args safety ret)
+ where
+ -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
+ -- use one to get the label printed.
+ lbl = CmmLabel (mkForeignLabel
+ (mkFastString (show op))
+ Nothing ForeignLabelInThisPackage IsFunction)
+
+ CmmBranch ident -> genBranch ident
+ CmmCondBranch expr ident -> genCondBranch expr ident
+ CmmJump expr params -> genJump expr params
+ CmmReturn params -> genReturn params
+ CmmSwitch arg ids -> genSwitch arg ids
+
+-- Just look like a tuple, since it was a tuple before
+-- ... is that a good idea? --Isaac Dupree
+instance (Outputable a) => Outputable (CmmHinted a) where
+ ppr (CmmHinted a k) = ppr (a, k)
+
+pprUpdateFrame :: UpdateFrame -> SDoc
+pprUpdateFrame (UpdateFrame expr args) =
+ hcat [ ptext (sLit "jump")
+ , space
+ , if isTrivialCmmExpr expr
+ then pprExpr expr
+ else case expr of
+ CmmLoad (CmmReg _) _ -> pprExpr expr
+ _ -> parens (pprExpr expr)
+ , space
+ , parens ( commafy $ map ppr args ) ]
+
+
+-- --------------------------------------------------------------------------
+-- goto local label. [1], section 6.6
+--
+-- goto lbl;
+--
+genBranch :: BlockId -> SDoc
+genBranch ident =
+ ptext (sLit "goto") <+> ppr ident <> semi
+
+-- --------------------------------------------------------------------------
+-- Conditional. [1], section 6.4
+--
+-- if (expr) { goto lbl; }
+--
+genCondBranch :: CmmExpr -> BlockId -> SDoc
+genCondBranch expr ident =
+ hsep [ ptext (sLit "if")
+ , parens(ppr expr)
+ , ptext (sLit "goto")
+ , ppr ident <> semi ]
+
+-- --------------------------------------------------------------------------
+-- A tail call. [1], Section 6.9
+--
+-- jump foo(a, b, c);
+--
+genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
+genJump expr args =
+ hcat [ ptext (sLit "jump")
+ , space
+ , if isTrivialCmmExpr expr
+ then pprExpr expr
+ else case expr of
+ CmmLoad (CmmReg _) _ -> pprExpr expr
+ _ -> parens (pprExpr expr)
+ , space
+ , parens ( commafy $ map ppr args )
+ , semi ]
+
+
+-- --------------------------------------------------------------------------
+-- Return from a function. [1], Section 6.8.2 of version 1.128
+--
+-- return (a, b, c);
+--
+genReturn :: [CmmHinted CmmExpr] -> SDoc
+genReturn args =
+ hcat [ ptext (sLit "return")
+ , space
+ , parens ( commafy $ map ppr args )
+ , semi ]
+
+-- --------------------------------------------------------------------------
+-- Tabled jump to local label
+--
+-- The syntax is from [1], section 6.5
+--
+-- switch [0 .. n] (expr) { case ... ; }
+--
+genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
+genSwitch expr maybe_ids
+
+ = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
+
+ in hang (hcat [ ptext (sLit "switch [0 .. ")
+ , int (length maybe_ids - 1)
+ , ptext (sLit "] ")
+ , if isTrivialCmmExpr expr
+ then pprExpr expr
+ else parens (pprExpr expr)
+ , ptext (sLit " {")
+ ])
+ 4 (vcat ( map caseify pairs )) $$ rbrace
+
+ where
+ snds a b = (snd a) == (snd b)
+
+ caseify :: [(Int,Maybe BlockId)] -> SDoc
+ caseify ixs@((_,Nothing):_)
+ = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
+ <> ptext (sLit " */")
+ caseify as
+ = let (is,ids) = unzip as
+ in hsep [ ptext (sLit "case")
+ , hcat (punctuate comma (map int is))
+ , ptext (sLit ": goto")
+ , ppr (head [ id | Just id <- ids]) <> semi ]
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = fsep $ punctuate comma xs
+{-# LANGUAGE TypeFamilies #-}
-- | Optimisation fuel is used to control the amount of work the optimiser does.
--
-- Every optimisation step consumes a certain amount of fuel and stops when
-- the optimiser with varying amount of fuel to find out the exact number of
-- steps where a bug is introduced in the output.
module OptimizationFuel
- ( OptimizationFuel, canRewriteWithFuel, maybeRewriteWithFuel, oneLessFuel
- , OptFuelState, initOptFuelState --, setTotalFuel
- , tankFilledTo, diffFuel
- , FuelConsumer
- , FuelUsingMonad, FuelState
- , lastFuelPass, fuelExhausted, fuelRemaining, fuelDecrement, fuelDec1
+ ( OptimizationFuel, amountOfFuel, tankFilledTo, anyFuelLeft, oneLessFuel
+ , OptFuelState, initOptFuelState
+ , FuelConsumer, FuelUsingMonad, FuelState
+ , fuelGet, fuelSet, lastFuelPass, setFuelPass
+ , fuelExhausted, fuelDec1, tryWithFuel
, runFuelIO, fuelConsumingPass
- , FuelMonad
+ , FuelUniqSM
, liftUniq
- , lGraphOfGraph -- needs to be able to create a unique ID...
)
where
-import BlockId
-import ZipCfg
---import GHC.Exts (State#)
-import Panic
import Data.IORef
import Control.Monad
import StaticFlags (opt_Fuel)
import UniqSupply
+import Panic ()
+
+import Compiler.Hoopl
+import Compiler.Hoopl.GHC (getFuel, setFuel)
#include "HsVersions.h"
type FuelConsumer a = OptimizationFuel -> (a, OptimizationFuel)
-canRewriteWithFuel :: OptimizationFuel -> Bool
-oneLessFuel :: OptimizationFuel -> OptimizationFuel
-maybeRewriteWithFuel :: OptimizationFuel -> Maybe a -> Maybe a
-diffFuel :: OptimizationFuel -> OptimizationFuel -> Int
- -- to measure consumption during compilation
tankFilledTo :: Int -> OptimizationFuel
+amountOfFuel :: OptimizationFuel -> Int
+
+anyFuelLeft :: OptimizationFuel -> Bool
+oneLessFuel :: OptimizationFuel -> OptimizationFuel
#ifdef DEBUG
newtype OptimizationFuel = OptimizationFuel Int
deriving Show
tankFilledTo = OptimizationFuel
-canRewriteWithFuel (OptimizationFuel f) = f > 0
-maybeRewriteWithFuel fuel ma = if canRewriteWithFuel fuel then ma else Nothing
+amountOfFuel (OptimizationFuel f) = f
+
+anyFuelLeft (OptimizationFuel f) = f > 0
oneLessFuel (OptimizationFuel f) = ASSERT (f > 0) (OptimizationFuel (f - 1))
-diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f'
#else
-- type OptimizationFuel = State# () -- would like this, but it won't work
data OptimizationFuel = OptimizationFuel
deriving Show
-tankFilledTo _ = panic "tankFilledTo" -- should be impossible to evaluate
- -- realWorld# might come in handy, too...
-canRewriteWithFuel OptimizationFuel = True
-maybeRewriteWithFuel _ ma = ma
-oneLessFuel f = f
-diffFuel _ _ = 0
+tankFilledTo _ = OptimizationFuel
+amountOfFuel _ = maxBound
+
+anyFuelLeft _ = True
+oneLessFuel _ = OptimizationFuel
#endif
-data FuelState = FuelState { fs_fuellimit :: OptimizationFuel, fs_lastpass :: String }
-newtype FuelMonad a = FuelMonad (FuelState -> UniqSM (a, FuelState))
+data FuelState = FuelState { fs_fuel :: OptimizationFuel, fs_lastpass :: String }
+newtype FuelUniqSM a = FUSM { unFUSM :: FuelState -> UniqSM (a, FuelState) }
-fuelConsumingPass :: String -> FuelConsumer a -> FuelMonad a
-fuelConsumingPass name f = do fuel <- fuelRemaining
+fuelConsumingPass :: String -> FuelConsumer a -> FuelUniqSM a
+fuelConsumingPass name f = do setFuelPass name
+ fuel <- fuelGet
let (a, fuel') = f fuel
- fuelDecrement name fuel fuel'
+ fuelSet fuel'
return a
-runFuelIO :: OptFuelState -> FuelMonad a -> IO a
-runFuelIO fs (FuelMonad f) =
+runFuelIO :: OptFuelState -> FuelUniqSM a -> IO a
+runFuelIO fs (FUSM f) =
do pass <- readIORef (pass_ref fs)
fuel <- readIORef (fuel_ref fs)
u <- mkSplitUniqSupply 'u'
writeIORef (fuel_ref fs) fuel'
return a
-instance Monad FuelMonad where
- FuelMonad f >>= k = FuelMonad (\s -> do (a, s') <- f s
- let FuelMonad f' = k a in (f' s'))
- return a = FuelMonad (\s -> return (a, s))
+instance Monad FuelUniqSM where
+ FUSM f >>= k = FUSM (\s -> f s >>= \(a, s') -> unFUSM (k a) s')
+ return a = FUSM (\s -> return (a, s))
-instance MonadUnique FuelMonad where
+instance MonadUnique FuelUniqSM where
getUniqueSupplyM = liftUniq getUniqueSupplyM
getUniqueM = liftUniq getUniqueM
getUniquesM = liftUniq getUniquesM
-liftUniq :: UniqSM x -> FuelMonad x
-liftUniq x = FuelMonad (\s -> x >>= (\u -> return (u, s)))
+
+liftUniq :: UniqSM x -> FuelUniqSM x
+liftUniq x = FUSM (\s -> x >>= (\u -> return (u, s)))
class Monad m => FuelUsingMonad m where
- fuelRemaining :: m OptimizationFuel
- fuelDecrement :: String -> OptimizationFuel -> OptimizationFuel -> m ()
- fuelDec1 :: m ()
- fuelExhausted :: m Bool
- lastFuelPass :: m String
-
-instance FuelUsingMonad FuelMonad where
- fuelRemaining = extract fs_fuellimit
- lastFuelPass = extract fs_lastpass
- fuelExhausted = extract $ not . canRewriteWithFuel . fs_fuellimit
- fuelDecrement p f f' = FuelMonad (\s -> return ((), fuelDecrementState p f f' s))
- fuelDec1 = FuelMonad f
- where f s = if canRewriteWithFuel (fs_fuellimit s) then
- return ((), s { fs_fuellimit = oneLessFuel (fs_fuellimit s) })
- else panic "Tried to use exhausted fuel supply"
-
-extract :: (FuelState -> a) -> FuelMonad a
-extract f = FuelMonad (\s -> return (f s, s))
-
-fuelDecrementState
- :: String -> OptimizationFuel -> OptimizationFuel -> FuelState -> FuelState
-fuelDecrementState new_optimizer old new s =
- FuelState { fs_fuellimit = lim, fs_lastpass = optimizer }
- where lim = if diffFuel old (fs_fuellimit s) == 0 then new
- else panic $
- concat ["lost track of ", new_optimizer, "'s transactions"]
- optimizer = if diffFuel old new > 0 then new_optimizer else fs_lastpass s
-
--- lGraphOfGraph is here because we need uniques to implement it.
-lGraphOfGraph :: Graph m l -> FuelMonad (LGraph m l)
-lGraphOfGraph (Graph tail blocks) =
- do entry <- liftM BlockId $ getUniqueM
- return $ LGraph entry (insertBlock (Block entry tail) blocks)
+ fuelGet :: m OptimizationFuel
+ fuelSet :: OptimizationFuel -> m ()
+ lastFuelPass :: m String
+ setFuelPass :: String -> m ()
+
+fuelExhausted :: FuelUsingMonad m => m Bool
+fuelExhausted = fuelGet >>= return . anyFuelLeft
+
+fuelDec1 :: FuelUsingMonad m => m ()
+fuelDec1 = fuelGet >>= fuelSet . oneLessFuel
+
+tryWithFuel :: FuelUsingMonad m => a -> m (Maybe a)
+tryWithFuel r = do f <- fuelGet
+ if anyFuelLeft f then fuelSet (oneLessFuel f) >> return (Just r)
+ else return Nothing
+
+instance FuelUsingMonad FuelUniqSM where
+ fuelGet = extract fs_fuel
+ lastFuelPass = extract fs_lastpass
+ fuelSet fuel = FUSM (\s -> return ((), s { fs_fuel = fuel }))
+ setFuelPass pass = FUSM (\s -> return ((), s { fs_lastpass = pass }))
+
+extract :: (FuelState -> a) -> FuelUniqSM a
+extract f = FUSM (\s -> return (f s, s))
+
+instance FuelMonad FuelUniqSM where
+ getFuel = liftM amountOfFuel fuelGet
+ setFuel = fuelSet . tankFilledTo
+
+-- Don't bother to checkpoint the unique supply; it doesn't matter
+instance CheckpointMonad FuelUniqSM where
+ type Checkpoint FuelUniqSM = FuelState
+ checkpoint = FUSM $ \fuel -> return (fuel, fuel)
+ restart fuel = FUSM $ \_ -> return ((), fuel)
+
-- Cmm stuff
import BlockId
-import Cmm
-import PprCmm () -- Instances only
+import OldCmm
+import OldPprCmm () -- Instances only
import CLabel
import ForeignCall
import ClosureInfo
-- top level procs
--
pprTop :: RawCmmTop -> SDoc
-pprTop (CmmProc info clbl _params (ListGraph blocks)) =
+pprTop (CmmProc info clbl (ListGraph blocks)) =
(if not (null info)
then pprDataExterns info $$
pprWordArray (entryLblToInfoLbl clbl) info
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
-
--
--- This is where we walk over Cmm emitting an external representation,
+-- 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.
--
-- These conventions produce much more readable Cmm output.
--
-- A useful example pass over Cmm is in nativeGen/MachCodeGen.hs
---
+{-# LANGUAGE GADTs, TypeFamilies, FlexibleContexts #-}
module PprCmm
- ( writeCmms, pprCmms, pprCmm, pprStmt, pprExpr,
- pprSection, pprStatic, pprLit
- )
+ ( module PprCmmDecl
+ , module PprCmmExpr
+ )
where
-import BlockId
-import Cmm
-import CmmUtils
+import BlockId ()
import CLabel
-import BasicTypes
-
-
-import ForeignCall
-import Outputable
+import Cmm
+import CmmExpr
+import CmmUtils (isTrivialCmmExpr)
import FastString
+import Outputable
+import PprCmmDecl
+import PprCmmExpr
+import Util
+import BasicTypes
+import Compiler.Hoopl
import Data.List
-import System.IO
-import Data.Maybe
-
--- Temp Jan08
-import SMRep
-import ClosureInfo
-#include "../includes/rts/storage/FunTypes.h"
-
-
-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
-
-writeCmms :: Handle -> [Cmm] -> IO ()
-writeCmms handle cmms = printForC handle (pprCmms cmms)
-
------------------------------------------------------------------------------
-
-instance (Outputable d, Outputable info, Outputable g)
- => Outputable (GenCmm d 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 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 CmmStmt where
- ppr s = pprStmt s
-
-instance Outputable CmmExpr where
- ppr e = pprExpr e
-
-instance Outputable CmmReg where
- ppr e = pprReg e
-
-instance Outputable CmmLit where
- ppr l = pprLit l
-
-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 Outputable CmmStatic where
- ppr e = pprStatic e
-
-instance Outputable CmmInfo where
- ppr e = pprInfo e
-
-
-
------------------------------------------------------------------------------
-
-pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
-pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
-
--- --------------------------------------------------------------------------
--- Top level `procedure' blocks.
---
-pprTop :: (Outputable d, Outputable info, Outputable i)
- => GenCmmTop d info i -> SDoc
-
-pprTop (CmmProc info lbl params graph )
-
- = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params)
- , nest 8 $ lbrace <+> ppr info $$ rbrace
- , nest 4 $ ppr graph
- , rbrace ]
-
--- --------------------------------------------------------------------------
--- We follow [1], 4.5
---
--- section "data" { ... }
---
-pprTop (CmmData section ds) =
- (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
- $$ rbrace
-
--- --------------------------------------------------------------------------
-instance Outputable CmmSafety where
- ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
- ppr (CmmSafe srt) = ppr srt
- ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
-
--- --------------------------------------------------------------------------
--- Info tables. The current pretty printer needs refinement
--- but will work for now.
---
--- For ideas on how to refine it, they used to be printed in the
--- style of C--'s 'stackdata' declaration, just inside the proc body,
--- and were labelled with the procedure name ++ "_info".
-pprInfo :: CmmInfo -> SDoc
-pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) =
- vcat [{-ptext (sLit "gc_target: ") <>
- maybe (ptext (sLit "<none>")) ppr gc_target,-}
- ptext (sLit "update_frame: ") <>
- maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame]
-pprInfo (CmmInfo _gc_target update_frame
- (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) =
- vcat [{-ptext (sLit "gc_target: ") <>
- maybe (ptext (sLit "<none>")) ppr gc_target,-}
- ptext (sLit "has static closure: ") <> ppr stat_clos <+>
- ptext (sLit "update_frame: ") <>
- maybe (ptext (sLit "<none>")) pprUpdateFrame update_frame,
- ptext (sLit "type: ") <> pprLit closure_type,
- ptext (sLit "desc: ") <> pprLit closure_desc,
- ptext (sLit "tag: ") <> integer (toInteger tag),
- pprTypeInfo info]
-
-pprTypeInfo :: ClosureTypeInfo -> SDoc
-pprTypeInfo (ConstrInfo layout constr descr) =
- vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
- ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
- ptext (sLit "constructor: ") <> integer (toInteger constr),
- pprLit descr]
-pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
- vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
- ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
- ptext (sLit "srt: ") <> ppr srt,
--- Temp Jan08
- ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
-
- ptext (sLit "arity: ") <> integer (toInteger arity),
- --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
- ptext (sLit "slow: ") <> pprLit slow_entry
- ]
-pprTypeInfo (ThunkInfo layout srt) =
- vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
- ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
- ptext (sLit "srt: ") <> ppr srt]
-pprTypeInfo (ThunkSelectorInfo offset srt) =
- vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
- ptext (sLit "srt: ") <> ppr srt]
-pprTypeInfo (ContInfo stack srt) =
- vcat [ptext (sLit "stack: ") <> ppr stack,
- ptext (sLit "srt: ") <> ppr srt]
-
--- Temp Jan08
-argDescrType :: ArgDescr -> StgHalfWord
--- The "argument type" RTS field type
-argDescrType (ArgSpec n) = n
-argDescrType (ArgGen liveness)
- | isBigLiveness liveness = ARG_GEN_BIG
- | otherwise = ARG_GEN
-
--- Temp Jan08
-isBigLiveness :: Liveness -> Bool
-isBigLiveness (BigLiveness _) = True
-isBigLiveness (SmallLiveness _) = False
-
-
-pprUpdateFrame :: UpdateFrame -> SDoc
-pprUpdateFrame (UpdateFrame expr args) =
- hcat [ ptext (sLit "jump")
- , space
- , if isTrivialCmmExpr expr
- then pprExpr expr
- else case expr of
- CmmLoad (CmmReg _) _ -> pprExpr expr
- _ -> parens (pprExpr expr)
- , space
- , parens ( commafy $ map ppr args ) ]
-
-
--- --------------------------------------------------------------------------
--- Basic blocks look like assembly blocks.
--- lbl: stmt ; stmt ; ..
-pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc
-pprBBlock (BasicBlock ident stmts) =
- hang (ppr ident <> colon) 4 (vcat (map ppr stmts))
-
--- --------------------------------------------------------------------------
--- Statements. C-- usually, exceptions to this should be obvious.
---
-pprStmt :: CmmStmt -> SDoc
-pprStmt stmt = case stmt of
-
- -- ;
- CmmNop -> semi
-
- -- // text
- CmmComment s -> text "//" <+> ftext s
-
- -- reg = expr;
- CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
-
- -- rep[lv] = expr;
- CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
- where
- rep = ppr ( cmmExprType expr )
-
- -- call "ccall" foo(x, y)[r1, r2];
- -- ToDo ppr volatile
- CmmCall (CmmCallee fn cconv) results args safety ret ->
- sep [ pp_lhs <+> pp_conv
- , nest 2 (pprExpr9 fn <>
- parens (commafy (map ppr_ar args)))
- <> brackets (ppr safety)
- , case ret of CmmMayReturn -> empty
- CmmNeverReturns -> ptext $ sLit (" never returns")
- ] <> semi
- where
- pp_lhs | null results = empty
- | otherwise = commafy (map ppr_ar results) <+> equals
- -- Don't print the hints on a native C-- call
-
- ppr_ar :: Outputable a => CmmHinted a -> SDoc
- ppr_ar (CmmHinted ar k) = case cconv of
- CmmCallConv -> ppr ar
- _ -> ppr (ar,k)
- pp_conv = case cconv of
- CmmCallConv -> empty
- _ -> ptext (sLit("foreign")) <+> doubleQuotes (ppr cconv)
-
- -- Call a CallishMachOp, like sin or cos that might be implemented as a library call.
- CmmCall (CmmPrim op) results args safety ret ->
- pprStmt (CmmCall (CmmCallee (CmmLit lbl) CCallConv)
- results args safety ret)
- where
- -- HACK: A CallishMachOp doesn't really correspond to a ForeignLabel, but we
- -- use one to get the label printed.
- lbl = CmmLabel (mkForeignLabel
- (mkFastString (show op))
- Nothing ForeignLabelInThisPackage IsFunction)
-
- CmmBranch ident -> genBranch ident
- CmmCondBranch expr ident -> genCondBranch expr ident
- CmmJump expr params -> genJump expr params
- CmmReturn params -> genReturn params
- CmmSwitch arg ids -> genSwitch arg ids
-
-instance Outputable ForeignHint where
- ppr NoHint = empty
- ppr SignedHint = quotes(text "signed")
--- ppr AddrHint = quotes(text "address")
--- Temp Jan08
- ppr AddrHint = (text "PtrHint")
-
--- Just look like a tuple, since it was a tuple before
--- ... is that a good idea? --Isaac Dupree
-instance (Outputable a) => Outputable (CmmHinted a) where
- ppr (CmmHinted a k) = ppr (a, k)
-
--- --------------------------------------------------------------------------
--- goto local label. [1], section 6.6
---
--- goto lbl;
---
-genBranch :: BlockId -> SDoc
-genBranch ident =
- ptext (sLit "goto") <+> ppr ident <> semi
-
--- --------------------------------------------------------------------------
--- Conditional. [1], section 6.4
---
--- if (expr) { goto lbl; }
---
-genCondBranch :: CmmExpr -> BlockId -> SDoc
-genCondBranch expr ident =
- hsep [ ptext (sLit "if")
- , parens(ppr expr)
- , ptext (sLit "goto")
- , ppr ident <> semi ]
-
--- --------------------------------------------------------------------------
--- A tail call. [1], Section 6.9
---
--- jump foo(a, b, c);
---
-genJump :: CmmExpr -> [CmmHinted CmmExpr] -> SDoc
-genJump expr args =
- hcat [ ptext (sLit "jump")
- , space
- , if isTrivialCmmExpr expr
- then pprExpr expr
- else case expr of
- CmmLoad (CmmReg _) _ -> pprExpr expr
- _ -> parens (pprExpr expr)
- , space
- , parens ( commafy $ map ppr args )
- , semi ]
-
-
--- --------------------------------------------------------------------------
--- Return from a function. [1], Section 6.8.2 of version 1.128
---
--- return (a, b, c);
---
-genReturn :: [CmmHinted CmmExpr] -> SDoc
-genReturn args =
- hcat [ ptext (sLit "return")
- , space
- , parens ( commafy $ map ppr args )
- , semi ]
-
--- --------------------------------------------------------------------------
--- Tabled jump to local label
---
--- The syntax is from [1], section 6.5
---
--- switch [0 .. n] (expr) { case ... ; }
---
-genSwitch :: CmmExpr -> [Maybe BlockId] -> SDoc
-genSwitch expr maybe_ids
-
- = let pairs = groupBy snds (zip [0 .. ] maybe_ids )
-
- in hang (hcat [ ptext (sLit "switch [0 .. ")
- , int (length maybe_ids - 1)
- , ptext (sLit "] ")
- , if isTrivialCmmExpr expr
- then pprExpr expr
- else parens (pprExpr expr)
- , ptext (sLit " {")
- ])
- 4 (vcat ( map caseify pairs )) $$ rbrace
-
- where
- snds a b = (snd a) == (snd b)
-
- caseify :: [(Int,Maybe BlockId)] -> SDoc
- caseify ixs@((_,Nothing):_)
- = ptext (sLit "/* impossible: ") <> hcat (intersperse comma (map (int.fst) ixs))
- <> ptext (sLit " */")
- caseify as
- = let (is,ids) = unzip as
- in hsep [ ptext (sLit "case")
- , hcat (punctuate comma (map int is))
- , ptext (sLit ": goto")
- , ppr (head [ id | Just id <- ids]) <> semi ]
-
--- --------------------------------------------------------------------------
--- Expressions
---
-
-pprExpr :: CmmExpr -> SDoc
-pprExpr e
- = case e of
- CmmRegOff reg i ->
- pprExpr (CmmMachOp (MO_Add rep)
- [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
- where rep = typeWidth (cmmRegType reg)
- CmmLit lit -> pprLit lit
- _other -> pprExpr1 e
-
--- Here's the precedence table from CmmParse.y:
--- %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 :: CmmExpr -> SDoc
-pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
- = pprExpr7 x <+> doc <+> pprExpr7 y
-pprExpr1 e = pprExpr7 e
-
-infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
-
-infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
-infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
-infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
-infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>"))
-infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">="))
-infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<="))
-infixMachOp1 (MO_U_Gt _) = Just (char '>')
-infixMachOp1 (MO_U_Lt _) = Just (char '<')
-infixMachOp1 _ = Nothing
-
--- %left '-' '+'
-pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
- = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
-pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
- = pprExpr7 x <+> doc <+> pprExpr8 y
-pprExpr7 e = pprExpr8 e
-
-infixMachOp7 (MO_Add _) = Just (char '+')
-infixMachOp7 (MO_Sub _) = Just (char '-')
-infixMachOp7 _ = Nothing
-
--- %left '/' '*' '%'
-pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
- = pprExpr8 x <+> doc <+> pprExpr9 y
-pprExpr8 e = pprExpr9 e
-
-infixMachOp8 (MO_U_Quot _) = Just (char '/')
-infixMachOp8 (MO_Mul _) = Just (char '*')
-infixMachOp8 (MO_U_Rem _) = Just (char '%')
-infixMachOp8 _ = Nothing
-
-pprExpr9 :: CmmExpr -> SDoc
-pprExpr9 e =
- case e of
- CmmLit lit -> pprLit1 lit
- CmmLoad expr rep -> ppr rep <> brackets( ppr 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 mop args
-
-genMachOp :: MachOp -> [CmmExpr] -> SDoc
-genMachOp mop args
- | Just doc <- infixMachOp mop = case args of
- -- dyadic
- [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
-
- -- unary
- [x] -> doc <> pprExpr9 x
-
- _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
- (pprMachOp mop <+>
- parens (hcat $ punctuate comma (map pprExpr args)))
- empty
-
- | isJust (infixMachOp1 mop)
- || isJust (infixMachOp7 mop)
- || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
-
- | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr 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 :: CmmLit -> SDoc
-pprLit lit = case lit of
- CmmInt i rep ->
- hcat [ (if i < 0 then parens else id)(integer i)
- , ppUnless (rep == wordWidth) $
- space <> dcolon <+> ppr rep ]
-
- CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
- CmmLabel clbl -> pprCLabel clbl
- CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
- CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
- <> pprCLabel clbl2 <> ppr_offset i
- CmmBlock id -> ppr id
- CmmHighStackMark -> text "<highSp>"
-
-pprLit1 :: CmmLit -> SDoc
-pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
-pprLit1 lit = pprLit lit
-
-ppr_offset :: Int -> SDoc
-ppr_offset i
- | i==0 = empty
- | i>=0 = char '+' <> int i
- | otherwise = char '-' <> int (-i)
-
--- --------------------------------------------------------------------------
--- Static data.
--- Strings are printed as C strings, and we print them as I8[],
--- following C--
---
-pprStatic :: CmmStatic -> SDoc
-pprStatic s = case s of
- CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
- CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
- CmmAlign i -> nest 4 $ text "align" <+> int i
- CmmDataLabel clbl -> pprCLabel clbl <> colon
- CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
-
--- --------------------------------------------------------------------------
--- 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 '_' <> ppr uniq <>
- (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
- then dcolon <> ptr <> ppr rep
- else dcolon <> ptr <> ppr rep)
- where
- ptr = empty
- --if isGcPtrType rep
- -- then doubleQuotes (text "ptr")
- -- else empty
-
--- Stack areas
-pprArea :: Area -> SDoc
-pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ]
-pprArea (CallArea id) = pprAreaId id
-
-pprAreaId :: AreaId -> SDoc
-pprAreaId Old = text "old"
-pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
-
--- needs to be kept in syn with Cmm.hs.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
- Sp -> ptext (sLit "Sp")
- SpLim -> ptext (sLit "SpLim")
- Hp -> ptext (sLit "Hp")
- HpLim -> ptext (sLit "HpLim")
- CurrentTSO -> ptext (sLit "CurrentTSO")
- CurrentNursery -> ptext (sLit "CurrentNursery")
- HpAlloc -> ptext (sLit "HpAlloc")
- EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
- GCEnter1 -> ptext (sLit "stg_gc_enter_1")
- GCFun -> ptext (sLit "stg_gc_fun")
- BaseReg -> ptext (sLit "BaseReg")
- PicBaseReg -> ptext (sLit "PicBaseReg")
-
--- --------------------------------------------------------------------------
--- data sections
---
-pprSection :: Section -> SDoc
-pprSection s = case s of
- 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"))
- OtherSection s' -> section <+> doubleQuotes (text s')
- where
- section = ptext (sLit "section")
-
------------------------------------------------------------------------------
-
-commafy :: [SDoc] -> SDoc
-commafy xs = fsep $ punctuate comma xs
+import Prelude hiding (succ)
+
+-------------------------------------------------
+-- Outputable instances
+
+instance Outputable CmmStackInfo where
+ ppr = pprStackInfo
+
+instance Outputable CmmTopInfo where
+ ppr = pprTopInfo
+
+
+instance Outputable (CmmNode e x) where
+ ppr = pprNode
+
+instance Outputable Convention where
+ ppr = pprConvention
+
+instance Outputable ForeignConvention where
+ ppr = pprForeignConvention
+
+instance Outputable ForeignTarget where
+ ppr = pprForeignTarget
+
+
+instance Outputable (Block CmmNode C C) where
+ ppr = pprBlock
+instance Outputable (Block CmmNode C O) where
+ ppr = pprBlock
+instance Outputable (Block CmmNode O C) where
+ ppr = pprBlock
+instance Outputable (Block CmmNode O O) where
+ ppr = pprBlock
+
+instance Outputable (Graph CmmNode e x) where
+ ppr = pprGraph
+
+instance Outputable CmmGraph where
+ ppr = pprCmmGraph
+
+----------------------------------------------------------
+-- Outputting types Cmm contains
+
+pprStackInfo :: CmmStackInfo -> SDoc
+pprStackInfo (StackInfo {arg_space=arg_space, updfr_space=updfr_space}) =
+ ptext (sLit "arg_space: ") <> ppr arg_space <+>
+ ptext (sLit "updfr_space: ") <> ppr updfr_space
+
+pprTopInfo :: CmmTopInfo -> SDoc
+pprTopInfo (TopInfo {info_tbl=info_tbl, stack_info=stack_info}) =
+ vcat [ptext (sLit "info_tbl: ") <> ppr info_tbl,
+ ptext (sLit "stack_info: ") <> ppr stack_info]
+
+----------------------------------------------------------
+-- Outputting blocks and graphs
+
+pprBlock :: IndexedCO x SDoc SDoc ~ SDoc => Block CmmNode e x -> IndexedCO e SDoc SDoc
+pprBlock block = foldBlockNodesB3 ( ($$) . ppr
+ , ($$) . (nest 4) . ppr
+ , ($$) . (nest 4) . ppr
+ )
+ block
+ empty
+
+pprGraph :: Graph CmmNode e x -> SDoc
+pprGraph GNil = empty
+pprGraph (GUnit block) = ppr block
+pprGraph (GMany entry body exit)
+ = text "{"
+ $$ nest 2 (pprMaybeO entry $$ (vcat $ map ppr $ bodyToBlockList body) $$ pprMaybeO exit)
+ $$ text "}"
+ where pprMaybeO :: Outputable (Block CmmNode e x) => MaybeO ex (Block CmmNode e x) -> SDoc
+ pprMaybeO NothingO = empty
+ pprMaybeO (JustO block) = ppr block
+
+pprCmmGraph :: CmmGraph -> SDoc
+pprCmmGraph g
+ = text "{" <> text "offset"
+ $$ nest 2 (vcat $ map ppr blocks)
+ $$ text "}"
+ where blocks = postorderDfs g
+
+---------------------------------------------
+-- 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>"
+pprConvention PrimOpCall = text "<primop-call-convention>"
+pprConvention PrimOpReturn = text "<primop-ret-convention>"
+pprConvention (Foreign c) = ppr c
+pprConvention (Private {}) = text "<private-convention>"
+
+pprForeignConvention :: ForeignConvention -> SDoc
+pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
+
+pprForeignTarget :: ForeignTarget -> SDoc
+pprForeignTarget (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
+ where ppr_fc :: ForeignConvention -> SDoc
+ ppr_fc (ForeignConvention c args res) =
+ doubleQuotes (ppr c) <+> text "arg hints: " <+> ppr args <+> text " result hints: " <+> ppr res
+ ppr_target :: CmmExpr -> SDoc
+ ppr_target t@(CmmLit _) = ppr t
+ ppr_target fn' = parens (ppr fn')
+
+pprForeignTarget (PrimTarget op)
+ -- HACK: We're just using a ForeignLabel to get this printed, the label
+ -- might not really be foreign.
+ = ppr (CmmLabel (mkForeignLabel
+ (mkFastString (show op))
+ Nothing ForeignLabelInThisPackage IsFunction))
+pprNode :: CmmNode e x -> SDoc
+pprNode node = pp_node <+> pp_debug
+ where
+ pp_node :: SDoc
+ pp_node = case node of
+ -- label:
+ CmmEntry id -> ppr id <> colon
+
+ -- // text
+ CmmComment s -> text "//" <+> ftext s
+
+ -- reg = expr;
+ CmmAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
+
+ -- rep[lv] = expr;
+ CmmStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
+ where
+ rep = ppr ( cmmExprType 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,
+ ptext $ sLit "call",
+ ppr target <> parens (commafy $ map ppr args) <> semi]
+
+ -- goto label;
+ CmmBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
+
+ -- if (expr) goto t; else goto f;
+ CmmCondBranch expr t f ->
+ hsep [ ptext (sLit "if")
+ , parens(ppr expr)
+ , ptext (sLit "goto")
+ , ppr t <> semi
+ , ptext (sLit "else goto")
+ , ppr f <> semi
+ ]
+
+ CmmSwitch expr maybe_ids ->
+ hang (hcat [ ptext (sLit "switch [0 .. ")
+ , int (length maybe_ids - 1)
+ , ptext (sLit "] ")
+ , if isTrivialCmmExpr expr then ppr expr else parens (ppr expr)
+ , ptext (sLit " {")
+ ])
+ 4 (vcat ( map caseify pairs )) $$ rbrace
+ where pairs = groupBy snds (zip [0 .. ] maybe_ids )
+ snds a b = (snd a) == (snd b)
+ caseify ixs@((_,Nothing):_) = ptext (sLit "/* impossible: ")
+ <> hcat (intersperse comma (map (int.fst) ixs)) <> ptext (sLit " */")
+ caseify as = let (is,ids) = unzip as
+ in hsep [ ptext (sLit "case")
+ , hcat (punctuate comma (map int is))
+ , ptext (sLit ": goto")
+ , ppr (head [ id | Just id <- ids]) <> semi ]
+
+ CmmCall tgt k out res updfr_off ->
+ hcat [ ptext (sLit "call"), space
+ , pprFun tgt, ptext (sLit "(...)"), space
+ , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
+ <+> parens (ppr res)
+ , ptext (sLit " with update frame") <+> ppr updfr_off
+ , semi ]
+ where pprFun f@(CmmLit _) = ppr f
+ pprFun f = parens (ppr f)
+
+ CmmForeignCall {tgt=t, res=rs, args=as, succ=s, updfr=u, intrbl=i} ->
+ hcat $ if i then [ptext (sLit "interruptible"), space] else [] ++
+ [ ptext (sLit "foreign call"), space
+ , ppr t, ptext (sLit "(...)"), space
+ , ptext (sLit "returns to") <+> ppr s
+ <+> ptext (sLit "args:") <+> parens (ppr as)
+ <+> ptext (sLit "ress:") <+> parens (ppr rs)
+ , ptext (sLit " with update frame") <+> 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"
+ 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
--- /dev/null
+----------------------------------------------------------------------------
+--
+-- 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.cminusminus.org/. 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 PprCmmDecl
+ ( writeCmms, pprCmms, pprCmm, pprSection, pprStatic
+ )
+where
+
+import CmmDecl
+import CLabel
+import PprCmmExpr
+
+
+import Outputable
+import FastString
+
+import Data.List
+import System.IO
+
+-- Temp Jan08
+import SMRep
+import ClosureInfo
+#include "../includes/rts/storage/FunTypes.h"
+
+
+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
+
+writeCmms :: (Outputable info, Outputable g) => Handle -> [GenCmm CmmStatic info g] -> IO ()
+writeCmms handle cmms = printForC handle (pprCmms cmms)
+
+-----------------------------------------------------------------------------
+
+instance (Outputable d, Outputable info, Outputable g)
+ => Outputable (GenCmm d 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 CmmStatic where
+ ppr e = pprStatic e
+
+instance Outputable CmmInfoTable where
+ ppr e = pprInfoTable e
+
+
+-----------------------------------------------------------------------------
+
+pprCmm :: (Outputable d, Outputable info, Outputable g) => GenCmm d info g -> SDoc
+pprCmm (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops
+
+-- --------------------------------------------------------------------------
+-- Top level `procedure' blocks.
+--
+pprTop :: (Outputable d, Outputable info, Outputable i)
+ => GenCmmTop d info i -> SDoc
+
+pprTop (CmmProc info lbl graph)
+
+ = vcat [ pprCLabel lbl <> lparen <> rparen
+ , nest 8 $ lbrace <+> ppr info $$ rbrace
+ , nest 4 $ ppr graph
+ , rbrace ]
+
+-- --------------------------------------------------------------------------
+-- We follow [1], 4.5
+--
+-- section "data" { ... }
+--
+pprTop (CmmData section ds) =
+ (hang (pprSection section <+> lbrace) 4 (vcat (map ppr ds)))
+ $$ rbrace
+
+-- --------------------------------------------------------------------------
+-- Info tables.
+
+pprInfoTable :: CmmInfoTable -> SDoc
+pprInfoTable CmmNonInfoTable = empty
+pprInfoTable (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info) =
+ vcat [ptext (sLit "has static closure: ") <> ppr stat_clos <+>
+ ptext (sLit "type: ") <> pprLit closure_type,
+ ptext (sLit "desc: ") <> pprLit closure_desc,
+ ptext (sLit "tag: ") <> integer (toInteger tag),
+ pprTypeInfo info]
+
+pprTypeInfo :: ClosureTypeInfo -> SDoc
+pprTypeInfo (ConstrInfo layout constr descr) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "constructor: ") <> integer (toInteger constr),
+ pprLit descr]
+pprTypeInfo (FunInfo layout srt arity _args slow_entry) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "srt: ") <> ppr srt,
+-- Temp Jan08
+ ptext (sLit ("fun_type: ")) <> integer (toInteger (argDescrType _args)),
+
+ ptext (sLit "arity: ") <> integer (toInteger arity),
+ --ptext (sLit "args: ") <> ppr args, -- TODO: needs to be printed
+ ptext (sLit "slow: ") <> pprLit slow_entry
+ ]
+pprTypeInfo (ThunkInfo layout srt) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger (fst layout)),
+ ptext (sLit "nptrs: ") <> integer (toInteger (snd layout)),
+ ptext (sLit "srt: ") <> ppr srt]
+pprTypeInfo (ThunkSelectorInfo offset srt) =
+ vcat [ptext (sLit "ptrs: ") <> integer (toInteger offset),
+ ptext (sLit "srt: ") <> ppr srt]
+pprTypeInfo (ContInfo stack srt) =
+ vcat [ptext (sLit "stack: ") <> ppr stack,
+ ptext (sLit "srt: ") <> ppr srt]
+
+-- Temp Jan08
+argDescrType :: ArgDescr -> StgHalfWord
+-- The "argument type" RTS field type
+argDescrType (ArgSpec n) = n
+argDescrType (ArgGen liveness)
+ | isBigLiveness liveness = ARG_GEN_BIG
+ | otherwise = ARG_GEN
+
+-- Temp Jan08
+isBigLiveness :: Liveness -> Bool
+isBigLiveness (BigLiveness _) = True
+isBigLiveness (SmallLiveness _) = False
+
+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--
+--
+pprStatic :: CmmStatic -> SDoc
+pprStatic s = case s of
+ CmmStaticLit lit -> nest 4 $ ptext (sLit "const") <+> pprLit lit <> semi
+ CmmUninitialised i -> nest 4 $ text "I8" <> brackets (int i)
+ CmmAlign i -> nest 4 $ text "align" <+> int i
+ CmmDataLabel clbl -> pprCLabel clbl <> colon
+ CmmString s' -> nest 4 $ text "I8[]" <+> text (show s')
+
+-- --------------------------------------------------------------------------
+-- data sections
+--
+pprSection :: Section -> SDoc
+pprSection s = case s of
+ 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"))
+ OtherSection s' -> section <+> doubleQuotes (text s')
+ where
+ section = ptext (sLit "section")
--- /dev/null
+----------------------------------------------------------------------------
+--
+-- 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.cminusminus.org/. 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 PprCmmExpr
+ ( pprExpr, pprLit
+ , pprExpr9 {-only to import in OldPprCmm. When it dies, remove the export -}
+ )
+where
+
+import CmmExpr
+import CLabel
+
+import Outputable
+import FastString
+
+import Data.Maybe
+
+-----------------------------------------------------------------------------
+
+instance Outputable CmmExpr where
+ ppr e = pprExpr e
+
+instance Outputable CmmReg where
+ ppr e = pprReg e
+
+instance Outputable CmmLit where
+ ppr l = pprLit l
+
+instance Outputable LocalReg where
+ ppr e = pprLocalReg e
+
+instance Outputable Area where
+ ppr e = pprArea e
+
+instance Outputable GlobalReg where
+ ppr e = pprGlobalReg e
+
+-- --------------------------------------------------------------------------
+-- Expressions
+--
+
+pprExpr :: CmmExpr -> SDoc
+pprExpr e
+ = case e of
+ CmmRegOff reg i ->
+ pprExpr (CmmMachOp (MO_Add rep)
+ [CmmReg reg, CmmLit (CmmInt (fromIntegral i) rep)])
+ where rep = typeWidth (cmmRegType reg)
+ CmmLit lit -> pprLit lit
+ _other -> pprExpr1 e
+
+-- Here's the precedence table from CmmParse.y:
+-- %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 :: CmmExpr -> SDoc
+pprExpr1 (CmmMachOp op [x,y]) | Just doc <- infixMachOp1 op
+ = pprExpr7 x <+> doc <+> pprExpr7 y
+pprExpr1 e = pprExpr7 e
+
+infixMachOp1, infixMachOp7, infixMachOp8 :: MachOp -> Maybe SDoc
+
+infixMachOp1 (MO_Eq _) = Just (ptext (sLit "=="))
+infixMachOp1 (MO_Ne _) = Just (ptext (sLit "!="))
+infixMachOp1 (MO_Shl _) = Just (ptext (sLit "<<"))
+infixMachOp1 (MO_U_Shr _) = Just (ptext (sLit ">>"))
+infixMachOp1 (MO_U_Ge _) = Just (ptext (sLit ">="))
+infixMachOp1 (MO_U_Le _) = Just (ptext (sLit "<="))
+infixMachOp1 (MO_U_Gt _) = Just (char '>')
+infixMachOp1 (MO_U_Lt _) = Just (char '<')
+infixMachOp1 _ = Nothing
+
+-- %left '-' '+'
+pprExpr7 (CmmMachOp (MO_Add rep1) [x, CmmLit (CmmInt i rep2)]) | i < 0
+ = pprExpr7 (CmmMachOp (MO_Sub rep1) [x, CmmLit (CmmInt (negate i) rep2)])
+pprExpr7 (CmmMachOp op [x,y]) | Just doc <- infixMachOp7 op
+ = pprExpr7 x <+> doc <+> pprExpr8 y
+pprExpr7 e = pprExpr8 e
+
+infixMachOp7 (MO_Add _) = Just (char '+')
+infixMachOp7 (MO_Sub _) = Just (char '-')
+infixMachOp7 _ = Nothing
+
+-- %left '/' '*' '%'
+pprExpr8 (CmmMachOp op [x,y]) | Just doc <- infixMachOp8 op
+ = pprExpr8 x <+> doc <+> pprExpr9 y
+pprExpr8 e = pprExpr9 e
+
+infixMachOp8 (MO_U_Quot _) = Just (char '/')
+infixMachOp8 (MO_Mul _) = Just (char '*')
+infixMachOp8 (MO_U_Rem _) = Just (char '%')
+infixMachOp8 _ = Nothing
+
+pprExpr9 :: CmmExpr -> SDoc
+pprExpr9 e =
+ case e of
+ CmmLit lit -> pprLit1 lit
+ CmmLoad expr rep -> ppr rep <> brackets( ppr 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 mop args
+
+genMachOp :: MachOp -> [CmmExpr] -> SDoc
+genMachOp mop args
+ | Just doc <- infixMachOp mop = case args of
+ -- dyadic
+ [x,y] -> pprExpr9 x <+> doc <+> pprExpr9 y
+
+ -- unary
+ [x] -> doc <> pprExpr9 x
+
+ _ -> pprTrace "PprCmm.genMachOp: machop with strange number of args"
+ (pprMachOp mop <+>
+ parens (hcat $ punctuate comma (map pprExpr args)))
+ empty
+
+ | isJust (infixMachOp1 mop)
+ || isJust (infixMachOp7 mop)
+ || isJust (infixMachOp8 mop) = parens (pprExpr (CmmMachOp mop args))
+
+ | otherwise = char '%' <> ppr_op <> parens (commafy (map pprExpr 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 :: CmmLit -> SDoc
+pprLit lit = case lit of
+ CmmInt i rep ->
+ hcat [ (if i < 0 then parens else id)(integer i)
+ , ppUnless (rep == wordWidth) $
+ space <> dcolon <+> ppr rep ]
+
+ CmmFloat f rep -> hsep [ rational f, dcolon, ppr rep ]
+ CmmLabel clbl -> pprCLabel clbl
+ CmmLabelOff clbl i -> pprCLabel clbl <> ppr_offset i
+ CmmLabelDiffOff clbl1 clbl2 i -> pprCLabel clbl1 <> char '-'
+ <> pprCLabel clbl2 <> ppr_offset i
+ CmmBlock id -> ppr id
+ CmmHighStackMark -> text "<highSp>"
+
+pprLit1 :: CmmLit -> SDoc
+pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit)
+pprLit1 lit = pprLit 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 '_' <> ppr uniq <>
+ (if isWord32 rep -- && not (isGcPtrType rep) -- Temp Jan08 -- sigh
+ then dcolon <> ptr <> ppr rep
+ else dcolon <> ptr <> ppr rep)
+ where
+ ptr = empty
+ --if isGcPtrType rep
+ -- then doubleQuotes (text "ptr")
+ -- else empty
+
+-- Stack areas
+pprArea :: Area -> SDoc
+pprArea (RegSlot r) = hcat [ text "slot<", ppr r, text ">" ]
+pprArea (CallArea id) = pprAreaId id
+
+pprAreaId :: AreaId -> SDoc
+pprAreaId Old = text "old"
+pprAreaId (Young id) = hcat [ text "young<", ppr id, text ">" ]
+
+-- needs to be kept in syn with CmmExpr.hs.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
+ Sp -> ptext (sLit "Sp")
+ SpLim -> ptext (sLit "SpLim")
+ Hp -> ptext (sLit "Hp")
+ HpLim -> ptext (sLit "HpLim")
+ CurrentTSO -> ptext (sLit "CurrentTSO")
+ CurrentNursery -> ptext (sLit "CurrentNursery")
+ HpAlloc -> ptext (sLit "HpAlloc")
+ EagerBlackholeInfo -> ptext (sLit "stg_EAGER_BLACKHOLE_info")
+ GCEnter1 -> ptext (sLit "stg_gc_enter_1")
+ GCFun -> ptext (sLit "stg_gc_fun")
+ BaseReg -> ptext (sLit "BaseReg")
+ PicBaseReg -> ptext (sLit "PicBaseReg")
+
+-----------------------------------------------------------------------------
+
+commafy :: [SDoc] -> SDoc
+commafy xs = fsep $ punctuate comma xs
+++ /dev/null
-
-module PprCmmZ
- ( pprCmmGraphLikeCmm
- )
-where
-
-import BlockId
-import Cmm
-import PprCmm
-import Outputable
-import qualified ZipCfgCmmRep as G
-import qualified ZipCfg as Z
-import CmmZipUtil
-
-import Data.Maybe
-import FastString
-
-----------------------------------------------------------------
--- | The purpose of this function is to print a Cmm zipper graph "as if it were"
--- a Cmm program. The objective is dodgy, so it's unsurprising parts of the
--- code are dodgy as well.
-
-pprCmmGraphLikeCmm :: G.CmmGraph -> SDoc
-pprCmmGraphLikeCmm g = vcat (swallow blocks)
- where blocks = Z.postorder_dfs g
- swallow :: [G.CmmBlock] -> [SDoc]
- swallow [] = []
- swallow (Z.Block id t : rest) = tail id [] Nothing t rest
- tail id prev' out (Z.ZTail m t) rest = tail id (mid m : prev') out t rest
- tail id prev' out (Z.ZLast (Z.LastOther l)) rest = last id prev' out l rest
- tail id prev' _ (Z.ZLast Z.LastExit) rest = exit id prev' rest
- mid m = ppr m
- block' id prev'
- | id == Z.lg_entry g, entry_has_no_pred =
- vcat (text "<entry>" : reverse prev')
- | otherwise = hang (ppr id <> colon) 4 (vcat (reverse prev'))
- last id prev' out l n =
- let endblock stmt = block' id (stmt : prev') : swallow n in
- case l of
- G.LastBranch tgt ->
- case n of
- Z.Block id' t : bs
- | tgt == id', unique_pred id'
- -> tail id prev' out t bs -- optimize out redundant labels
- _ -> endblock (ppr $ CmmBranch tgt)
- l@(G.LastCondBranch expr tid fid) ->
- let ft id = text "// fall through to " <> ppr id in
- case n of
- Z.Block id' t : bs
- | id' == fid, isNothing out ->
- tail id (ft fid : ppr (CmmCondBranch expr tid) : prev') Nothing t bs
- | id' == tid, Just e' <- maybeInvertCmmExpr expr, isNothing out->
- tail id (ft tid : ppr (CmmCondBranch e' fid) : prev') Nothing t bs
- _ -> endblock $ with_out out l
- l@(G.LastSwitch {}) -> endblock $ with_out out l
- l@(G.LastCall _ _ _ _ _) -> endblock $ with_out out l
- exit id prev' n = -- highly irregular (assertion violation?)
- let endblock stmt = block' id (stmt : prev') : swallow n in
- endblock (text "// <exit>")
- preds = zipPreds g
- entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of
- Nothing -> True
- Just s -> isEmptyBlockSet s
- single_preds =
- let add b single =
- let id = Z.blockId b
- in case lookupBlockEnv preds id of
- Nothing -> single
- Just s -> if sizeBlockSet s == 1 then
- extendBlockSet single id
- else single
- in Z.fold_blocks add emptyBlockSet g
- unique_pred id = elemBlockSet id single_preds
-
-with_out :: Maybe (G.Convention, CmmActuals) -> G.Last -> SDoc
-with_out Nothing l = ptext (sLit "??no-arguments??") <+> ppr l
-with_out (Just (conv, args)) l = last l
- where last (G.LastCall e k _ _ _) =
- hcat [ptext (sLit "... = foreign "),
- doubleQuotes(ppr conv), space,
- ppr_target e, parens ( commafy $ map ppr args ),
- ptext (sLit " \"safe\""),
- text " returns to " <+> ppr k,
- semi ]
- last l = ppr l
- ppr_target (CmmLit lit) = pprLit lit
- ppr_target fn' = parens (ppr fn')
- commafy xs = hsep $ punctuate comma xs
+++ /dev/null
-Sketch of the new arrivals:
-
- MkZipCfg Constructor functions for control-flow graphs.
- Not understandable in its entirety without reference
- to ZipCfg, but nevertheless a worthy starting point,
- as it is a good deal simpler than full ZipCfg.
- MkZipCfg is polymorphic in the types of middle and last
- nodes.
-
- ZipCfg Describes a zipper-like representation for true basic-block
- control-flow graphs. A block has a single entry point,
- which is a always a label, followed by zero or mode 'middle
- nodes', each of which represents an uninterruptible
- single-entry, single-exit computation, then finally a 'last
- node', which may have zero or more successors. A special
- 'exit node' is used for splicing together graphs.
-
- In addition to three representations of flow graphs, the
- module provides a surfeit of functions for observing and
- modifying graphs and related data:
- - Block IDs, sets and environments thereof
- - supply of fresh block IDS (as String -> UniqSM BlockId)
- - myriad functions for splicing graphs
- - postorder_dfs layout of blocks
- - folding, mapping, and translation functions
-
- ZipCFG is polymorphic in the type of middle and last nodes.
-
- CmmExpr Code for C-- expressions, which is shared among old and new
- representations of flow graphs. Of primary interest is the
- type class UserOfLocalRegs and its method foldRegsUsed,
- which is sufficiently overloaded to be used against
- expressions, statements, formals, hinted formals, and so
- on. This overloading greatly clarifies the computation of
- liveness as well as some other analyses.
-
- ZipCfgCmm Types to instantiate ZipCfg for C--: middle and last nodes,
- and a bunch of abbreviations of types in ZipCfg and Cmm.
- Also provides suitable constructor functions for building
- graphs from Cmm statements.
-
- CmmLiveZ A good example of a very simple dataflow analysis. It
- computes the set of live local registers at each point.
-
- DFMonad Support for dataflow analysis and dataflow-based
- transformation. This module needs work. Includes
- DataflowLattice - for tracking dataflow facts (good)
- DFM - monad for iterative dataflow analysis and rewriting (OK)
- DFTx - monad to track Whalley/Davidson transactions (ugly)
- type class DataflowAnalysis - operations common to DFA, DFM
- Some dodgy bits are
- subAnalysis, which may not be right
-
- ZipDataflow Iteratively solve forward and backward dataflow problems over
- flow graphs. Polymorphic in the type of graph and in the
- lattice of dataflow facts. Supports the incremental
- rewriting technique described by Lerner, Grove, and Chambers
- in POPL 2002. The code is a mess and is still being
- sorted out.
-
-
- CmmTx A simple monad for tracking when a transformation has
- occurred (something has changed).
-
- CmmCvt Converts between Cmm and ZipCfgCmm representations.
-
- CmmProcPointZ One module that performs three analyses and
- transformations:
-
- 1. Using Michael Adams's iterative algorithm, computes a
- minimal set of proc points that enable code to be
- generated without copying any basic blocks.
-
- 2. Assigns a protocol to each proc point. The assigner
- is rigged to enable the 'Adams optimization' whereby
- we attempt to eliminate return continuations by
- making procedures return directly to join points.
- Arguably this could be done by a separate rewriting
- pass to perform earlier.
-
- 3. Insert CopyIn and CopyOut nodes where needed
- according to the protocols.
-
- CmmSpillReload Inserts spills and reloads to establish the invariant that
- at a safe call, there are no live variables in registers.
-
- CmmCPSZ The CPS transformation so far.
-
- CmmContFlowOpt Branch-chain elimination and elimination of unreachable code.
-
- CmmOpt Changed optimization to use 'foldRegsUsed'; eliminated
- significant duplication of code.
-
- PprCmmZ Prettyprinting functions related to ZipCfg and ZipCfgCmm
+++ /dev/null
-
-module StackColor where
-
-import BlockId
-import StackPlacements
-import qualified GraphColor as Color
-import CmmExpr
-import CmmSpillReload
-import DFMonad
-import qualified GraphOps
-import ZipCfg
-import ZipCfgCmmRep
-import ZipDataflow
-
-import Maybes
-import Panic
-import UniqSet
-
--- import Data.List
-
-fold_edge_facts_b ::
- LastNode l => (DualLive -> a -> a) -> BackwardTransfers m l DualLive -> LGraph m l
- -> (BlockId -> DualLive) -> a -> a
-fold_edge_facts_b f comp graph env z =
- foldl fold_block_facts z (postorder_dfs graph)
- where
- fold_block_facts z b =
- let (h, l) = goto_end (ZipCfg.unzip b)
- last_in _ LastExit = fact_bot dualLiveLattice
- last_in env (LastOther l) = bt_last_in comp l env
- in head_fold h (last_in env l) z
- head_fold (ZHead h m) out z = head_fold h (bt_middle_in comp m out) (f out z)
- head_fold (ZFirst id) out z = f (bt_first_in comp id out) (f out z)
-
-foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a
-foldConflicts f z g@(LGraph entry _) =
- do env <- dualLiveness emptyBlockSet g
- let lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
- f' dual z = f (on_stack dual) z
- return $ fold_edge_facts_b f' (dualLiveTransfers entry emptyBlockSet) g lookup z
- --let env = runDFA dualLiveLattice (run_b_anal dualLiveness g >> getAllFacts)
- -- lookup id = lookupBlockEnv env id `orElse` fact_bot dualLiveLattice
- -- f' dual z = f (on_stack dual) z
- --in fold_edge_facts_b f' dualLiveness g lookup z
-
-
-type IGraph = Color.Graph LocalReg SlotClass StackPlacement
-type ClassCount = [(SlotClass, Int)]
-
-buildIGraphAndCounts :: LGraph Middle Last -> FuelMonad (IGraph, ClassCount)
-buildIGraphAndCounts g = igraph_and_counts
- where igraph_and_counts = foldConflicts add (Color.initGraph, zero) g
- zero = map (\c -> (c, 0)) allSlotClasses
- add live (igraph, counts) = (graphAddConflictSet live igraph,
- addSimulCounts (classCounts live) counts)
- addSimulCounts =
- zipWith (\(c, n) (c', n') -> if c == c' then (c, max n n')
- else panic "slot classes out of order")
- classCounts regs = foldUniqSet addReg zero regs
- addReg reg counts =
- let cls = slotClass reg in
- map (\(c, n) -> (c, if c == cls then n + 1 else n)) counts
-
-
--- | Add some conflict edges to the graph.
--- Conflicts between virtual and real regs are recorded as exclusions.
---
-
-graphAddConflictSet :: RegSet -> IGraph -> IGraph
-graphAddConflictSet set graph = GraphOps.addConflicts set slotClass graph
-
-slotClass :: LocalReg -> SlotClass
-slotClass (LocalReg _ ty) =
- case typeWidth ty of -- the horror, the horror
- W8 -> SlotClass32
- W16 -> SlotClass32
- W32 -> SlotClass32
- W64 -> SlotClass64
- W128 -> SlotClass128
- W80 -> SlotClass64
-
-{-
-colorMe :: (IGraph, ClassCount) -> (IGraph, UniqSet LocalReg)
-colorMe (igraph, counts) = Color.colorGraph starter_colors triv spill_max_degree igraph
- where starter_colors = allocate [] counts allStackSlots
- allocate prev [] colors = insert prev colors
- allocate prev ((c, n) : counts) colors =
- let go prev 0 colors = allocate prev counts colors
- go prev n colors = let (p, colors') = getStackSlot c colors in
- go (p:prev) (n-1) colors'
- in go prev n colors
- insert :: [StackPlacement] -> SlotSet -> SlotSet
- insert [] colors = colors
- insert (p:ps) colors = insert ps (extendSlotSet colors p)
- triv :: Color.Triv LocalReg SlotClass StackPlacement
- triv = trivColorable (mkSizeOf counts)
-
-spill_max_degree :: IGraph -> LocalReg
-spill_max_degree igraph = Color.nodeId node
- where node = maximumBy (\n1 n2 -> compare
- (sizeUniqSet $ Color.nodeConflicts n1)
- (sizeUniqSet $ Color.nodeConflicts n2)) $
- eltsUFM $ Color.graphMap igraph
-
-
-type Worst = SlotClass -> (Int, Int, Int) -> Int
-
-trivColorable :: (SlotClass -> Int) ->
- SlotClass -> UniqSet LocalReg -> UniqSet StackPlacement -> Bool
-trivColorable sizeOf classN conflicts exclusions = squeeze < sizeOf classN
- where squeeze = worst classN counts
- counts = if isEmptyUniqSet exclusions then foldUniqSet acc zero conflicts
- else panic "exclusions in stack slots?!"
- zero = (0, 0, 0)
- acc r (word, dbl, quad) =
- case slotClass r of
- SlotClass32 -> (word+1, dbl, quad)
- SlotClass64 -> (word, dbl+1, quad)
- SlotClass128 -> (word, dbl, quad+1)
- worst SlotClass128 (_, _, q) = q
- worst SlotClass64 (_, d, q) = d + 2 * q
- worst SlotClass32 (w, d, q) = w + 2 * d + 4 * q
--}
-
--- | number of placements available is from class and all larger classes
-mkSizeOf :: ClassCount -> (SlotClass -> Int)
-mkSizeOf counts = sizeOf
- where sizeOf SlotClass32 = n32
- sizeOf SlotClass64 = n64
- sizeOf SlotClass128 = n128
- n128 = (lookup SlotClass128 counts `orElse` 0)
- n64 = (lookup SlotClass64 counts `orElse` 0) + 2 * n128
- n32 = (lookup SlotClass32 counts `orElse` 0) + 2 * n32
+++ /dev/null
-
-module StackPlacements
- ( SlotSet, allStackSlots -- the infinite set of stack slots
- , SlotClass(..), slotClassBits, stackSlot32, stackSlot64, stackSlot128
- , allSlotClasses
- , getStackSlot, extendSlotSet, deleteFromSlotSet, elemSlotSet, chooseSlot
- , StackPlacement(..)
- )
-where
-
-import Maybes
-import Outputable
-import Unique
-
-import Prelude hiding (pi)
-import Data.List
-
-{-
-
-The goal here is to provide placements on the stack that will allow,
-for example, two 32-bit words to spill to a slot previously used by a
-64-bit floating-point value. I use a simple buddy-system allocator
-that splits large slots in half as needed; this will work fine until
-the day when somebody wants to spill an 80-bit Intel floating-point
-register into the Intel standard 96-bit stack slot.
-
--}
-
-data SlotClass = SlotClass32 | SlotClass64 | SlotClass128
- deriving (Eq)
-
-instance Uniquable SlotClass where
- getUnique = getUnique . slotClassBits
-
-instance Outputable SlotClass where
- ppr cls = text "class of" <+> int (slotClassBits cls) <> text "-bit stack slots"
-
-slotClassBits :: SlotClass -> Int
-slotClassBits SlotClass32 = 32
-slotClassBits SlotClass64 = 64
-slotClassBits SlotClass128 = 128
-
-data StackPlacement = FullSlot SlotClass Int
- | YoungHalf StackPlacement
- | OldHalf StackPlacement
- deriving (Eq)
-
-data OneSize = OneSize { full_slots :: [StackPlacement], fragments :: [StackPlacement] }
- -- ^ Always used for slots that have been previously used
-
-data SlotSet = SlotSet { s32, s64, s128 :: OneSize, next_unused :: Int }
-
-allStackSlots :: SlotSet
-allStackSlots = SlotSet empty empty empty 0
- where empty = OneSize [] []
-
-
-psize :: StackPlacement -> Int
-psize (FullSlot cls _) = slotClassBits cls
-psize (YoungHalf p) = psize p `div` 2
-psize (OldHalf p) = psize p `div` 2
-
-
-
-
--- | Get a slot no matter what
-get32, get64, get128 :: SlotSet -> (StackPlacement, SlotSet)
-
--- | Get a previously used slot if one exists
-getu32, getu64, getu128 :: SlotSet -> Maybe (StackPlacement, SlotSet)
-
--- | Only supported slot classes
-
-stackSlot32, stackSlot64, stackSlot128 :: SlotClass
-stackSlot32 = SlotClass32
-stackSlot64 = SlotClass64
-stackSlot128 = SlotClass128
-
-allSlotClasses :: [SlotClass]
-allSlotClasses = [stackSlot32, stackSlot64, stackSlot128]
-
--- | Get a fresh slot, never before used
-getFull :: SlotClass -> SlotSet -> (StackPlacement, SlotSet)
-
-infixr 4 |||
-
-(|||) :: (SlotSet -> Maybe (StackPlacement, SlotSet)) ->
- (SlotSet -> (StackPlacement, SlotSet)) ->
- (SlotSet -> (StackPlacement, SlotSet))
-
-f1 ||| f2 = \slots -> f1 slots `orElse` f2 slots
-
-getFull cls slots = (FullSlot cls n, slots { next_unused = n + 1 })
- where n = next_unused slots
-
-get32 = getu32 ||| (fmap split64 . getu64) ||| getFull stackSlot32
-get64 = getu64 ||| (fmap split128 . getu128) ||| getFull stackSlot64
-get128 = getu128 ||| getFull stackSlot128
-
-type SizeGetter = SlotSet -> OneSize
-type SizeSetter = OneSize -> SlotSet -> SlotSet
-
-upd32, upd64, upd128 :: SizeSetter
-upd32 this_size slots = slots { s32 = this_size }
-upd64 this_size slots = slots { s64 = this_size }
-upd128 this_size slots = slots { s128 = this_size }
-
-with_size :: Int -> (SizeGetter -> SizeSetter -> a) -> a
-with_size 32 = with_32
-with_size 64 = with_64
-with_size 128 = with_128
-with_size _ = panic "non-standard slot size -- error in size computation?"
-
-with_32, with_64, with_128 :: (SizeGetter -> SizeSetter -> a) -> a
-with_32 f = f s32 upd32
-with_64 f = f s64 upd64
-with_128 f = f s128 upd128
-
-getu32 = with_32 getUsed
-getu64 = with_64 getUsed
-getu128 = with_128 getUsed
-
-getUsed :: SizeGetter -> SizeSetter -> SlotSet -> Maybe (StackPlacement, SlotSet)
-getUsed get set slots =
- let this_size = get slots in
- case full_slots this_size of
- p : ps -> Just (p, set (this_size { full_slots = ps }) slots)
- [] -> case fragments this_size of
- p : ps -> Just (p, set (this_size { fragments = ps }) slots)
- [] -> Nothing
-
--- | When splitting, allocate the old half first in case it makes the
--- stack smaller at a call site.
-split64, split128 :: (StackPlacement, SlotSet) -> (StackPlacement, SlotSet)
-split64 (p, slots) = (OldHalf p, slots { s32 = cons_frag (YoungHalf p) (s32 slots) })
-split128 (p, slots) = (OldHalf p, slots { s64 = cons_frag (YoungHalf p) (s64 slots) })
-
-cons_frag :: StackPlacement -> OneSize -> OneSize
-cons_frag p this_size = this_size { fragments = p : fragments this_size }
-
-
-----------------------------
-instance Outputable StackPlacement where
- ppr (FullSlot cls n) = int (slotClassBits cls) <> text "-bit slot " <> int n
- ppr (YoungHalf p) = text "young half of" <+> ppr p
- ppr (OldHalf p) = text "old half of" <+> ppr p
-
-instance Outputable SlotSet where
- ppr slots = fsep $ punctuate comma
- (pprSlots (s32 slots) ++ pprSlots (s64 slots) ++ pprSlots (s128 slots) ++
- [text "and slots numbered" <+> int (next_unused slots)
- <+> text "and up"])
- where pprSlots (OneSize w fs) = map ppr w ++ map ppr fs
-
-{-
-instance ColorSet SlotSet SlotClass StackPlacement where
- emptyColorSet = panic "The set of stack slots is never empty"
- deleteFromColorSet = deleteFromSlotSet
- extendColorSet slots (cls, p@(FullSlot {})) =
- with_size (slotClassBits cls) add_full p (pi slots)
- extendColorSet slots (cls, p) = with_size (slotClassBits cls) add_frag p (pi slots)
- chooseColor = chooseSlot
--}
-
-deleteFromSlotSet :: StackPlacement -> SlotSet -> SlotSet
-deleteFromSlotSet p@(FullSlot {}) slots = with_size (psize p) remove_full p (pi slots)
-deleteFromSlotSet p slots = with_size (psize p) remove_frag p (pi slots)
-
-extendSlotSet :: SlotSet -> StackPlacement -> SlotSet
-extendSlotSet slots p@(FullSlot {}) = with_size (psize p) add_full p (pi slots)
-extendSlotSet slots p = with_size (psize p) add_frag p (pi slots)
-
-elemSlotSet :: StackPlacement -> SlotSet -> Bool
-elemSlotSet p@(FullSlot {}) slots = with_size (psize p) elem_full p slots
-elemSlotSet p slots = with_size (psize p) elem_frag p slots
-
-remove_full, remove_frag, add_full, add_frag
- :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> SlotSet
-
-remove_full get set p slots = set p' slots
- where this_size = get slots
- p' = this_size { full_slots = delete p $ full_slots this_size }
-
-remove_frag get set p slots = set p' slots
- where this_size = get slots
- p' = this_size { full_slots = delete p $ full_slots this_size }
-
-add_full get set p slots = set p' slots
- where this_size = get slots
- p' = this_size { full_slots = add p $ full_slots this_size }
-
-add_frag get set p slots = set p' slots
- where this_size = get slots
- p' = this_size { full_slots = add p $ full_slots this_size }
-
-add :: Eq a => a -> [a] -> [a]
-add x xs = if notElem x xs then x : xs else xs
-
-elem_full, elem_frag :: SizeGetter -> SizeSetter -> StackPlacement -> SlotSet -> Bool
-elem_full get _set p slots = elem p (full_slots $ get slots)
-elem_frag get _set p slots = elem p (fragments $ get slots)
-
-
-
-
-getStackSlot :: SlotClass -> SlotSet -> (StackPlacement, SlotSet)
-getStackSlot cls slots =
- case cls of
- SlotClass32 -> get32 (pi slots)
- SlotClass64 -> get64 (pi slots)
- SlotClass128 -> get128 (pi slots)
-
-
-chooseSlot :: SlotClass -> [StackPlacement] -> SlotSet -> Maybe (StackPlacement, SlotSet)
-chooseSlot cls prefs slots =
- case filter (flip elemSlotSet slots) prefs of
- placement : _ -> Just (placement, deleteFromSlotSet placement (pi slots))
- [] -> Just (getStackSlot cls slots)
-
-check_invariant :: Bool
-check_invariant = True
-
-pi :: SlotSet -> SlotSet
-pi = if check_invariant then panic_on_invariant_violation else id
-
-panic_on_invariant_violation :: SlotSet -> SlotSet
-panic_on_invariant_violation slots =
- check 32 (s32 slots) $ check 64 (s64 slots) $ check 128 (s128 slots) $ slots
- where n = next_unused slots
- check bits this_size = (check_full bits $ full_slots this_size) .
- (check_frag bits $ fragments this_size)
- check_full _ [] = id
- check_full bits (FullSlot cls k : ps) =
- if slotClassBits cls /= bits then panic "slot in bin of wrong size"
- else if k >= n then panic "slot number is unreasonably fresh"
- else check_full bits ps
- check_full _ _ = panic "a fragment is in a bin reserved for full slots"
- check_frag _ [] = id
- check_frag _ (FullSlot {} : _) =
- panic "a full slot is in a bin reserved for fragments"
- check_frag bits (p : ps) =
- if bits /= psize p then panic "slot in bin of wrong size"
- else if pnumber p >= n then panic "slot number is unreasonably fresh"
- else check_frag bits ps
- pnumber (FullSlot _ k) = k
- pnumber (YoungHalf p) = pnumber p
- pnumber (OldHalf p) = pnumber p
-
+++ /dev/null
-module ZipCfg
- ( -- These data types and names are carefully thought out
- Graph(..), LGraph(..), FGraph(..)
- , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..)
- , insertBlock
- , HavingSuccessors, succs, fold_succs
- , LastNode, mkBranchNode, isBranchNode, branchNodeTarget
-
- -- Observers and transformers
- -- (open to renaming suggestions here)
- , blockId, zip, unzip, last, goto_end, zipht, tailOfLast
- , splice_tail, splice_head, splice_head_only', splice_head'
- , of_block_list, to_block_list
- , graphOfLGraph
- , map_blocks, map_one_block, map_nodes, mapM_blocks
- , postorder_dfs, postorder_dfs_from, postorder_dfs_from_except
- , fold_layout
- , fold_blocks, fold_fwd_block
- , translate
-
- , pprLgraph, pprGraph
-
- , entry -- exported for the convenience of ZipDataflow0, at least for now
-
- {-
- -- the following functions might one day be useful and can be found
- -- either below or in ZipCfgExtras:
- , entry, exit, focus, focusp, unfocus
- , ht_to_block, ht_to_last,
- , splice_focus_entry, splice_focus_exit
- , foldM_fwd_block
- -}
-
- )
-where
-
-#include "HsVersions.h"
-
-import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv
- , BlockSet, emptyBlockSet, unitBlockSet, elemBlockSet, extendBlockSet
- , delFromBlockEnv, foldBlockEnv', mapBlockEnv
- , eltsBlockEnv, isNullBEnv, plusBlockEnv)
-import CmmExpr ( UserOfLocalRegs(..) )
-import PprCmm()
-
-import Outputable hiding (empty)
-
-import Data.Maybe
-import Prelude hiding (zip, unzip, last)
-
--------------------------------------------------------------------------
--- GENERIC ZIPPER-BASED CONTROL-FLOW GRAPH --
--------------------------------------------------------------------------
-{-
-
-This module defines datatypes used to represent control-flow graphs,
-along with some functions for analyzing and splicing graphs.
-Functions for building graphs are found in a separate module 'MkZipCfg'.
-
-Every graph has a distinguished entry point. A graph has at least one
-exit; most exits are instructions (or statements) like 'jump' or
-'return', which transfer control to other procedures, but a graph may
-have up to one 'fall through' exit. (A graph that represents an
-entire Haskell or C-- procedure does not have a 'fall through' exit.)
-
-A graph is a collection of basic blocks. A basic block begins with a
-label (unique id; see Note [Unique BlockId]) which is followed by a
-sequence of zero or more 'middle' nodes; the basic block ends with a
-'last' node. Each 'middle' node is a single-entry, single-exit,
-uninterruptible computation. A 'last' node is a single-entry,
-multiple-exit computation. A last node may have zero or more successors,
-which are identified by their unique ids.
-
-A special case of last node is the ``default exit,'' which represents
-'falling off the end' of the graph. Such a node is always represented by
-the data constructor 'LastExit'. A graph may contain at most one
-'LastExit' node, and a graph representing a full procedure should not
-contain any 'LastExit' nodes. 'LastExit' nodes are used only to splice
-graphs together, either during graph construction (see module 'MkZipCfg')
-or during optimization (see module 'ZipDataflow').
-
-A graph is parameterized over the types of middle and last nodes. Each of
-these types will typically be instantiated with a subset of C-- statements
-(see module 'ZipCfgCmmRep') or a subset of machine instructions (yet to be
-implemented as of August 2007).
-
-
-Note [Kinds of Graphs]
-~~~~~~~~~~~~~~~~~~~~~~
-This module exposes three representations of graphs. In order of
-increasing complexity, they are:
-
- Graph m l The basic graph with its distinguished entry point
-
- LGraph m l A graph with a *labelled* entry point
-
- FGraph m l A labelled graph with the *focus* on a particular edge
-
-There are three types because each type offers a slightly different
-invariant or cost model.
-
- * The distinguished entry of a Graph has no label. Because labels must be
- unique, acquiring one requires a supply of Unique labels (BlockId's).
- The primary advantage of the Graph representation is that we can build a
- small Graph purely functionally, without needing a fresh BlockId or
- Unique. For example, during optimization we can easily rewrite a single
- middle node into a Graph containing a sequence of two middle nodes
- followed by LastExit.
-
- * In an LGraph, every basic block is labelled. The primary advantage of
- this representation is its simplicity: each basic block can be treated
- like any other. This representation is used for mapping, folding, and
- translation, as well as layout.
-
- Like any graph, an LGraph still has a distinguished entry point,
- which you can discover using 'lg_entry'.
-
- * An FGraph is an LGraph with the *focus* on one particular edge. The
- primary advantage of this representation is that it provides
- constant-time access to the nodes connected by that edge, and it also
- allows constant-time, functional *replacement* of those nodes---in the
- style of Huet's 'zipper'.
-
-None of these representations is ideally suited to the incremental
-construction of large graphs. A separate module, 'MkZipCfg', provides a
-fourth representation that is asymptotically optimal for such construction.
-
--}
-
---------------- Representation --------------------
-
--- | A basic block is a 'first' node, followed by zero or more 'middle'
--- nodes, followed by a 'last' node.
-
--- eventually this module should probably replace the original Cmm, but for
--- now we leave it to dynamic invariants what can be found where
-
-data ZLast l
- = LastExit -- fall through; used for the block that has no last node
- -- LastExit is a device used only for graphs under
- -- construction, or framgments of graph under optimisation,
- -- so we don't want to pollute the 'l' type parameter with it
- | LastOther l
-
---So that we don't have orphan instances, this goes here or in CmmExpr.
---At least UserOfLocalRegs (ZLast Last) is needed (Last defined elsewhere),
---but there's no need for non-Haskell98 instances for that.
-instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where
- foldRegsUsed f z (LastOther l) = foldRegsUsed f z l
- foldRegsUsed _f z LastExit = z
-
-
-data ZHead m = ZFirst BlockId
- | ZHead (ZHead m) m
- -- ZHead is a (reversed) sequence of middle nodes labeled by a BlockId
-data ZTail m l = ZLast (ZLast l) | ZTail m (ZTail m l)
- -- ZTail is a sequence of middle nodes followed by a last node
-
--- | Blocks and flow graphs; see Note [Kinds of graphs]
-
-data Block m l = Block { bid :: BlockId
- , tail :: ZTail m l }
-
-data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) }
-
-data LGraph m l = LGraph { lg_entry :: BlockId
- , lg_blocks :: BlockEnv (Block m l)}
- -- Invariant: lg_entry is in domain( lg_blocks )
-
--- | And now the zipper. The focus is between the head and tail.
--- We cannot ever focus on an inter-block edge.
-data ZBlock m l = ZBlock (ZHead m) (ZTail m l)
-data FGraph m l = FGraph { fg_entry :: BlockId
- , fg_focus :: ZBlock m l
- , fg_others :: BlockEnv (Block m l) }
- -- Invariant: the block represented by 'fg_focus' is *not*
- -- in the map 'fg_others'
-
----- Utility functions ---
-
-blockId :: Block m l -> BlockId
-zip :: ZBlock m l -> Block m l
-unzip :: Block m l -> ZBlock m l
-
-last :: ZBlock m l -> ZLast l
-goto_end :: ZBlock m l -> (ZHead m, ZLast l)
-
-tailOfLast :: l -> ZTail m l
-
--- | Take a head and tail and go to beginning or end. The asymmetry
--- in the types and names is a bit unfortunate, but 'Block m l' is
--- effectively '(BlockId, ZTail m l)' and is accepted in many more places.
-
-ht_to_block, zipht :: ZHead m -> ZTail m l -> Block m l
-ht_to_last :: ZHead m -> ZTail m l -> (ZHead m, ZLast l)
-
--- | We can splice a single-entry, single-exit LGraph onto a head or a tail.
--- For a head, we have a head 'h' followed by a LGraph 'g'.
--- The entry node of 'g' gets joined to 'h', forming the entry into
--- the new LGraph. The exit of 'g' becomes the new head.
--- For both arguments and results, the order of values is the order of
--- control flow: before splicing, the head flows into the LGraph; after
--- splicing, the LGraph flows into the head.
--- Splicing a tail is the dual operation.
--- (In order to maintain the order-means-control-flow convention, the
--- orders are reversed.)
---
--- For example, assume
--- head = [L: x:=0]
--- grph = (M, [M: <stuff>,
--- <blocks>,
--- N: y:=x; LastExit])
--- tail = [return (y,x)]
---
--- Then splice_head head grph
--- = ((L, [L: x:=0; goto M,
--- M: <stuff>,
--- <blocks>])
--- , N: y:=x)
---
--- Then splice_tail grph tail
--- = ( <stuff>
--- , (???, [<blocks>,
--- N: y:=x; return (y,x)])
-
-splice_head :: ZHead m -> LGraph m l -> (LGraph m l, ZHead m)
-splice_head' :: ZHead m -> Graph m l -> (BlockEnv (Block m l), ZHead m)
-splice_tail :: Graph m l -> ZTail m l -> Graph m l
-
--- | We can also splice a single-entry, no-exit Graph into a head.
-splice_head_only :: ZHead m -> LGraph m l -> LGraph m l
-splice_head_only' :: ZHead m -> Graph m l -> LGraph m l
-
-
--- | A safe operation
-
--- | Conversion to and from the environment form is convenient. For
--- layout or dataflow, however, one will want to use 'postorder_dfs'
--- in order to get the blocks in an order that relates to the control
--- flow in the procedure.
-of_block_list :: BlockId -> [Block m l] -> LGraph m l -- N log N
-to_block_list :: LGraph m l -> [Block m l] -- N log N
-
--- | Conversion from LGraph to Graph
-graphOfLGraph :: LastNode l => LGraph m l -> Graph m l
-graphOfLGraph (LGraph eid blocks) = Graph (ZLast $ mkBranchNode eid) blocks
-
-
--- | Traversal: 'postorder_dfs' returns a list of blocks reachable
--- from the entry node. This list has the following property:
---
--- Say a "back reference" exists if one of a block's
--- control-flow successors precedes it in the output list
---
--- Then there are as few back references as possible
---
--- The output is suitable for use in
--- a forward dataflow problem. For a backward problem, simply reverse
--- the list. ('postorder_dfs' is sufficiently tricky to implement that
--- one doesn't want to try and maintain both forward and backward
--- versions.)
-
-postorder_dfs :: LastNode l => LGraph m l -> [Block m l]
-
--- | For layout, we fold over pairs of 'Block m l' and 'Maybe BlockId'
--- in layout order. The 'Maybe BlockId', if present, identifies the
--- block that will be the layout successor of the current block. This
--- may be useful to help an emitter omit the final 'goto' of a block
--- that flows directly to its layout successor.
---
--- For example: fold_layout f z [ L1:B1, L2:B2, L3:B3 ]
--- = z <$> f (L1:B1) (Just L2)
--- <$> f (L2:B2) (Just L3)
--- <$> f (L3:B3) Nothing
--- where a <$> f = f a
-fold_layout ::
- LastNode l => (Block m l -> Maybe BlockId -> a -> a) -> a -> LGraph m l-> a
-
--- | We can also fold over blocks in an unspecified order. The
--- 'ZipCfgExtras' module provides a monadic version, which we
--- haven't needed (else it would be here).
-fold_blocks :: (Block m l -> a -> a) -> a -> LGraph m l -> a
-
--- | Fold from first to last
-fold_fwd_block :: (BlockId -> a -> a) -> (m -> a -> a) ->
- (ZLast l -> a -> a) -> Block m l -> a -> a
-
-map_one_block :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> Block m l -> Block m' l'
-
-map_nodes :: (BlockId -> BlockId) -> (m -> m') -> (l -> l') -> LGraph m l -> LGraph m' l'
- -- mapping includes the entry id!
-
-map_blocks :: (Block m l -> Block m' l') -> LGraph m l -> LGraph m' l'
-mapM_blocks :: Monad mm
- => (Block m l -> mm (Block m' l')) -> LGraph m l -> mm (LGraph m' l')
-
--- | These translation functions are speculative. I hope eventually
--- they will be used in the native-code back ends ---NR
-translate :: Monad tm =>
- (m -> tm (LGraph m' l')) ->
- (l -> tm (LGraph m' l')) ->
- (LGraph m l -> tm (LGraph m' l'))
-
-{-
--- | It's possible that another form of translation would be more suitable:
-translateA :: (m -> Agraph m' l') -> (l -> AGraph m' l') -> LGraph m l -> LGraph m' l'
--}
-
-------------------- Last nodes
-
--- | We can't make a graph out of just any old 'last node' type. A last node
--- has to be able to find its successors, and we need to be able to create and
--- identify unconditional branches. We put these capabilities in a type class.
--- Moreover, the property of having successors is also shared by 'Block's and
--- 'ZTails', so it is useful to have that property in a type class of its own.
-
-class HavingSuccessors b where
- succs :: b -> [BlockId]
- fold_succs :: (BlockId -> a -> a) -> b -> a -> a
-
- fold_succs add l z = foldr add z $ succs l
-
-class HavingSuccessors l => LastNode l where
- mkBranchNode :: BlockId -> l
- isBranchNode :: l -> Bool
- branchNodeTarget :: l -> BlockId -- panics if not branch node
- -- ^ N.B. This interface seems to make for more congenial clients than a
- -- single function of type 'l -> Maybe BlockId'
-
-instance HavingSuccessors l => HavingSuccessors (ZLast l) where
- succs LastExit = []
- succs (LastOther l) = succs l
- fold_succs _ LastExit z = z
- fold_succs f (LastOther l) z = fold_succs f l z
-
-instance LastNode l => LastNode (ZLast l) where
- mkBranchNode id = LastOther $ mkBranchNode id
- isBranchNode LastExit = False
- isBranchNode (LastOther l) = isBranchNode l
- branchNodeTarget LastExit = panic "branchNodeTarget LastExit"
- branchNodeTarget (LastOther l) = branchNodeTarget l
-
-instance LastNode l => HavingSuccessors (ZBlock m l) where
- succs b = succs (last b)
-
-instance LastNode l => HavingSuccessors (Block m l) where
- succs b = succs (unzip b)
-
-instance LastNode l => HavingSuccessors (ZTail m l) where
- succs b = succs (lastTail b)
-
-
-
--- ================ IMPLEMENTATION ================--
-
------ block manipulations
-
-blockId (Block id _) = id
-
--- | Convert block between forms.
--- These functions are tail-recursive, so we can go as deep as we like
--- without fear of stack overflow.
-
-ht_to_block head tail = case head of
- ZFirst id -> Block id tail
- ZHead h m -> ht_to_block h (ZTail m tail)
-
-ht_to_last head (ZLast l) = (head, l)
-ht_to_last head (ZTail m t) = ht_to_last (ZHead head m) t
-
-zipht h t = ht_to_block h t
-zip (ZBlock h t) = ht_to_block h t
-goto_end (ZBlock h t) = ht_to_last h t
-
-unzip (Block id t) = ZBlock (ZFirst id) t
-
-head_id :: ZHead m -> BlockId
-head_id (ZFirst id) = id
-head_id (ZHead h _) = head_id h
-
-last (ZBlock _ t) = lastTail t
-
-lastTail :: ZTail m l -> ZLast l
-lastTail (ZLast l) = l
-lastTail (ZTail _ t) = lastTail t
-
-tailOfLast l = ZLast (LastOther l) -- tedious to write in every client
-
-
------------------- simple graph manipulations
-
-focus :: BlockId -> LGraph m l -> FGraph m l -- focus on edge out of node with id
-focus id (LGraph entry blocks) =
- case lookupBlockEnv blocks id of
- Just b -> FGraph entry (unzip b) (delFromBlockEnv blocks id)
- Nothing -> panic "asked for nonexistent block in flow graph"
-
-entry :: LGraph m l -> FGraph m l -- focus on edge out of entry node
-entry g@(LGraph eid _) = focus eid g
-
--- | pull out a block satisfying the predicate, if any
-splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
- Maybe (Block m l, BlockEnv (Block m l))
-splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks
- where scan b (yes, no) =
- case yes of
- Nothing | p b -> (Just b, no)
- | otherwise -> (yes, insertBlock b no)
- Just _ -> (yes, insertBlock b no)
- lift (Nothing, _) = Nothing
- lift (Just b, bs) = Just (b, bs)
-
--- | 'insertBlock' should not be used to /replace/ an existing block
--- but only to insert a new one
-insertBlock :: Block m l -> BlockEnv (Block m l) -> BlockEnv (Block m l)
-insertBlock b bs =
- ASSERT (isNothing $ lookupBlockEnv bs id)
- extendBlockEnv bs id b
- where id = blockId b
-
--- | Used in assertions; tells if a graph has exactly one exit
-single_exit :: LGraph l m -> Bool
-single_exit g = foldBlockEnv' check 0 (lg_blocks g) == 1
- where check block count = case last (unzip block) of
- LastExit -> count + (1 :: Int)
- _ -> count
-
--- | Used in assertions; tells if a graph has exactly one exit
-single_exitg :: Graph l m -> Bool
-single_exitg (Graph tail blocks) = foldBlockEnv' add (exit_count (lastTail tail)) blocks == 1
- where add block count = count + exit_count (last (unzip block))
- exit_count LastExit = 1 :: Int
- exit_count _ = 0
-
------------------- graph traversals
-
--- | This is the most important traversal over this data structure. It drops
--- unreachable code and puts blocks in an order that is good for solving forward
--- dataflow problems quickly. The reverse order is good for solving backward
--- dataflow problems quickly. The forward order is also reasonably good for
--- emitting instructions, except that it will not usually exploit Forrest
--- Baskett's trick of eliminating the unconditional branch from a loop. For
--- that you would need a more serious analysis, probably based on dominators, to
--- identify loop headers.
---
--- The ubiquity of 'postorder_dfs' is one reason for the ubiquity of the 'LGraph'
--- representation, when for most purposes the plain 'Graph' representation is
--- more mathematically elegant (but results in more complicated code).
---
--- Here's an easy way to go wrong! Consider
--- @
--- A -> [B,C]
--- B -> D
--- C -> D
--- @
--- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D.
--- Better to get [A,B,C,D]
-
-
-postorder_dfs g@(LGraph _ blockenv) =
- let FGraph id eblock _ = entry g in
- zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id)
-
-postorder_dfs_from_except :: forall m b l. (HavingSuccessors b, LastNode l)
- => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l]
-postorder_dfs_from_except blocks b visited
- = vchildren (get_children b) (\acc _visited -> acc) [] visited
- where
- vnode :: Block m l -> ([Block m l] -> BlockSet -> a)
- -> [Block m l] -> BlockSet -> a
- vnode block@(Block id _) cont acc visited =
- if elemBlockSet id visited then
- cont acc visited
- else
- let cont' acc visited = cont (block:acc) visited in
- vchildren (get_children block) cont' acc (extendBlockSet visited id)
-
- vchildren :: [Block m l] -> ([Block m l] -> BlockSet -> a)
- -> [Block m l] -> BlockSet -> a
- vchildren bs cont acc visited =
- let next children acc visited =
- case children of [] -> cont acc visited
- (b:bs) -> vnode b (next bs) acc visited
- in next bs acc visited
-
- get_children :: HavingSuccessors c => c -> [Block m l]
- get_children block = foldl add_id [] (succs block)
-
- add_id :: [Block m l] -> BlockId -> [Block m l]
- add_id rst id = case lookupBlockEnv blocks id of
- Just b -> b : rst
- Nothing -> rst
-
-postorder_dfs_from
- :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> [Block m l]
-postorder_dfs_from blocks b = postorder_dfs_from_except blocks b emptyBlockSet
-
-
-
--- | Slightly more complicated than the usual fold because we want to tell block
--- 'b1' what its inline successor is going to be, so that if 'b1' ends with
--- 'goto b2', the goto can be omitted.
-
-fold_layout f z g@(LGraph eid _) = fold (postorder_dfs g) z
- where fold blocks z =
- case blocks of [] -> z
- [b] -> f b Nothing z
- b1 : b2 : bs -> fold (b2 : bs) (f b1 (nextlabel b2) z)
- nextlabel (Block id _) =
- if id == eid then panic "entry as successor"
- else Just id
-
--- | The rest of the traversals are straightforward
-
-map_blocks f (LGraph eid blocks) = LGraph eid (mapBlockEnv f blocks)
-
-map_nodes idm middle last (LGraph eid blocks) =
- LGraph (idm eid) (mapBlockEnv (map_one_block idm middle last) blocks)
-
-map_one_block idm middle last (Block id t) = Block (idm id) (tail t)
- where tail (ZTail m t) = ZTail (middle m) (tail t)
- tail (ZLast LastExit) = ZLast LastExit
- tail (ZLast (LastOther l)) = ZLast (LastOther (last l))
-
-
-mapM_blocks f (LGraph eid blocks) = blocks' >>= return . LGraph eid
- where blocks' =
- foldBlockEnv' (\b mblocks -> do { blocks <- mblocks
- ; b <- f b
- ; return $ insertBlock b blocks })
- (return emptyBlockEnv) blocks
-
-fold_blocks f z (LGraph _ blocks) = foldBlockEnv' f z blocks
-fold_fwd_block first middle last (Block id t) z = tail t (first id z)
- where tail (ZTail m t) z = tail t (middle m z)
- tail (ZLast l) z = last l z
-
-of_block_list e blocks = LGraph e $ foldr insertBlock emptyBlockEnv blocks
-to_block_list (LGraph _ blocks) = eltsBlockEnv blocks
-
-
--- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for
--- splicing purposes. There are two useful cases: the 'LGraph' is a single block
--- or it isn't. We use continuation-passing style.
-
-prepare_for_splicing ::
- LGraph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
- -> a
-prepare_for_splicing g single multi =
- let FGraph _ gentry gblocks = entry g
- ZBlock _ etail = gentry
- in if isNullBEnv gblocks then
- case last gentry of
- LastExit -> single etail
- _ -> panic "bad single block"
- else
- case splitp_blocks is_exit gblocks of
- Nothing -> panic "Can't find an exit block"
- Just (gexit, gblocks) ->
- let (gh, gl) = goto_end $ unzip gexit in
- case gl of LastExit -> multi etail gh gblocks
- _ -> panic "exit is not exit?!"
-
-prepare_for_splicing' ::
- Graph m l -> (ZTail m l -> a) -> (ZTail m l -> ZHead m -> BlockEnv (Block m l) -> a)
- -> a
-prepare_for_splicing' (Graph etail gblocks) single multi =
- if isNullBEnv gblocks then
- case lastTail etail of
- LastExit -> single etail
- _ -> panic "bad single block"
- else
- case splitp_blocks is_exit gblocks of
- Nothing -> panic "Can't find an exit block"
- Just (gexit, gblocks) ->
- let (gh, gl) = goto_end $ unzip gexit in
- case gl of LastExit -> multi etail gh gblocks
- _ -> panic "exit is not exit?!"
-
-is_exit :: Block m l -> Bool
-is_exit b = case last (unzip b) of { LastExit -> True; _ -> False }
-
-splice_head head g@(LGraph _ _) =
- ASSERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
- where eid = head_id head
- splice_one_block tail' =
- case ht_to_last head tail' of
- (head, LastExit) -> (LGraph eid emptyBlockEnv, head)
- _ -> panic "spliced LGraph without exit"
- splice_many_blocks entry exit others =
- (LGraph eid (insertBlock (zipht head entry) others), exit)
-
-splice_head' head g =
- ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
- where splice_one_block tail' =
- case ht_to_last head tail' of
- (head, LastExit) -> (emptyBlockEnv, head)
- _ -> panic "spliced LGraph without exit"
- splice_many_blocks entry exit others =
- (insertBlock (zipht head entry) others, exit)
-
--- splice_tail :: Graph m l -> ZTail m l -> Graph m l
-splice_tail g tail =
- ASSERT (single_exitg g) prepare_for_splicing' g splice_one_block splice_many_blocks
- where splice_one_block tail' = Graph (tail' `append_tails` tail) emptyBlockEnv
- append_tails (ZLast LastExit) tail = tail
- append_tails (ZLast _) _ = panic "spliced single block without LastExit"
- append_tails (ZTail m t) tail = ZTail m (append_tails t tail)
- splice_many_blocks entry exit others =
- Graph entry (insertBlock (zipht exit tail) others)
-
-{-
-splice_tail g tail =
- AS SERT (single_exit g) prepare_for_splicing g splice_one_block splice_many_blocks
- where splice_one_block tail' = -- return tail' .. tail
- case ht_to_last (ZFirst (lg_entry g)) tail' of
- (head', LastExit) ->
- case ht_to_block head' tail of
- Block id t | id == lg_entry g -> (t, LGraph id emptyBlockEnv)
- _ -> panic "entry in; garbage out"
- _ -> panic "spliced single block without Exit"
- splice_many_blocks entry exit others =
- (entry, LGraph (lg_entry g) (insertBlock (zipht exit tail) others))
--}
-
-splice_head_only head g =
- let FGraph eid gentry gblocks = entry g
- in case gentry of
- ZBlock (ZFirst _) tail ->
- LGraph eid (insertBlock (zipht head tail) gblocks)
- _ -> panic "entry not at start of block?!"
-
-splice_head_only' head (Graph tail gblocks) =
- let eblock = zipht head tail in
- LGraph (blockId eblock) (insertBlock eblock gblocks)
- -- the offset probably should never be used, but well, it's correct for this LGraph
-
-
---- Translation
-
-translate txm txl (LGraph eid blocks) =
- do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks
- return $ LGraph eid blocks'
- where
- -- txblock ::
- -- Block m l -> tm (BlockEnv (Block m' l')) -> tm (BlockEnv (Block m' l'))
- txblock (Block id t) expanded =
- do blocks' <- expanded
- txtail (ZFirst id) t blocks'
- -- txtail :: ZHead m' -> ZTail m l -> BlockEnv (Block m' l') ->
- -- tm (BlockEnv (Block m' l'))
- txtail h (ZTail m t) blocks' =
- do m' <- txm m
- let (g, h') = splice_head h m'
- txtail h' t (plusBlockEnv (lg_blocks g) blocks')
- txtail h (ZLast (LastOther l)) blocks' =
- do l' <- txl l
- return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks'
- txtail h (ZLast LastExit) blocks' =
- return $ insertBlock (zipht h (ZLast LastExit)) blocks'
-
-----------------------------------------------------------------
----- Prettyprinting
-----------------------------------------------------------------
-
--- putting this code in PprCmmZ leads to circular imports :-(
-
-instance (Outputable m, Outputable l) => Outputable (ZTail m l) where
- ppr = pprTail
-
-instance (Outputable m, Outputable l, LastNode l) => Outputable (Graph m l) where
- ppr = pprGraph
-
-instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) where
- ppr = pprLgraph
-
-instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where
- ppr = pprBlock
-
-instance (Outputable l) => Outputable (ZLast l) where
- ppr = pprLast
-
-pprTail :: (Outputable m, Outputable l) => ZTail m l -> SDoc
-pprTail (ZTail m t) = ppr m $$ ppr t
-pprTail (ZLast l) = ppr l
-
-pprLast :: (Outputable l) => ZLast l -> SDoc
-pprLast LastExit = text "<exit>"
-pprLast (LastOther l) = ppr l
-
-pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc
-pprBlock (Block id tail) =
- ppr id <> colon
- $$ (nest 3 (ppr tail))
-
-pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc
-pprLgraph g = text "{" <> text "offset" $$
- nest 2 (vcat $ map ppr blocks) $$ text "}"
- where blocks = postorder_dfs g
-
-pprGraph :: (Outputable m, Outputable l, LastNode l) => Graph m l -> SDoc
-pprGraph (Graph tail blockenv) =
- text "{" $$ nest 2 (ppr tail $$ (vcat $ map ppr blocks)) $$ text "}"
- where blocks = postorder_dfs_from blockenv tail
-
+++ /dev/null
-{-# OPTIONS_GHC -XNoMonoLocalBinds #-}
--- Norman likes local bindings
-
--- This module is pure representation and should be imported only by
--- clients that need to manipulate representation and know what
--- they're doing. Clients that need to create flow graphs should
--- instead import MkZipCfgCmm.
-
-module ZipCfgCmmRep
- ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph
- , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset
- , Convention(..), ForeignConvention(..), ForeignSafety(..)
- , ValueDirection(..), ForeignHint(..)
- , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted
- , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast
- , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts
- )
-where
-
-import BlockId
-import CmmExpr
-import Cmm ( GenCmm(..), GenCmmTop(..), CmmStatic, CmmInfo
- , CallishMachOp(..), ForeignHint(..)
- , CmmActuals, CmmFormals, CmmHinted(..)
- , CmmStmt(..) -- imported in order to call ppr on Switch and to
- -- implement pprCmmGraphLikeCmm
- )
-import DFMonad
-import PprCmm()
-import CmmTx
-
-import CLabel
-import FastString
-import ForeignCall
-import qualified ZipDataflow as DF
-import ZipCfg
-import MkZipCfg
-import Util
-
-import BasicTypes
-import Maybes
-import Control.Monad
-import Outputable
-import Prelude hiding (zip, unzip, last)
-import SMRep (ByteOff)
-import UniqSupply
-
-----------------------------------------------------------------------
------ Type synonyms and definitions
-
-type CmmGraph = LGraph Middle Last
-type CmmAGraph = AGraph Middle Last
-type CmmBlock = Block Middle Last
-type CmmStackInfo = (ByteOff, Maybe ByteOff)
- -- probably want a record; (SP offset on entry, update frame space)
-type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
-type CmmTopZ = GenCmmTop CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
-type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a ()
-type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a ()
-
-type UpdFrameOffset = ByteOff
-
-data Middle
- = MidComment FastString
-
- | MidAssign CmmReg CmmExpr -- Assign to register
-
- | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is
- -- given by cmmExprType of the rhs.
-
- | MidForeignCall -- A foreign call; see Note [Foreign calls]
- ForeignSafety -- Is it a safe or unsafe call?
- MidCallTarget -- call target and convention
- CmmFormals -- zero or more results
- CmmActuals -- zero or more arguments
- deriving Eq
-
-data Last
- = LastBranch BlockId -- Goto another block in the same procedure
-
- | LastCondBranch { -- conditional branch
- cml_pred :: CmmExpr,
- cml_true, cml_false :: BlockId
- }
- | LastSwitch CmmExpr [Maybe BlockId] -- Table branch
- -- The scrutinee is zero-based;
- -- zero -> first block
- -- one -> second block etc
- -- Undefined outside range, and when there's a Nothing
- | LastCall { -- A call (native or safe foreign)
- cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp!
-
- cml_cont :: Maybe BlockId,
- -- BlockId of continuation (Nothing for return or tail call)
-
- cml_args :: ByteOff,
- -- Byte offset, from the *old* end of the Area associated with
- -- the BlockId (if cml_cont = Nothing, then Old area), of
- -- youngest outgoing arg. Set the stack pointer to this before
- -- transferring control.
- -- (NB: an update frame might also have been stored in the Old
- -- area, but it'll be in an older part than the args.)
-
- cml_ret_args :: ByteOff,
- -- For calls *only*, the byte offset for youngest returned value
- -- This is really needed at the *return* point rather than here
- -- at the call, but in practice it's convenient to record it here.
-
- cml_ret_off :: Maybe ByteOff
- -- For calls *only*, the byte offset of the base of the frame that
- -- must be described by the info table for the return point.
- -- The older words are an update frames, which have their own
- -- info-table and layout information
-
- -- From a liveness point of view, the stack words older than
- -- cml_ret_off are treated as live, even if the sequel of
- -- the call goes into a loop.
- }
-
-data MidCallTarget -- The target of a MidUnsafeCall
- = ForeignTarget -- A foreign procedure
- CmmExpr -- Its address
- ForeignConvention -- Its calling convention
-
- | PrimTarget -- A possibly-side-effecting machine operation
- CallishMachOp -- Which one
- deriving Eq
-
-data Convention
- = NativeDirectCall -- Native C-- call skipping the node (closure) argument
-
- | NativeNodeCall -- Native C-- call including the node argument
-
- | NativeReturn -- Native C-- return
-
- | Slow -- Slow entry points: all args pushed on the stack
-
- | GC -- Entry to the garbage collector: uses the node reg!
-
- | PrimOpCall -- Calling prim ops
-
- | PrimOpReturn -- Returning from prim ops
-
- | Foreign -- Foreign call/return
- ForeignConvention
-
- | Private
- -- Used for control transfers within a (pre-CPS) procedure All
- -- jump sites known, never pushed on the stack (hence no SRT)
- -- You can choose whatever calling convention you please
- -- (provided you make sure all the call sites agree)!
- -- This data type eventually to be extended to record the convention.
- deriving( Eq )
-
-data ForeignConvention
- = ForeignConvention
- CCallConv -- Which foreign-call convention
- [ForeignHint] -- Extra info about the args
- [ForeignHint] -- Extra info about the result
- deriving Eq
-
-data ForeignSafety
- = Unsafe -- unsafe call
- | Safe BlockId -- making infotable requires: 1. label
- UpdFrameOffset -- 2. where the upd frame is
- Bool -- is the call interruptible?
- deriving Eq
-
-data ValueDirection = Arguments | Results
- -- Arguments go with procedure definitions, jumps, and arguments to calls
- -- Results go with returns and with results of calls.
- deriving Eq
-
-{- Note [Foreign calls]
-~~~~~~~~~~~~~~~~~~~~~~~
-A MidForeign call is used *all* foreign calls, both *unsafe* and *safe*.
-Unsafe ones are easy: think of them as a "fat machine instruction".
-
-Safe ones are trickier. A safe foreign call
- r = f(x)
-ultimately expands to
- push "return address" -- Never used to return to;
- -- just points an info table
- save registers into TSO
- call suspendThread
- r = f(x) -- Make the call
- call resumeThread
- restore registers
- pop "return address"
-We cannot "lower" a safe foreign call to this sequence of Cmms, because
-after we've saved Sp all the Cmm optimiser's assumptions are broken.
-Furthermore, currently the smart Cmm constructors know the calling
-conventions for Haskell, the garbage collector, etc, and "lower" them
-so that a LastCall passes no parameters or results. But the smart
-constructors do *not* (currently) know the foreign call conventions.
-
-For these reasons use MidForeignCall for all calls. The only annoying thing
-is that a safe foreign call needs an info table.
--}
-
-----------------------------------------------------------------------
------ Splicing between blocks
--- Given a middle node, a block, and a successor BlockId,
--- we can insert the middle node between the block and the successor.
--- We return the updated block and a list of new blocks that must be added
--- to the graph.
--- The semantics is a bit tricky. We consider cases on the last node:
--- o For a branch, we can just insert before the branch,
--- but sometimes the optimizer does better if we actually insert
--- a fresh basic block, enabling some common blockification.
--- o For a conditional branch, switch statement, or call, we must insert
--- a new basic block.
--- o For a jump or return, this operation is impossible.
-
-insertBetween :: MonadUnique m => CmmBlock -> [Middle] -> BlockId -> m (CmmBlock, [CmmBlock])
-insertBetween b ms succId = insert $ goto_end $ unzip b
- where insert (h, LastOther (LastBranch bid)) =
- if bid == succId then
- do (bid', bs) <- newBlocks
- return (zipht h (ZLast (LastOther (LastBranch bid'))), bs)
- else panic "tried invalid block insertBetween"
- insert (h, LastOther (LastCondBranch c t f)) =
- do (t', tbs) <- if t == succId then newBlocks else return $ (t, [])
- (f', fbs) <- if f == succId then newBlocks else return $ (f, [])
- return (zipht h $ ZLast $ LastOther (LastCondBranch c t' f'), tbs ++ fbs)
- insert (h, LastOther (LastSwitch e ks)) =
- do (ids, bs) <- mapAndUnzipM mbNewBlocks ks
- return (zipht h $ ZLast $ LastOther (LastSwitch e ids), join bs)
- insert (_, LastOther (LastCall {})) =
- panic "unimp: insertBetween after a call -- probably not a good idea"
- insert (_, LastExit) = panic "cannot insert after exit"
- newBlocks = do id <- liftM BlockId $ getUniqueM
- return $ (id, [Block id $
- foldr ZTail (ZLast (LastOther (LastBranch succId))) ms])
- mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks
- else return (Just k, [])
- mbNewBlocks Nothing = return (Nothing, [])
- lift (id, bs) = (Just id, bs)
-
-----------------------------------------------------------------------
------ Instance declarations for control flow
-
-instance HavingSuccessors Last where
- succs = cmmSuccs
- fold_succs = fold_cmm_succs
-
-instance LastNode Last where
- mkBranchNode id = LastBranch id
- isBranchNode (LastBranch _) = True
- isBranchNode _ = False
- branchNodeTarget (LastBranch id) = id
- branchNodeTarget _ = panic "asked for target of non-branch"
-
-cmmSuccs :: Last -> [BlockId]
-cmmSuccs (LastBranch id) = [id]
-cmmSuccs (LastCall _ Nothing _ _ _) = []
-cmmSuccs (LastCall _ (Just id) _ _ _) = [id]
-cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint
-cmmSuccs (LastSwitch _ edges) = catMaybes edges
-
-fold_cmm_succs :: (BlockId -> a -> a) -> Last -> a -> a
-fold_cmm_succs f (LastBranch id) z = f id z
-fold_cmm_succs _ (LastCall _ Nothing _ _ _) z = z
-fold_cmm_succs f (LastCall _ (Just id) _ _ _) z = f id z
-fold_cmm_succs f (LastCondBranch _ te fe) z = f te (f fe z)
-fold_cmm_succs f (LastSwitch _ edges) z = foldl (flip f) z $ catMaybes edges
-
-----------------------------------------------------------------------
------ Instance declarations for register use
-
-instance UserOfLocalRegs Middle where
- foldRegsUsed f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign _lhs expr) = fold f z expr
- middle (MidStore addr rval) = fold f (fold f z addr) rval
- middle (MidForeignCall _ tgt _ args) = fold f (fold f z tgt) args
- fold f z m = foldRegsUsed f z m -- avoid monomorphism restriction
-
-instance UserOfLocalRegs MidCallTarget where
- foldRegsUsed _f z (PrimTarget _) = z
- foldRegsUsed f z (ForeignTarget e _) = foldRegsUsed f z e
-
-instance UserOfSlots MidCallTarget where
- foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e
- foldSlotsUsed _f z (PrimTarget _) = z
-
-instance (UserOfLocalRegs a) => UserOfLocalRegs (Maybe a) where
- foldRegsUsed f z (Just x) = foldRegsUsed f z x
- foldRegsUsed _ z Nothing = z
-
-instance (UserOfSlots a) => UserOfSlots (Maybe a) where
- foldSlotsUsed f z (Just x) = foldSlotsUsed f z x
- foldSlotsUsed _ z Nothing = z
-
-instance UserOfLocalRegs Last where
- foldRegsUsed f z l = last l
- where last (LastBranch _id) = z
- last (LastCall tgt _ _ _ _) = foldRegsUsed f z tgt
- last (LastCondBranch e _ _) = foldRegsUsed f z e
- last (LastSwitch e _tbl) = foldRegsUsed f z e
-
-instance DefinerOfLocalRegs Middle where
- foldRegsDefd f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign lhs _) = fold f z lhs
- middle (MidStore _ _) = z
- middle (MidForeignCall _ _ fs _) = fold f z fs
- fold f z m = foldRegsDefd f z m -- avoid monomorphism restriction
-
-instance DefinerOfLocalRegs Last where
- foldRegsDefd _ z _ = z
-
-
-----------------------------------------------------------------------
------ Instance declarations for stack slot use
-
-instance UserOfSlots Middle where
- foldSlotsUsed f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign _lhs expr) = fold f z expr
- middle (MidStore addr rval) = fold f (fold f z addr) rval
- middle (MidForeignCall _ tgt _ress args) = fold f (fold f z tgt) args
- fold f z e = foldSlotsUsed f z e -- avoid monomorphism restriction
-
-instance UserOfSlots Last where
- foldSlotsUsed f z l = last l
- where last (LastBranch _id) = z
- last (LastCall tgt _ _ _ _) = foldSlotsUsed f z tgt
- last (LastCondBranch e _ _) = foldSlotsUsed f z e
- last (LastSwitch e _tbl) = foldSlotsUsed f z e
-
-instance UserOfSlots l => UserOfSlots (ZLast l) where
- foldSlotsUsed f z (LastOther l) = foldSlotsUsed f z l
- foldSlotsUsed _ z LastExit = z
-
-instance DefinerOfSlots Middle where
- foldSlotsDefd f z m = middle m
- where middle (MidComment {}) = z
- middle (MidAssign _ _) = z
- middle (MidForeignCall {}) = z
- middle (MidStore (CmmStackSlot a i) e) =
- f z (a, i, widthInBytes $ typeWidth $ cmmExprType e)
- middle (MidStore _ _) = z
-
-instance DefinerOfSlots Last where
- foldSlotsDefd _ z _ = z
-
-instance DefinerOfSlots l => DefinerOfSlots (ZLast l) where
- foldSlotsDefd f z (LastOther l) = foldSlotsDefd f z l
- foldSlotsDefd _ z LastExit = z
-
-----------------------------------------------------------------------
------ Code for manipulating Middle and Last nodes
-
-mapExpMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
-mapExpMiddle _ m@(MidComment _) = m
-mapExpMiddle exp (MidAssign r e) = MidAssign r (exp e)
-mapExpMiddle exp (MidStore addr e) = MidStore (exp addr) (exp e)
-mapExpMiddle exp (MidForeignCall s tgt fs as) =
- MidForeignCall s (mapExpMidcall exp tgt) fs (map exp as)
-
-foldExpMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
-foldExpMiddle _ (MidComment _) z = z
-foldExpMiddle exp (MidAssign _ e) z = exp e z
-foldExpMiddle exp (MidStore addr e) z = exp addr $ exp e z
-foldExpMiddle exp (MidForeignCall _ tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as
-
-mapExpLast :: (CmmExpr -> CmmExpr) -> Last -> Last
-mapExpLast _ l@(LastBranch _) = l
-mapExpLast exp (LastCondBranch e ti fi) = LastCondBranch (exp e) ti fi
-mapExpLast exp (LastSwitch e tbl) = LastSwitch (exp e) tbl
-mapExpLast exp (LastCall tgt mb_id o i s) = LastCall (exp tgt) mb_id o i s
-
-foldExpLast :: (CmmExpr -> z -> z) -> Last -> z -> z
-foldExpLast _ (LastBranch _) z = z
-foldExpLast exp (LastCondBranch e _ _) z = exp e z
-foldExpLast exp (LastSwitch e _) z = exp e z
-foldExpLast exp (LastCall tgt _ _ _ _) z = exp tgt z
-
-mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget
-mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c
-mapExpMidcall _ m@(PrimTarget _) = m
-
-foldExpMidcall :: (CmmExpr -> z -> z) -> MidCallTarget -> z -> z
-foldExpMidcall exp (ForeignTarget e _) z = exp e z
-foldExpMidcall _ (PrimTarget _) z = z
-
--- Take a transformer on expressions and apply it recursively.
-wrapRecExp :: (CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
-wrapRecExp f (CmmMachOp op es) = f (CmmMachOp op $ map (wrapRecExp f) es)
-wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (wrapRecExp f addr) ty)
-wrapRecExp f e = f e
-
-mapExpDeepMiddle :: (CmmExpr -> CmmExpr) -> Middle -> Middle
-mapExpDeepLast :: (CmmExpr -> CmmExpr) -> Last -> Last
-mapExpDeepMiddle f = mapExpMiddle $ wrapRecExp f
-mapExpDeepLast f = mapExpLast $ wrapRecExp f
-
--- Take a folder on expressions and apply it recursively.
-wrapRecExpf :: (CmmExpr -> z -> z) -> CmmExpr -> z -> z
-wrapRecExpf f e@(CmmMachOp _ es) z = foldr (wrapRecExpf f) (f e z) es
-wrapRecExpf f e@(CmmLoad addr _) z = wrapRecExpf f addr (f e z)
-wrapRecExpf f e z = f e z
-
-foldExpDeepMiddle :: (CmmExpr -> z -> z) -> Middle -> z -> z
-foldExpDeepLast :: (CmmExpr -> z -> z) -> Last -> z -> z
-foldExpDeepMiddle f = foldExpMiddle $ wrapRecExpf f
-foldExpDeepLast f = foldExpLast $ wrapRecExpf f
-
-----------------------------------------------------------------------
--- Compute the join of facts live out of a Last node. Useful for most backward
--- analyses.
-joinOuts :: DataflowLattice a -> (BlockId -> a) -> Last -> a
-joinOuts lattice env l =
- let bot = fact_bot lattice
- join x y = txVal $ fact_add_to lattice x y
- in case l of
- (LastBranch id) -> env id
- (LastCall _ Nothing _ _ _) -> bot
- (LastCall _ (Just k) _ _ _) -> env k
- (LastCondBranch _ t f) -> join (env t) (env f)
- (LastSwitch _ tbl) -> foldr join bot (map env $ catMaybes tbl)
-
-----------------------------------------------------------------------
------ Instance declarations for prettyprinting (avoids recursive imports)
-
-instance Outputable Middle where
- ppr s = pprMiddle s
-
-instance Outputable Last where
- ppr s = pprLast s
-
-instance Outputable Convention where
- ppr = pprConvention
-
-instance Outputable ForeignConvention where
- ppr = pprForeignConvention
-
-instance Outputable ValueDirection where
- ppr Arguments = ptext $ sLit "args"
- ppr Results = ptext $ sLit "results"
-
-instance DF.DebugNodes Middle Last
-
-debugPpr :: Bool
-debugPpr = debugIsOn
-
-pprMiddle :: Middle -> SDoc
-pprMiddle stmt = pp_stmt <+> pp_debug
- where
- pp_stmt = case stmt of
- -- // text
- MidComment s -> text "//" <+> ftext s
-
- -- reg = expr;
- MidAssign reg expr -> ppr reg <+> equals <+> ppr expr <> semi
-
- -- rep[lv] = expr;
- MidStore lv expr -> rep <> brackets(ppr lv) <+> equals <+> ppr expr <> semi
- where
- rep = ppr ( cmmExprType expr )
-
- -- call "ccall" foo(x, y)[r1, r2];
- -- ToDo ppr volatile
- MidForeignCall safety target results args ->
- hsep [ ppUnless (null results) $
- parens (commafy $ map ppr results) <+> equals,
- ppr_safety safety,
- ptext $ sLit "call",
- ppr_call_target target <> parens (commafy $ map ppr args) <> semi]
-
- pp_debug =
- if not debugPpr then empty
- else text " //" <+>
- case stmt of
- MidComment {} -> text "MidComment"
- MidAssign {} -> text "MidAssign"
- MidStore {} -> text "MidStore"
- MidForeignCall {} -> text "MidForeignCall"
-
-ppr_fc :: ForeignConvention -> SDoc
-ppr_fc (ForeignConvention c args res) =
- doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
-
-ppr_safety :: ForeignSafety -> SDoc
-ppr_safety (Safe bid upd interruptible) =
- text (if interruptible then "interruptible" else "safe") <>
- text "<" <> ppr bid <> text ", " <> ppr upd <> text ">"
-ppr_safety Unsafe = text "unsafe"
-
-ppr_call_target :: MidCallTarget -> SDoc
-ppr_call_target (ForeignTarget fn c) = ppr_fc c <+> ppr_target fn
-ppr_call_target (PrimTarget op)
- -- HACK: We're just using a ForeignLabel to get this printed, the label
- -- might not really be foreign.
- = ppr (CmmLabel (mkForeignLabel
- (mkFastString (show op))
- Nothing ForeignLabelInThisPackage IsFunction))
-
-ppr_target :: CmmExpr -> SDoc
-ppr_target t@(CmmLit _) = ppr t
-ppr_target fn' = parens (ppr fn')
-
-pprHinted :: Outputable a => CmmHinted a -> SDoc
-pprHinted (CmmHinted a NoHint) = ppr a
-pprHinted (CmmHinted a AddrHint) = doubleQuotes (text "address") <+> ppr a
-pprHinted (CmmHinted a SignedHint) = doubleQuotes (text "signed") <+> ppr a
-
-pprLast :: Last -> SDoc
-pprLast stmt = pp_stmt <+> pp_debug
- where
- pp_stmt = case stmt of
- LastBranch ident -> ptext (sLit "goto") <+> ppr ident <> semi
- LastCondBranch expr t f -> genFullCondBranch expr t f
- LastSwitch arg ids -> ppr $ CmmSwitch arg ids
- LastCall tgt k out res updfr_off -> genBareCall tgt k out res updfr_off
-
- pp_debug = text " //" <+> case stmt of
- LastBranch {} -> text "LastBranch"
- LastCondBranch {} -> text "LastCondBranch"
- LastSwitch {} -> text "LastSwitch"
- LastCall {} -> text "LastCall"
-
-genBareCall :: CmmExpr -> Maybe BlockId -> ByteOff -> ByteOff ->
- Maybe UpdFrameOffset -> SDoc
-genBareCall fn k out res updfr_off =
- hcat [ ptext (sLit "call"), space
- , pprFun fn, ptext (sLit "(...)"), space
- , ptext (sLit "returns to") <+> ppr k <+> parens (ppr out)
- <+> parens (ppr res)
- , ptext (sLit " with update frame") <+> ppr updfr_off
- , semi ]
-
-pprFun :: CmmExpr -> SDoc
-pprFun f@(CmmLit _) = ppr f
-pprFun f = parens (ppr f)
-
-genFullCondBranch :: Outputable id => CmmExpr -> id -> id -> SDoc
-genFullCondBranch expr t f =
- hsep [ ptext (sLit "if")
- , parens(ppr expr)
- , ptext (sLit "goto")
- , ppr t <> semi
- , ptext (sLit "else goto")
- , ppr f <> semi
- ]
-
-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>"
-pprConvention PrimOpCall = text "<primop-call-convention>"
-pprConvention PrimOpReturn = text "<primop-ret-convention>"
-pprConvention (Foreign c) = ppr c
-pprConvention (Private {}) = text "<private-convention>"
-
-pprForeignConvention :: ForeignConvention -> SDoc
-pprForeignConvention (ForeignConvention c as rs) = ppr c <> ppr as <> ppr rs
-
-commafy :: [SDoc] -> SDoc
-commafy xs = hsep $ punctuate comma xs
+++ /dev/null
-{-# OPTIONS -Wall -fno-warn-name-shadowing #-}
-
--- This module contains code related to the zipcfg representation.
--- The code either has been used or has been thought to be useful
--- within the Quick C-- compiler, but as yet no use has been found for
--- it within GHC. This module should therefore be considered to be
--- full of code that need not be maintained. Should a function in
--- this module prove useful, it should not be exported, but rather
--- should be migrated back into ZipCfg (or possibly ZipCfgUtil), where
--- it can be maintained.
-
-module ZipCfgExtras
- ()
-where
-import BlockId
-import Maybes
-import Panic
-import ZipCfg
-
-import Prelude hiding (zip, unzip, last)
-
-
-exit :: LGraph m l -> FGraph m l -- focus on edge into default exit node
- -- (fails if there isn't one)
-focusp :: (Block m l -> Bool) -> LGraph m l -> Maybe (FGraph m l)
- -- focus on start of block satisfying predicate
--- unfocus :: FGraph m l -> LGraph m l -- lose focus
-
--- | We can insert a single-entry, single-exit subgraph at
--- the current focus.
--- The new focus can be at either the entry edge or the exit edge.
-
-{-
-splice_focus_entry :: FGraph m l -> LGraph m l -> FGraph m l
-splice_focus_exit :: FGraph m l -> LGraph m l -> FGraph m l
--}
-
-_unused :: ()
-_unused = all `seq` ()
- where all = ( exit, focusp --, unfocus {- , splice_focus_entry, splice_focus_exit -}
- , foldM_fwd_block (\_ a -> Just a)
- )
-
---unfocus (FGraph e bz bs) = LGraph e (insertBlock (zip bz) bs)
-
-focusp p (LGraph entry blocks) =
- fmap (\(b, bs) -> FGraph entry (unzip b) bs) (splitp_blocks p blocks)
-
-exit g@(LGraph eid _) = FGraph eid (ZBlock h (ZLast l)) others
- where FGraph _ b others = focusp is_exit g `orElse` panic "no exit in flow graph"
- (h, l) = goto_end b
-
-
-{-
-splice_focus_entry (FGraph eid (ZBlock head tail) blocks) g =
- let (tail', g') = splice_tail g tail in
- FGraph eid (ZBlock head tail') (plusUFM (lg_blocks g') blocks)
-
-splice_focus_exit (FGraph eid (ZBlock head tail) blocks) g =
- let (g', head') = splice_head head g in
- FGraph eid (ZBlock head' tail) (plusUFM (lg_blocks g') blocks)
--}
-
--- | iterate from first to last
-foldM_fwd_block ::
- Monad m => (BlockId -> a -> m a) -> (mid -> a -> m a) -> (ZLast l -> a -> m a) ->
- Block mid l -> a -> m a
-foldM_fwd_block first middle last (Block id t) z = do { z <- first id z; tail t z }
- where tail (ZTail m t) z = do { z <- middle m z; tail t z }
- tail (ZLast l) z = last l z
-
-splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) ->
- Maybe (Block m l, BlockEnv (Block m l))
-splitp_blocks = panic "splitp_blocks" -- implemented in ZipCfg but not exported
-is_exit :: Block m l -> Bool
-is_exit = panic "is_exit" -- implemented in ZipCfg but not exported
+++ /dev/null
-{-# LANGUAGE MultiParamTypeClasses, ScopedTypeVariables, KindSignatures,
- FlexibleContexts #-}
-
-module ZipDataflow
- ( DebugNodes(), RewritingDepth(..), LastOutFacts(..)
- , zdfSolveFrom, zdfRewriteFrom
- , zdfSolveFromL
- , ForwardTransfers(..), BackwardTransfers(..)
- , ForwardRewrites(..), BackwardRewrites(..)
- , ForwardFixedPoint, BackwardFixedPoint
- , zdfFpFacts
- , zdfFpOutputFact
- , zdfGraphChanged
- , zdfDecoratedGraph -- not yet implemented
- , zdfFpContents
- , zdfFpLastOuts
- , zdfBRewriteFromL, zdfFRewriteFromL
- )
-where
-
-import BlockId
-import CmmTx
-import DFMonad
-import OptimizationFuel as F
-import MkZipCfg
-import ZipCfg
-import qualified ZipCfg as G
-
-import Maybes
-import Outputable
-
-import Control.Monad
-
-{-
-
-This module implements two useful tools:
-
- 1. An iterative solver for dataflow problems
-
- 2. The combined dataflow-analysis-and-transformation framework
- described by Lerner, Grove, and Chambers in their excellent
- 2002 POPL paper (http://tinyurl.com/3zycbr or
- http://tinyurl.com/3pnscd).
-
-Each tool comes in two flavors: one for forward dataflow problems
-and one for backward dataflow problems.
-
-We quote the paper above:
-
- Dataflow analyses can have mutually beneficial interactions.
- Previous efforts to exploit these interactions have either
- (1) iteratively performed each individual analysis until no
- further improvements are discovered or (2) developed "super-
- analyses" that manually combine conceptually separate anal-
- yses. We have devised a new approach that allows anal-
- yses to be defined independently while still enabling them
- to be combined automatically and profitably. Our approach
- avoids the loss of precision associated with iterating indi-
- vidual analyses and the implementation difficulties of man-
- ually writing a super-analysis.
-
-The key idea is to provide at each CFG node not only a dataflow
-transfer function but also a rewriting function that has the option to
-replace the node with a new (possibly empty) graph. The rewriting
-function takes a dataflow fact as input, and the fact is used to
-justify any rewriting. For example, in a backward problem, the fact
-that variable x is dead can be used to justify rewriting node
- x := e
-to the empty graph. In a forward problem, the fact that x == 7 can
-be used to justify rewriting node
- y := x + 1
-to
- y := 8
-which in turn will be analyzed and produce a new fact:
-x == 7 and y == 8.
-
-In its most general form, this module takes as input graph, transfer
-equations, rewrites, and an initial set of dataflow facts, and
-iteratively computes a new graph and a new set of dataflow facts such
-that
- * The set of facts is a fixed point of the transfer equations
- * The graph has been rewritten as much as is consistent with
- the given facts and requested rewriting depth (see below)
-N.B. 'A set of facts' is shorthand for 'A finite map from CFG label to fact'.
-
-The types of transfer equations, rewrites, and fixed points are
-different for forward and backward problems. To avoid cluttering the
-name space with two versions of every name, other names such as
-zdfSolveFrom are overloaded to work in both forward or backward
-directions. This design decision is based on experience with the
-predecessor module, which has been mercifully deleted.
-
-
-This module is deliberately very abstract. It is a completely general
-framework and well-nigh impossible to understand in isolation. The
-cautious reader will begin with some concrete examples in the form of
-clients. NR recommends
-
- CmmLiveZ A simple liveness analysis
-
- CmmSpillReload.removeDeadAssignmentsAndReloads
- A piece of spaghetti to pull on, which leads to
- - a two-part liveness analysis that tracks
- variables live in registers and live on the stack
- - elimination of assignments to dead variables
- - elimination of redundant reloads
-
-Even hearty souls should avoid the CmmProcPointZ client, at least for
-the time being.
-
--}
-
-
-{- ============ TRANSFER FUNCTIONS AND REWRITES =========== -}
-
--- | For a backward transfer, you're given the fact on a node's
--- outedge and you compute the fact on the inedge. Facts have type 'a'.
--- A last node may have multiple outedges, each pointing to a labelled
--- block, so instead of a fact it is given a mapping from BlockId to fact.
-
-data BackwardTransfers middle last a = BackwardTransfers
- { bt_first_in :: BlockId -> a -> a
- , bt_middle_in :: middle -> a -> a
- , bt_last_in :: last -> (BlockId -> a) -> a
- }
-
--- | For a forward transfer, you're given the fact on a node's
--- inedge and you compute the fact on the outedge. Because a last node
--- may have multiple outedges, each pointing to a labelled
--- block, so instead of a fact it produces a list of (BlockId, fact) pairs.
-
-data ForwardTransfers middle last a = ForwardTransfers
- { ft_first_out :: BlockId -> a -> a
- , ft_middle_out :: middle -> a -> a
- , ft_last_outs :: last -> a -> LastOutFacts a
- , ft_exit_out :: a -> a
- }
-
-newtype LastOutFacts a = LastOutFacts [(BlockId, a)]
- -- ^ These are facts flowing out of a last node to the node's successors.
- -- They are either to be set (if they pertain to the graph currently
- -- under analysis) or propagated out of a sub-analysis
-
-
--- | A backward rewrite takes the same inputs as a backward transfer,
--- but instead of producing a fact, it produces a replacement graph or Nothing.
-
-data BackwardRewrites middle last a = BackwardRewrites
- { br_first :: BlockId -> a -> Maybe (AGraph middle last)
- , br_middle :: middle -> a -> Maybe (AGraph middle last)
- , br_last :: last -> (BlockId -> a) -> Maybe (AGraph middle last)
- , br_exit :: Maybe (AGraph middle last)
- }
-
--- | A forward rewrite takes the same inputs as a forward transfer,
--- but instead of producing a fact, it produces a replacement graph or Nothing.
-
-data ForwardRewrites middle last a = ForwardRewrites
- { fr_first :: BlockId -> a -> Maybe (AGraph middle last)
- , fr_middle :: middle -> a -> Maybe (AGraph middle last)
- , fr_last :: last -> a -> Maybe (AGraph middle last)
- , fr_exit :: a -> Maybe (AGraph middle last)
- }
-
-{- ===================== FIXED POINTS =================== -}
-
--- | The result of combined analysis and transformation is a
--- solution to the set of dataflow equations together with a 'contained value'.
--- This solution is a member of type class 'FixedPoint', which is parameterized by
--- * middle and last nodes 'm' and 'l'
--- * data flow fact 'fact'
--- * the type 'a' of the contained value
---
--- In practice, the contained value 'zdfFpContents' is either a
--- rewritten graph, when rewriting, or (), when solving without
--- rewriting. A function 'zdfFpMap' allows a client to change
--- the contents without changing other values.
---
--- To save space, we provide the solution 'zdfFpFacts' as a mapping
--- from BlockId to fact; if necessary, facts on edges can be
--- reconstructed using the transfer functions; this functionality is
--- intended to be included as the 'zdfDecoratedGraph', but the code
--- has not yet been implemented.
---
--- The solution may also includes a fact 'zdfFpOuputFact', which is
--- not associated with any label:
--- * for a backward problem, this is the fact at entry
--- * for a forward problem, this is the fact at the distinguished exit node,
--- if such a node is present
---
--- For a forward problem only, the solution includes 'zdfFpLastOuts',
--- which is the set of facts on edges leaving the graph.
---
--- The flag 'zdfGraphChanged' tells whether the engine did any rewriting.
-
-class FixedPoint fp where
- zdfFpContents :: fp m l fact a -> a
- zdfFpFacts :: fp m l fact a -> BlockEnv fact
- zdfFpOutputFact :: fp m l fact a -> fact -- entry for backward; exit for forward
- zdfDecoratedGraph :: fp m l fact a -> Graph (fact, m) (fact, l)
- zdfGraphChanged :: fp m l fact a -> ChangeFlag
- zdfFpMap :: (a -> b) -> (fp m l fact a -> fp m l fact b)
-
--- | The class 'FixedPoint' has two instances: one for forward problems and
--- one for backward problems. The 'CommonFixedPoint' defines all fields
--- common to both. (The instance declarations are uninteresting and appear below.)
-
-data CommonFixedPoint m l fact a = FP
- { fp_facts :: BlockEnv fact
- , fp_out :: fact -- entry for backward; exit for forward
- , fp_changed :: ChangeFlag
- , fp_dec_graph :: Graph (fact, m) (fact, l)
- , fp_contents :: a
- }
-
--- | The common fixed point is sufficient for a backward problem.
-type BackwardFixedPoint = CommonFixedPoint
-
--- | A forward problem needs the common fields, plus the facts on the outedges.
-data ForwardFixedPoint m l fact a = FFP
- { ffp_common :: CommonFixedPoint m l fact a
- , zdfFpLastOuts :: LastOutFacts fact
- }
-
-
-{- ============== SOLVING AND REWRITING ============== -}
-
-type PassName = String
-
--- | 'zdfSolveFrom' is an overloaded name that resolves to a pure
--- analysis with no rewriting. It has only two instances: forward and
--- backward. Since it needs no rewrites, the type parameters of the
--- class are transfer functions and the fixed point.
---
---
--- An iterative solver normally starts with the bottom fact at every
--- node, but it can be useful in other contexts as well. For this
--- reason the initial set of facts (at labelled blocks only) is a
--- parameter to the solver.
---
--- The constraints on the type signature exist purely for debugging;
--- they make it possible to prettyprint nodes and facts. The parameter of
--- type 'PassName' is also used just for debugging.
---
--- Note that the result is a fixed point with no contents, that is,
--- the contents have type ().
---
--- The intent of the rest of the type signature should be obvious.
--- If not, place a skype call to norman-ramsey or complain bitterly
--- to <norman-ramsey@acm.org>.
-
-class DataflowSolverDirection transfers fixedpt where
- zdfSolveFrom :: (DebugNodes m l, Outputable a)
- => BlockEnv a -- ^ Initial facts (unbound == bottom)
- -> PassName
- -> DataflowLattice a -- ^ Lattice
- -> transfers m l a -- ^ Dataflow transfer functions
- -> a -- ^ Fact flowing in (at entry or exit)
- -> Graph m l -- ^ Graph to be analyzed
- -> FuelMonad (fixedpt m l a ()) -- ^ Answers
- zdfSolveFromL :: (DebugNodes m l, Outputable a)
- => BlockEnv a -- Initial facts (unbound == bottom)
- -> PassName
- -> DataflowLattice a -- Lattice
- -> transfers m l a -- Dataflow transfer functions
- -> a -- Fact flowing in (at entry or exit)
- -> LGraph m l -- Graph to be analyzed
- -> FuelMonad (fixedpt m l a ()) -- Answers
- zdfSolveFromL b p l t a g = zdfSolveFrom b p l t a $ quickGraph g
-
--- There are exactly two instances: forward and backward
-instance DataflowSolverDirection ForwardTransfers ForwardFixedPoint
- where zdfSolveFrom = solve_f
-
-instance DataflowSolverDirection BackwardTransfers BackwardFixedPoint
- where zdfSolveFrom = solve_b
-
-
--- | zdfRewriteFrom is an overloaded name that resolves to an
--- interleaved analysis and transformation. It too is instantiated in
--- forward and backward directions.
---
--- The type parameters of the class include not only transfer
--- functions and the fixed point but also rewrites.
---
--- The type signature of 'zdfRewriteFrom' is that of 'zdfSolveFrom'
--- with the rewrites and a rewriting depth as additional parameters,
--- as well as a different result, which contains a rewritten graph.
-
-class DataflowSolverDirection transfers fixedpt =>
- DataflowDirection transfers fixedpt rewrites where
- zdfRewriteFrom :: (DebugNodes m l, Outputable a)
- => RewritingDepth -- whether to rewrite a rewritten graph
- -> BlockEnv a -- initial facts (unbound == bottom)
- -> PassName
- -> DataflowLattice a
- -> transfers m l a
- -> rewrites m l a
- -> a -- fact flowing in (at entry or exit)
- -> Graph m l
- -> FuelMonad (fixedpt m l a (Graph m l))
-
--- Temporarily lifting from Graph to LGraph -- an experiment to see how we
--- can eliminate some hysteresis between Graph and LGraph.
--- Perhaps Graph should be confined to dataflow code.
--- Trading space for time
-quickGraph :: LastNode l => LGraph m l -> Graph m l
-quickGraph g = Graph (ZLast $ mkBranchNode $ lg_entry g) $ lg_blocks g
-
-quickLGraph :: LastNode l => Graph m l -> FuelMonad (LGraph m l)
-quickLGraph (Graph (ZLast (LastOther l)) blockenv)
- | isBranchNode l = return $ LGraph (branchNodeTarget l) blockenv
-quickLGraph g = F.lGraphOfGraph g
-
-fixptWithLGraph :: LastNode l => CommonFixedPoint m l fact (Graph m l) ->
- FuelMonad (CommonFixedPoint m l fact (LGraph m l))
-fixptWithLGraph cfp =
- do fp_c <- quickLGraph $ fp_contents cfp
- return $ cfp {fp_contents = fp_c}
-
-ffixptWithLGraph :: LastNode l => ForwardFixedPoint m l fact (Graph m l) ->
- FuelMonad (ForwardFixedPoint m l fact (LGraph m l))
-ffixptWithLGraph fp =
- do common <- fixptWithLGraph $ ffp_common fp
- return $ fp {ffp_common = common}
-
-zdfFRewriteFromL :: (DebugNodes m l, Outputable a)
- => RewritingDepth -- whether to rewrite a rewritten graph
- -> BlockEnv a -- initial facts (unbound == bottom)
- -> PassName
- -> DataflowLattice a
- -> ForwardTransfers m l a
- -> ForwardRewrites m l a
- -> a -- fact flowing in (at entry or exit)
- -> LGraph m l
- -> FuelMonad (ForwardFixedPoint m l a (LGraph m l))
-zdfFRewriteFromL d b p l t r a g@(LGraph _ _) =
- do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
- ffixptWithLGraph fp
-
-zdfBRewriteFromL :: (DebugNodes m l, Outputable a)
- => RewritingDepth -- whether to rewrite a rewritten graph
- -> BlockEnv a -- initial facts (unbound == bottom)
- -> PassName
- -> DataflowLattice a
- -> BackwardTransfers m l a
- -> BackwardRewrites m l a
- -> a -- fact flowing in (at entry or exit)
- -> LGraph m l
- -> FuelMonad (BackwardFixedPoint m l a (LGraph m l))
-zdfBRewriteFromL d b p l t r a g@(LGraph _ _) =
- do fp <- zdfRewriteFrom d b p l t r a $ quickGraph g
- fixptWithLGraph fp
-
-
-data RewritingDepth = RewriteShallow | RewriteDeep
--- When a transformation proposes to rewrite a node,
--- you can either ask the system to
--- * "shallow": accept the new graph, analyse it without further rewriting
--- * "deep": recursively analyse-and-rewrite the new graph
-
-
--- There are currently four instances, but there could be more
--- forward, backward (instantiates transfers, fixedpt, rewrites)
--- Graph, AGraph (instantiates graph)
-
-instance DataflowDirection ForwardTransfers ForwardFixedPoint ForwardRewrites
- where zdfRewriteFrom = rewrite_f_agraph
-
-instance DataflowDirection BackwardTransfers BackwardFixedPoint BackwardRewrites
- where zdfRewriteFrom = rewrite_b_agraph
-
-
-{- =================== IMPLEMENTATIONS ===================== -}
-
-
------------------------------------------------------------
--- solve_f: forward, pure
-
-solve_f :: (DebugNodes m l, Outputable a)
- => BlockEnv a -- initial facts (unbound == bottom)
- -> PassName
- -> DataflowLattice a -- lattice
- -> ForwardTransfers m l a -- dataflow transfer functions
- -> a
- -> Graph m l -- graph to be analyzed
- -> FuelMonad (ForwardFixedPoint m l a ()) -- answers
-solve_f env name lattice transfers in_fact g =
- runDFM lattice $ fwd_pure_anal name env transfers in_fact g
-
-rewrite_f_agraph :: (DebugNodes m l, Outputable a)
- => RewritingDepth
- -> BlockEnv a
- -> PassName
- -> DataflowLattice a
- -> ForwardTransfers m l a
- -> ForwardRewrites m l a
- -> a -- fact flowing in (at entry or exit)
- -> Graph m l
- -> FuelMonad (ForwardFixedPoint m l a (Graph m l))
-rewrite_f_agraph depth start_facts name lattice transfers rewrites in_fact g =
- runDFM lattice $
- do fuel <- fuelRemaining
- (fp, fuel') <- forward_rew maybeRewriteWithFuel depth start_facts name
- transfers rewrites in_fact g fuel
- fuelDecrement name fuel fuel'
- return fp
-
-areturn :: AGraph m l -> DFM a (Graph m l)
-areturn g = liftToDFM $ liftUniq $ graphOfAGraph g
-
--- | Here we prefer not simply to slap on 'goto eid' because this
--- introduces an unnecessary basic block at each rewrite, and we don't
--- want to stress out the finite map more than necessary
-lgraphToGraph :: LastNode l => LGraph m l -> Graph m l
-lgraphToGraph (LGraph eid blocks) =
- if flip any (eltsBlockEnv blocks) $ \block -> any (== eid) (succs block) then
- Graph (ZLast (mkBranchNode eid)) blocks
- else -- common case: entry is not a branch target
- let Block _ entry = lookupBlockEnv blocks eid `orElse` panic "missing entry!"
- in Graph entry (delFromBlockEnv blocks eid)
-
-
-class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l
-
-fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
- => PassName
- -> BlockEnv a
- -> ForwardTransfers m l a
- -> a
- -> Graph m l
- -> DFM a (ForwardFixedPoint m l a ())
-
-fwd_pure_anal name env transfers in_fact g =
- do (fp, _) <- anal_f name env transfers panic_rewrites in_fact g panic_fuel
- return fp
- where -- definitely a case of "I love lazy evaluation"
- anal_f = forward_sol (\_ _ -> Nothing) panic_depth
- panic_rewrites = panic "pure analysis asked for a rewrite function"
- panic_fuel = panic "pure analysis asked for fuel"
- panic_depth = panic "pure analysis asked for a rewrite depth"
-
------------------------------------------------------------------------
---
--- Here beginneth the super-general functions
---
--- Think of them as (typechecked) macros
--- * They are not exported
---
--- * They are called by the specialised wrappers
--- above, and always inlined into their callers
---
--- There are four functions, one for each combination of:
--- Forward, Backward
--- Solver, Rewriter
---
--- A "solver" produces a (DFM f (f, Fuel)),
--- where f is the fact at entry(Bwd)/exit(Fwd)
--- and from the DFM you can extract
--- the BlockId->f
--- the change-flag
--- and more besides
---
--- A "rewriter" produces a rewritten *Graph* as well
---
--- Both constrain their rewrites by
--- a) Fuel
--- b) RewritingDepth: shallow/deep
-
------------------------------------------------------------------------
-
-type Fuel = OptimizationFuel
-
-forward_sol
- :: forall m l a .
- (DebugNodes m l, LastNode l, Outputable a)
- => (forall a . Fuel -> Maybe a -> Maybe a)
- -- Squashes proposed rewrites if there is
- -- no more fuel; OR if we are doing a pure
- -- analysis, so totally ignore the rewrite
- -- ie. For pure-analysis the fn is (\_ _ -> Nothing)
- -> RewritingDepth -- Shallow/deep
- -> PassName
- -> BlockEnv a -- Initial set of facts
- -> ForwardTransfers m l a
- -> ForwardRewrites m l a
- -> a -- Entry fact
- -> Graph m l
- -> Fuel
- -> DFM a (ForwardFixedPoint m l a (), Fuel)
-forward_sol check_maybe = forw
- where
- forw :: RewritingDepth
- -> PassName
- -> BlockEnv a
- -> ForwardTransfers m l a
- -> ForwardRewrites m l a
- -> a
- -> Graph m l
- -> Fuel
- -> DFM a (ForwardFixedPoint m l a (), Fuel)
- forw rewrite name start_facts transfers rewrites =
- let anal_f :: DFM a b -> a -> Graph m l -> DFM a b
- anal_f finish in' g =
- do { _ <- fwd_pure_anal name emptyBlockEnv transfers in' g; finish }
-
- solve :: DFM a b -> a -> Graph m l -> Fuel -> DFM a (b, Fuel)
- solve finish in_fact (Graph entry blockenv) fuel =
- let blocks = G.postorder_dfs_from blockenv entry
- set_or_save = mk_set_or_save (isJust . lookupBlockEnv blockenv)
- set_successor_facts (Block id tail) fuel =
- do { idfact <- getFact id
- ; (last_outs, fuel) <- rec_rewrite (fr_first rewrites id idfact)
- (ft_first_out transfers id idfact)
- getExitFact (solve_tail tail)
- (solve_tail tail) idfact fuel
- ; set_or_save last_outs
- ; return fuel }
- in do { (last_outs, fuel) <- solve_tail entry in_fact fuel
- -- last_outs contains a mix of internal facts, which
- -- are inputs to 'run', and external facts, which
- -- are going to be forgotten by 'run'
- ; set_or_save last_outs
- ; fuel <- run "forward" name set_successor_facts blocks fuel
- ; set_or_save last_outs
- -- Re-set facts that may have been forgotten by run
- ; b <- finish
- ; return (b, fuel)
- }
-
- -- The need for both k1 and k2 suggests that maybe there's an opportunity
- -- for improvement here -- in most cases, they're the same...
- rec_rewrite :: forall t bI bW.
- Maybe (AGraph m l) -> t -> DFM a bW
- -> (t -> Fuel -> DFM a bI)
- -> (bW -> Fuel -> DFM a bI)
- -> a -> Fuel -> DFM a bI
- rec_rewrite rewritten analyzed finish k1 k2 in' fuel =
- case check_maybe fuel rewritten of -- fr_first rewrites id idfact of
- Nothing -> k1 analyzed fuel
- Just g -> do g <- areturn g
- (a, fuel) <- subAnalysis' $
- case rewrite of
- RewriteDeep -> solve finish in' g (oneLessFuel fuel)
- RewriteShallow -> do { a <- anal_f finish in' g
- ; return (a, oneLessFuel fuel) }
- k2 a fuel
- solve_tail (G.ZTail m t) in' fuel =
- rec_rewrite (fr_middle rewrites m in') (ft_middle_out transfers m in')
- getExitFact (solve_tail t) (solve_tail t) in' fuel
- solve_tail (G.ZLast (LastOther l)) in' fuel =
- rec_rewrite (fr_last rewrites l in') (ft_last_outs transfers l in')
- lastOutFacts k k in' fuel
- where k a b = return (a, b)
- solve_tail (G.ZLast LastExit) in' fuel =
- rec_rewrite (fr_exit rewrites in') (ft_exit_out transfers in')
- lastOutFacts k (\a b -> return (a, b)) in' fuel
- where k a fuel = do { setExitFact a ; return (LastOutFacts [], fuel) }
-
- fixed_point in_fact g fuel =
- do { setAllFacts start_facts
- ; (a, fuel) <- solve getExitFact in_fact g fuel
- ; facts <- getAllFacts
- ; last_outs <- lastOutFacts
- ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
- ; let fp = FFP cfp last_outs
- ; return (fp, fuel)
- }
- in fixed_point
-
-
-
-
-mk_set_or_save :: (DataflowAnalysis df, Monad (df a), Outputable a) =>
- (BlockId -> Bool) -> LastOutFacts a -> df a ()
-mk_set_or_save is_local (LastOutFacts l) = mapM_ set_or_save_one l
- where set_or_save_one (id, a) =
- if is_local id then setFact id a else addLastOutFact (id, a)
-
-
-
-forward_rew
- :: forall m l a .
- (DebugNodes m l, LastNode l, Outputable a)
- => (forall a . Fuel -> Maybe a -> Maybe a)
- -> RewritingDepth
- -> BlockEnv a
- -> PassName
- -> ForwardTransfers m l a
- -> ForwardRewrites m l a
- -> a
- -> Graph m l
- -> Fuel
- -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
-forward_rew check_maybe = forw
- where
- forw :: RewritingDepth
- -> BlockEnv a
- -> PassName
- -> ForwardTransfers m l a
- -> ForwardRewrites m l a
- -> a
- -> Graph m l
- -> Fuel
- -> DFM a (ForwardFixedPoint m l a (Graph m l), Fuel)
- forw depth xstart_facts name transfers rewrites in_factx gx fuelx =
- let rewrite :: BlockEnv a -> DFM a b
- -> a -> Graph m l -> Fuel
- -> DFM a (b, Graph m l, Fuel)
- rewrite start finish in_fact g fuel =
- in_fact `seq` g `seq`
- let Graph entry blockenv = g
- blocks = G.postorder_dfs_from blockenv entry
- in do { _ <- forward_sol check_maybe depth name start
- transfers rewrites in_fact g fuel
- ; eid <- freshBlockId "temporary entry id"
- ; (rewritten, fuel) <-
- rew_tail (ZFirst eid) in_fact entry emptyBlockEnv fuel
- ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel
- ; a <- finish
- ; return (a, lgraphToGraph (LGraph eid rewritten), fuel)
- }
-
- don't_rewrite :: forall t.
- BlockEnv a -> DFM a t -> a
- -> Graph m l -> Fuel
- -> DFM a (t, Graph m l, Fuel)
- don't_rewrite facts finish in_fact g fuel =
- do { _ <- forward_sol check_maybe depth name facts
- transfers rewrites in_fact g fuel
- ; a <- finish
- ; return (a, g, fuel)
- }
-
- inner_rew :: DFM a f -> a -> Graph m l -> Fuel -> DFM a (f, Graph m l, Fuel)
- inner_rew f i g fu = getAllFacts >>= \facts -> inner_rew' facts f i g fu
- where inner_rew' = case depth of RewriteShallow -> don't_rewrite
- RewriteDeep -> rewrite
- fixed_pt_and_fuel =
- do { (a, g, fuel) <- rewrite xstart_facts getExitFact in_factx gx fuelx
- ; facts <- getAllFacts
- ; changed <- graphWasRewritten
- ; last_outs <- lastOutFacts
- ; let cfp = FP facts a changed (panic "no decoration?!") g
- ; let fp = FFP cfp last_outs
- ; return (fp, fuel)
- }
-
--- JD: WHY AREN'T WE TAKING ANY FUEL HERE?
- rewrite_blocks :: [Block m l] -> (BlockEnv (Block m l))
- -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
- rewrite_blocks [] rewritten fuel = return (rewritten, fuel)
- rewrite_blocks (G.Block id t : bs) rewritten fuel =
- do let h = ZFirst id
- a <- getFact id
- case check_maybe fuel $ fr_first rewrites id a of
- Nothing -> do { (rewritten, fuel) <-
- rew_tail h (ft_first_out transfers id a)
- t rewritten fuel
- ; rewrite_blocks bs rewritten fuel }
- Just g -> do { markGraphRewritten
- ; g <- areturn g
- ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel
- ; let (blocks, h) = splice_head' h g
- ; (rewritten, fuel) <-
- rew_tail h outfact t (blocks `plusBlockEnv` rewritten) fuel
- ; rewrite_blocks bs rewritten fuel }
-
- rew_tail head in' (G.ZTail m t) rewritten fuel =
- in' `seq` rewritten `seq`
- my_trace "Rewriting middle node" (ppr m) $
- case check_maybe fuel $ fr_middle rewrites m in' of
- Nothing -> rew_tail (G.ZHead head m) (ft_middle_out transfers m in') t
- rewritten fuel
- Just g -> do { markGraphRewritten
- ; g <- areturn g
- ; (a, g, fuel) <- inner_rew getExitFact in' g fuel
- ; let (blocks, h) = G.splice_head' head g
- ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel
- }
- rew_tail h in' (G.ZLast l) rewritten fuel =
- in' `seq` rewritten `seq`
- my_trace "Rewriting last node" (ppr l) $
- case check_maybe fuel $ either_last rewrites in' l of
- Nothing -> do check_facts in' l
- return (insertBlock (zipht h (G.ZLast l)) rewritten, fuel)
- Just g -> do { markGraphRewritten
- ; g <- areturn g
- ; ((), g, fuel) <-
- my_trace "Just" (ppr g) $ inner_rew (return ()) in' g fuel
- ; let g' = G.splice_head_only' h g
- ; return (G.lg_blocks g' `plusBlockEnv` rewritten, fuel)
- }
- either_last rewrites in' (LastExit) = fr_exit rewrites in'
- either_last rewrites in' (LastOther l) = fr_last rewrites l in'
- check_facts in' (LastOther l) =
- let LastOutFacts last_outs = ft_last_outs transfers l in'
- in mapM_ (uncurry checkFactMatch) last_outs
- check_facts _ LastExit = return ()
- in fixed_pt_and_fuel
-
-lastOutFacts :: DFM f (LastOutFacts f)
-lastOutFacts = bareLastOutFacts >>= return . LastOutFacts
-
-{- ================================================================ -}
-
-solve_b :: (DebugNodes m l, Outputable a)
- => BlockEnv a -- initial facts (unbound == bottom)
- -> PassName
- -> DataflowLattice a -- lattice
- -> BackwardTransfers m l a -- dataflow transfer functions
- -> a -- exit fact
- -> Graph m l -- graph to be analyzed
- -> FuelMonad (BackwardFixedPoint m l a ()) -- answers
-solve_b env name lattice transfers exit_fact g =
- runDFM lattice $ bwd_pure_anal name env transfers g exit_fact
-
-
-rewrite_b_agraph :: (DebugNodes m l, Outputable a)
- => RewritingDepth
- -> BlockEnv a
- -> PassName
- -> DataflowLattice a
- -> BackwardTransfers m l a
- -> BackwardRewrites m l a
- -> a -- fact flowing in at exit
- -> Graph m l
- -> FuelMonad (BackwardFixedPoint m l a (Graph m l))
-rewrite_b_agraph depth start_facts name lattice transfers rewrites exit_fact g =
- runDFM lattice $
- do fuel <- fuelRemaining
- (fp, fuel') <- backward_rew maybeRewriteWithFuel depth start_facts name
- transfers rewrites g exit_fact fuel
- fuelDecrement name fuel fuel'
- return fp
-
-
-
-backward_sol
- :: forall m l a .
- (DebugNodes m l, LastNode l, Outputable a)
- => (forall a . Fuel -> Maybe a -> Maybe a)
- -> RewritingDepth
- -> PassName
- -> BlockEnv a
- -> BackwardTransfers m l a
- -> BackwardRewrites m l a
- -> Graph m l
- -> a
- -> Fuel
- -> DFM a (BackwardFixedPoint m l a (), Fuel)
-backward_sol check_maybe = back
- where
- back :: RewritingDepth
- -> PassName
- -> BlockEnv a
- -> BackwardTransfers m l a
- -> BackwardRewrites m l a
- -> Graph m l
- -> a
- -> Fuel
- -> DFM a (BackwardFixedPoint m l a (), Fuel)
- back rewrite name start_facts transfers rewrites =
- let anal_b :: Graph m l -> a -> DFM a a
- anal_b g out =
- do { fp <- bwd_pure_anal name emptyBlockEnv transfers g out
- ; return $ zdfFpOutputFact fp }
-
- subsolve :: AGraph m l -> a -> Fuel -> DFM a (a, Fuel)
- subsolve =
- case rewrite of
- RewriteDeep -> \g a fuel ->
- subAnalysis' $ do { g <- areturn g; solve g a (oneLessFuel fuel) }
- RewriteShallow -> \g a fuel ->
- subAnalysis' $ do { g <- areturn g; a <- anal_b g a
- ; return (a, oneLessFuel fuel) }
-
- solve :: Graph m l -> a -> Fuel -> DFM a (a, Fuel)
- solve (Graph entry blockenv) exit_fact fuel =
- let blocks = reverse $ G.postorder_dfs_from blockenv entry
- last_in _env (LastExit) = exit_fact
- last_in env (LastOther l) = bt_last_in transfers l env
- last_rew _env (LastExit) = br_exit rewrites
- last_rew env (LastOther l) = br_last rewrites l env
- set_block_fact block fuel =
- let (h, l) = G.goto_end (G.unzip block) in
- do { env <- factsEnv
- ; (a, fuel) <-
- case check_maybe fuel $ last_rew env l of
- Nothing -> return (last_in env l, fuel)
- Just g -> do g' <- areturn g
- my_trace "analysis rewrites last node"
- (ppr l <+> pprGraph g') $
- subsolve g exit_fact fuel
- ; _ <- set_head_fact h a fuel
- ; return fuel }
-
- in do { fuel <- run "backward" name set_block_fact blocks fuel
- ; eid <- freshBlockId "temporary entry id"
- ; fuel <- set_block_fact (Block eid entry) fuel
- ; a <- getFact eid
- ; forgetFact eid
- ; return (a, fuel)
- }
-
- set_head_fact (G.ZFirst id) a fuel =
- case check_maybe fuel $ br_first rewrites id a of
- Nothing -> do { my_trace "set_head_fact" (ppr id <+> text "=" <+>
- ppr (bt_first_in transfers id a)) $
- setFact id $ bt_first_in transfers id a
- ; return fuel }
- Just g -> do { g' <- areturn g
- ; (a, fuel) <- my_trace "analysis rewrites first node"
- (ppr id <+> pprGraph g') $
- subsolve g a fuel
- ; setFact id $ bt_first_in transfers id a
- ; return fuel
- }
- set_head_fact (G.ZHead h m) a fuel =
- case check_maybe fuel $ br_middle rewrites m a of
- Nothing -> set_head_fact h (bt_middle_in transfers m a) fuel
- Just g -> do { g' <- areturn g
- ; (a, fuel) <- my_trace "analysis rewrites middle node"
- (ppr m <+> pprGraph g') $
- subsolve g a fuel
- ; set_head_fact h a fuel }
-
- fixed_point g exit_fact fuel =
- do { setAllFacts start_facts
- ; (a, fuel) <- solve g exit_fact fuel
- ; facts <- getAllFacts
- ; let cfp = FP facts a NoChange (panic "no decoration?!") ()
- ; return (cfp, fuel)
- }
- in fixed_point
-
-bwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable a)
- => PassName
- -> BlockEnv a
- -> BackwardTransfers m l a
- -> Graph m l
- -> a
- -> DFM a (BackwardFixedPoint m l a ())
-
-bwd_pure_anal name env transfers g exit_fact =
- do (fp, _) <- anal_b name env transfers panic_rewrites g exit_fact panic_fuel
- return fp
- where -- another case of "I love lazy evaluation"
- anal_b = backward_sol (\_ _ -> Nothing) panic_depth
- panic_rewrites = panic "pure analysis asked for a rewrite function"
- panic_fuel = panic "pure analysis asked for fuel"
- panic_depth = panic "pure analysis asked for a rewrite depth"
-
-
-{- ================================================================ -}
-
-backward_rew
- :: forall m l a .
- (DebugNodes m l, LastNode l, Outputable a)
- => (forall a . Fuel -> Maybe a -> Maybe a)
- -> RewritingDepth
- -> BlockEnv a
- -> PassName
- -> BackwardTransfers m l a
- -> BackwardRewrites m l a
- -> Graph m l
- -> a
- -> Fuel
- -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
-backward_rew check_maybe = back
- where
- solve = backward_sol check_maybe
- back :: RewritingDepth
- -> BlockEnv a
- -> PassName
- -> BackwardTransfers m l a
- -> BackwardRewrites m l a
- -> Graph m l
- -> a
- -> Fuel
- -> DFM a (BackwardFixedPoint m l a (Graph m l), Fuel)
- back depth xstart_facts name transfers rewrites gx exit_fact fuelx =
- let rewrite :: BlockEnv a
- -> Graph m l -> a -> Fuel
- -> DFM a (a, Graph m l, Fuel)
- rewrite start g exit_fact fuel =
- let Graph entry blockenv = g
- blocks = reverse $ G.postorder_dfs_from blockenv entry
- in do { (FP _ in_fact _ _ _, _) <- -- don't drop the entry fact!
- solve depth name start transfers rewrites g exit_fact fuel
- --; env <- getAllFacts
- -- ; my_trace "facts after solving" (ppr env) $ return ()
- ; eid <- freshBlockId "temporary entry id"
- ; (rewritten, fuel) <- rewrite_blocks True blocks emptyBlockEnv fuel
- -- We can't have the fact check fail on the bogus entry, which _may_ change
- ; (rewritten, fuel) <-
- rewrite_blocks False [Block eid entry] rewritten fuel
- ; my_trace "eid" (ppr eid) $ return ()
- ; my_trace "exit_fact" (ppr exit_fact) $ return ()
- ; my_trace "in_fact" (ppr in_fact) $ return ()
- ; return (in_fact, lgraphToGraph (LGraph eid rewritten), fuel)
- } -- Remember: the entry fact computed by @solve@ accounts for rewriting
- don't_rewrite facts g exit_fact fuel =
- do { (fp, _) <-
- solve depth name facts transfers rewrites g exit_fact fuel
- ; return (zdfFpOutputFact fp, g, fuel) }
- inner_rew :: Graph m l -> a -> Fuel -> DFM a (a, Graph m l, Fuel)
- inner_rew g a f = getAllFacts >>= \facts -> inner_rew' facts g a f
- where inner_rew' = case depth of RewriteShallow -> don't_rewrite
- RewriteDeep -> rewrite
- fixed_pt_and_fuel =
- do { (a, g, fuel) <- rewrite xstart_facts gx exit_fact fuelx
- ; facts <- getAllFacts
- ; changed <- graphWasRewritten
- ; let fp = FP facts a changed (panic "no decoration?!") g
- ; return (fp, fuel)
- }
- rewrite_blocks :: Bool -> [Block m l] -> (BlockEnv (Block m l))
- -> Fuel -> DFM a (BlockEnv (Block m l), Fuel)
- rewrite_blocks check bs rewritten fuel =
- do { env <- factsEnv
- ; let rew [] r f = return (r, f)
- rew (b : bs) r f =
- do { (r, f) <- rewrite_block check env b r f; rew bs r f }
- ; rew bs rewritten fuel }
- rewrite_block check env b rewritten fuel =
- let (h, l) = G.goto_end (G.unzip b) in
- case maybeRewriteWithFuel fuel $ either_last env l of
- Nothing -> propagate check fuel h (last_in env l) (ZLast l) rewritten
- Just g ->
- do { markGraphRewritten
- ; g <- areturn g
- ; (a, g, fuel) <- inner_rew g exit_fact fuel
- ; let G.Graph t new_blocks = g
- ; let rewritten' = new_blocks `plusBlockEnv` rewritten
- ; propagate check fuel h a t rewritten' -- continue at entry of g
- }
- either_last _env (LastExit) = br_exit rewrites
- either_last env (LastOther l) = br_last rewrites l env
- last_in _env (LastExit) = exit_fact
- last_in env (LastOther l) = bt_last_in transfers l env
- propagate check fuel (ZHead h m) a tail rewritten =
- case maybeRewriteWithFuel fuel $ br_middle rewrites m a of
- Nothing ->
- propagate check fuel h (bt_middle_in transfers m a) (ZTail m tail) rewritten
- Just g ->
- do { markGraphRewritten
- ; g <- areturn g
- ; my_trace "With Facts" (ppr a) $ return ()
- ; my_trace " Rewrote middle node"
- (f4sep [ppr m, text "to", pprGraph g]) $
- return ()
- ; (a, g, fuel) <- inner_rew g a fuel
- ; let Graph t newblocks = G.splice_tail g tail
- ; my_trace "propagating facts" (ppr a) $
- propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) }
- propagate check fuel (ZFirst id) a tail rewritten =
- case maybeRewriteWithFuel fuel $ br_first rewrites id a of
- Nothing -> do { if check then
- checkFactMatch id $ bt_first_in transfers id a
- else return ()
- ; return (insertBlock (Block id tail) rewritten, fuel) }
- Just g ->
- do { markGraphRewritten
- ; g <- areturn g
- ; my_trace "Rewrote first node"
- (f4sep [ppr id <> colon, text "to", pprGraph g]) $ return ()
- ; (a, g, fuel) <- inner_rew g a fuel
- ; if check then checkFactMatch id (bt_first_in transfers id a)
- else return ()
- ; let Graph t newblocks = G.splice_tail g tail
- ; let r = insertBlock (Block id t) (newblocks `plusBlockEnv` rewritten)
- ; return (r, fuel) }
- in fixed_pt_and_fuel
-
-{- ================================================================ -}
-
-instance FixedPoint CommonFixedPoint where
- zdfFpFacts = fp_facts
- zdfFpOutputFact = fp_out
- zdfGraphChanged = fp_changed
- zdfDecoratedGraph = fp_dec_graph
- zdfFpContents = fp_contents
- zdfFpMap f (FP fs out ch dg a) = FP fs out ch dg (f a)
-
-instance FixedPoint ForwardFixedPoint where
- zdfFpFacts = fp_facts . ffp_common
- zdfFpOutputFact = fp_out . ffp_common
- zdfGraphChanged = fp_changed . ffp_common
- zdfDecoratedGraph = fp_dec_graph . ffp_common
- zdfFpContents = fp_contents . ffp_common
- zdfFpMap f (FFP fp los) = FFP (zdfFpMap f fp) los
-
-
-dump_things :: Bool
-dump_things = False
-
-my_trace :: String -> SDoc -> a -> a
-my_trace = if dump_things then pprTrace else \_ _ a -> a
-
-
--- | Here's a function to run an action on blocks until we reach a fixed point.
-run :: (Outputable a, DebugNodes m l) =>
- String -> String -> (Block m l -> b -> DFM a b) -> [Block m l] -> b -> DFM a b
-run dir name do_block blocks b =
- do { show_blocks $ iterate (1::Int) }
- where
- -- N.B. Each iteration starts with the same transaction limit;
- -- only the rewrites in the final iteration actually count
- trace_block (b, cnt) block =
- do b' <- my_trace "about to do" (text name <+> text "on" <+>
- ppr (blockId block) <+> ppr cnt) $
- do_block block b
- return (b', cnt + 1)
- iterate n =
- do { forgetLastOutFacts
- ; markFactsUnchanged
- ; (b, _) <- foldM trace_block (b, 0 :: Int) blocks
- ; changed <- factsStatus
- ; facts <- getAllFacts
- ; let depth = 0 -- was nesting depth
- ; ppIter depth n $
- case changed of
- NoChange -> unchanged depth $ return b
- SomeChange ->
- pprFacts depth n facts $
- if n < 1000 then iterate (n+1)
- else panic $ msg n
- }
- msg n = concat [name, " didn't converge in ", show n, " " , dir,
- " iterations"]
- my_nest depth sdoc = my_trace "" $ nest (3*depth) sdoc
- ppIter depth n = my_nest depth (empty $$ text "*************** iteration" <+> pp_i n)
- pp_i n = int n <+> text "of" <+> text name <+> text "on" <+> graphId
- unchanged depth =
- my_nest depth (text "facts for" <+> graphId <+> text "are unchanged")
-
- graphId = case blocks of { Block id _ : _ -> ppr id ; [] -> text "<empty>" }
- show_blocks = my_trace "Blocks:" (vcat (map pprBlock blocks))
- pprBlock (Block id t) = nest 2 (pprFact (id, t))
- pprFacts depth n env =
- my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$
- (nest 2 $ vcat $ map pprFact $ blockEnvToList env))
-
-pprFact :: (Outputable a, Outputable b) => (a,b) -> SDoc
-pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-
-f4sep :: [SDoc] -> SDoc
-f4sep [] = fsep []
-f4sep (d:ds) = fsep (d : map (nest 4) ds)
-
-
-subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) =>
- m f a -> m f a
-subAnalysis' m =
- do { a <- subAnalysis $
- do { a <- m; -- facts <- getAllFacts
- ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $
- return a }
- -- ; facts <- getAllFacts
- ; -- my_trace "in parent analysis facts are" (pprFacts facts) $
- return a }
- -- where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env
- -- pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a)
-Notes on new codegen (Sept 09)\r
+Notes on new codegen (Aug 10)\r
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~\r
\r
Things to do:\r
+ - We insert spills for variables before the stack check! This is the reason for\r
+ some fishy code in StgCmmHeap.entryHeapCheck where we are doing some strange\r
+ things to fix up the stack pointer before GC calls/jumps.\r
\r
- - SDM (2010-02-26) can we remove the Foreign constructor from Convention?\r
- Reason: we never generate code for a function with the Foreign\r
- calling convention, and the code for calling foreign calls is generated\r
+ The reason spills are inserted before the sp check is that at the entry to a\r
+ function we always store the parameters passed in registers to local variables.\r
+ The spill pass simply inserts spills at variable definitions. We instead should\r
+ sink the spills so that we can avoid spilling them on branches that never\r
+ reload them.\r
+\r
+ This will fix the spill before stack check problem but only really as a side\r
+ effect. A 'real fix' probably requires making the spiller know about sp checks.\r
+\r
+ - There is some silly stuff happening with the Sp. We end up with code like:\r
+ Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8\r
+ Seems to be perhaps caused by the issue above but also maybe a optimisation\r
+ pass needed?\r
+\r
+ - Proc pass all arguments on the stack, adding more code and slowing down things\r
+ a lot. We either need to fix this or even better would be to get rid of\r
+ proc points.\r
+\r
+ - CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to\r
+ Old.Cmm. We should abstract it to work on both representations, it needs only to\r
+ convert a CmmInfoTable to [CmmStatic].\r
+\r
+ - The MkGraph currenty uses a different semantics for <*> than Hoopl. Maybe\r
+ we could convert codeGen/StgCmm* clients to the Hoopl's semantics?\r
+ It's all deeply unsatisfactory.\r
+\r
+ - Improve preformance of Hoopl.\r
+\r
+ A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters\r
+ (using the same ghc-cmm branch +libraries compiled by the old codegenerator)\r
+ is at http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.oldghchoopl.txt\r
+ - the code produced is 10.9% slower, the compilation is +118% slower!\r
\r
- - All dataflow analyses are in the FuelMonad, even though they\r
- are guarnteed to consume no fuel. This seems silly\r
+ The same comparison with ghc-head with zip representation is at\r
+ http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.oldghczip.txt\r
+ - the code produced is 11.7% slower, the compilation is +78% slower.\r
\r
- - CmmContFlowOpt.runCmmContFlowOptZs is not called!\r
- - Why is runCmmOpts called from HscMain? Seems too "high up".\r
- In fact HscMain calls (runCmmOpts cmmCfgOptsZ) which is what\r
- runCmmContFlowOptZs does. Tidy up!\r
+ When compiling nofib, ghc-cmm + libraries compiled with -fnew-codegen\r
+ is 23.7% slower (http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.hooplghcoldgen.txt).\r
+ When compiling nofib, ghc-head + libraries compiled with -fnew-codegen\r
+ is 31.4% slower (http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.zipghcoldgen.txt).\r
\r
+ So we generate a bit better code, but it takes us longer!\r
+\r
+ - Are all blockToNodeList and blockOfNodeList really needed? Maybe we could\r
+ splice blocks instead?\r
+\r
+ In the CmmContFlowOpt.blockConcat, using Dataflow seems too clumsy. Still,\r
+ a block catenation function would be probably nicer than blockToNodeList\r
+ / blockOfNodeList combo.\r
+\r
+ - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that\r
+ delete splitEntrySeq from HooplUtils.\r
+\r
+ - manifestSP seems to touch a lot of the graph representation. It is\r
+ also slow for CmmSwitch nodes O(block_nodes * switch_statements).\r
+ Maybe rewrite manifestSP to use Dataflow?\r
+\r
+ - Sort out Label, LabelMap, LabelSet versus BlockId, BlockEnv, BlockSet\r
+ dichotomy. Mostly this means global replace, but we also need to make\r
+ Label an instance of Outputable (probably in the Outputable module).\r
+\r
+ - NB that CmmProcPoint line 283 has a hack that works around a GADT-related\r
+ bug in 6.10.\r
+\r
+ - SDM (2010-02-26) can we remove the Foreign constructor from Convention?\r
+ Reason: we never generate code for a function with the Foreign\r
+ calling convention, and the code for calling foreign calls is generated\r
\r
- AsmCodeGen has a generic Cmm optimiser; move this into new pipeline\r
\r
- - AsmCodeGen has post-native-cg branch elimiator (shortCutBranches);\r
+ - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);\r
we ultimately want to share this with the Cmm branch eliminator.\r
\r
- At the moment, references to global registers like Hp are "lowered" \r
- late (in AsmCodeGen.fixAssignTop and cmmToCmm). We should do this\r
- early, in the new native codegen, much in the way that we lower \r
- calling conventions. Might need to be a bit sophisticated about\r
- aliasing.\r
-\r
- - Refactor Cmm so that it contains only shared stuff\r
- Add a module MoribundCmm which contains stuff from\r
- Cmm for old code gen path\r
+ late (in CgUtils.fixStgRegisters). We should do this early, in the\r
+ new native codegen, much in the way that we lower calling conventions.\r
+ Might need to be a bit sophisticated about aliasing.\r
\r
- Question: currently we lift procpoints to become separate\r
CmmProcs. Do we still want to do this?\r
\r
- See "CAFs" below; we want to totally refactor the way SRTs are calculated\r
\r
- - Change \r
- type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)\r
- to\r
- type CmmZ = GenCmm CmmStatic (CmmInfo, CmmStackInfo) CmmGraph\r
- -- And perhaps take opportunity to prune CmmInfo?\r
-\r
- - Clarify which fields of CmmInfo are still used\r
- - Maybe get rid of CmmFormals arg of CmmProc in all versions?\r
-\r
- - We aren't sure whether cmmToRawCmm is actively used by the new pipeline; check\r
- And what does CmmBuildInfoTables do?!\r
-\r
- - Nuke CmmZipUtil, move zipPreds into ZipCfg\r
-\r
- Pull out Areas into its own module\r
Parameterise AreaMap\r
Add ByteWidth = Int\r
-- rET_SMALL etc ==> CmmInfo\r
Check that there are no other imports from codeGen in cmm/\r
\r
+ - If you eliminate a label by branch chain elimination,\r
+ what happens if there's an Area associated with that label?\r
+\r
- Think about a non-flattened representation?\r
\r
- LastCall: \r
http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/NewCodeGenPipeline\r
\r
\r
- - We believe that all of CmmProcPointZ.addProcPointProtocols is dead. What\r
+ - We believe that all of CmmProcPoint.addProcPointProtocols is dead. What\r
goes wrong if we simply never call it?\r
\r
- Something fishy in CmmStackLayout.hs\r
move the whole splitting game into the C back end *only*\r
(guided by the procpoint set)\r
\r
- \r
----------------------------------------------------\r
Modules in cmm/\r
----------------------------------------------------\r
\r
--------- Dead stuff ------------\r
-CmmProcPoint Dead: Michael Adams\r
-CmmCPS Dead: Michael Adams\r
-CmmCPSGen.hs Dead: Michael Adams\r
-CmmBrokenBlock.hs Dead: Michael Adams\r
-CmmLive.hs Dead: Michael Adams\r
-CmmProcPoint.hs Dead: Michael Adams\r
-Dataflow.hs Dead: Michael Adams\r
-StackColor.hs Norman?\r
-StackPlacements.hs Norman?\r
-\r
+-------- Testing stuff ------------\r
HscMain.optionallyConvertAndOrCPS\r
testCmmConversion\r
-DynFlags: -fconvert-to-zipper-and-back, -frun-cps, -frun-cpsz\r
+DynFlags: -fconvert-to-zipper-and-back, -frun-cpsz\r
\r
-------- Moribund stuff ------------\r
+OldCmm.hs Definition of flowgraph of old representation\r
+OldCmmUtil.hs Utilites that operates mostly on on CmmStmt\r
+OldPprCmm.hs Pretty print for CmmStmt, GenBasicBlock and ListGraph\r
CmmCvt.hs Conversion between old and new Cmm reps\r
CmmOpt.hs Hopefully-redundant optimiser\r
-CmmZipUtil.hs Only one function; move elsewhere\r
\r
-------- Stuff to keep ------------\r
-CmmCPSZ.hs Driver for new pipeline\r
+CmmCPS.hs Driver for new pipeline\r
\r
-CmmLiveZ.hs Liveness analysis, dead code elim\r
-CmmProcPointZ.hs Identifying and splitting out proc-points\r
+CmmLive.hs Liveness analysis, dead code elim\r
+CmmProcPoint.hs Identifying and splitting out proc-points\r
\r
CmmSpillReload.hs Save and restore across calls\r
\r
-CmmCommonBlockElimZ.hs Common block elim\r
+CmmCommonBlockElim.hs Common block elim\r
CmmContFlowOpt.hs Other optimisations (branch-chain, merging)\r
\r
CmmBuildInfoTables.hs New info-table \r
CmmStackLayout.hs and stack layout \r
CmmCallConv.hs\r
-CmmInfo.hs Defn of InfoTables, and conversion to exact layout\r
+CmmInfo.hs Defn of InfoTables, and conversion to exact byte layout\r
\r
---------- Cmm data types --------------\r
-ZipCfgCmmRep.hs Cmm instantiations of dataflow graph framework\r
-MkZipCfgCmm.hs Cmm instantiations of dataflow graph framework\r
+Cmm.hs Cmm instantiations of dataflow graph framework\r
+MkGraph.hs Interface for building Cmm for codeGen/Stg*.hs modules\r
+\r
+CmmDecl.hs Shared Cmm types of both representations\r
+CmmExpr.hs Type of Cmm expression\r
+CmmType.hs Type of Cmm types and their widths\r
+CmmMachOp.hs MachOp type and accompanying utilities\r
\r
-Cmm.hs Key module; a mix of old and new stuff\r
- so needs tidying up in due course\r
-CmmExpr.hs\r
CmmUtils.hs\r
CmmLint.hs\r
\r
PprC.hs Pretty print Cmm in C syntax\r
-PprCmm.hs Pretty printer for Cmm\r
-PprCmmZ.hs Additional stuff for zipper rep\r
-\r
-CLabel.hs CLabel\r
-\r
----------- Dataflow modules --------------\r
- Goal: separate library; for now, separate directory\r
-\r
-MkZipCfg.hs\r
-ZipCfg.hs\r
-ZipCfgExtras.hs\r
-ZipDataflow.hs\r
-CmmTx.hs Transactions\r
-OptimizationFuel.hs Fuel\r
-BlockId.hs BlockId, BlockEnv, BlockSet\r
-DFMonad.hs \r
+PprCmm.hs Pretty printer for CmmGraph.\r
+PprCmmDecl.hs Pretty printer for common Cmm types.\r
+PprCmmExpr.hs Pretty printer for Cmm expressions.\r
\r
+CLabel.hs CLabel\r
+BlockId.hs BlockId, BlockEnv, BlockSet\r
\r
----------------------------------------------------\r
Top-level structure\r
* HscMain.tryNewCodeGen\r
- STG->Cmm: StgCmm.codeGen (new codegen)\r
- Optimise: CmmContFlowOpt (simple optimisations, very self contained)\r
- - Cps convert: CmmCPSZ.protoCmmCPSZ \r
+ - Cps convert: CmmCPS.protoCmmCPS \r
- Optimise: CmmContFlowOpt again\r
- Convert: CmmCvt.cmmOfZgraph (convert to old rep) very self contained\r
\r
\r
\r
----------------------------------------------------\r
- CmmCPSZ.protoCmmCPSZ The new pipeline\r
+ CmmCPS.protoCmmCPS The new pipeline\r
----------------------------------------------------\r
\r
-CmmCPSZprotoCmmCPSZ:\r
+CmmCPS.protoCmmCPS:\r
1. Do cpsTop for each procedures separately\r
2. Build SRT representation; this spans multiple procedures\r
(unless split-objs)\r
\r
cpsTop:\r
- * CmmCommonBlockElimZ.elimCommonBlocks:\r
+ * CmmCommonBlockElim.elimCommonBlocks:\r
eliminate common blocks \r
\r
- * CmmProcPointZ.minimalProcPointSet\r
+ * CmmProcPoint.minimalProcPointSet\r
identify proc-points\r
no change to graph\r
\r
- * CmmProcPointZ.addProcPointProtocols\r
+ * CmmProcPoint.addProcPointProtocols\r
something to do with the MA optimisation\r
probably entirely unnecessary\r
\r
Manifest the stack pointer\r
\r
* Split into separate procedures\r
- - CmmProcPointZ.procPointAnalysis\r
+ - CmmProcPoint.procPointAnalysis\r
Given set of proc points, which blocks are reachable from each\r
Claim: too few proc-points => code duplication, but program still works??\r
\r
- - CmmProcPointZ.splitAtProcPoints\r
+ - CmmProcPoint.splitAtProcPoints\r
Using this info, split into separate procedures\r
\r
- CmmBuildInfoTables.setInfoTableStackMap\r
Figuring out proc-points\r
~~~~~~~~~~~~~~~~~~~~~~~~\r
Proc-points are identified by\r
-CmmProcPointZ.minimalProcPointSet/extendPPSet Although there isn't\r
+CmmProcPoint.minimalProcPointSet/extendPPSet Although there isn't\r
that much code, JD thinks that it could be done much more nicely using\r
a dominator analysis, using the Dataflow Engine.\r
\r
f's keep-alive refs to include h1.\r
\r
* The SRT info is the C_SRT field of Cmm.ClosureTypeInfo in a\r
- CmmInfoTable attached to each CmmProc. CmmCPSZ.toTops actually does\r
+ CmmInfoTable attached to each CmmProc. CmmCPS.toTops actually does\r
the attaching, right at the end of the pipeline. The C_SRT part\r
gives offsets within a single, shared table of closure pointers.\r
\r
Foreign calls\r
----------------------------------------------------\r
\r
-See Note [Foreign calls] in ZipCfgCmmRep! This explains that a safe\r
+See Note [Foreign calls] in CmmNode! This explains that a safe\r
foreign call must do this:\r
save thread state\r
push info table (on thread stack) to describe frame\r
Cmm representations\r
----------------------------------------------------\r
\r
-* Cmm.hs\r
+* CmmDecl.hs\r
The type [GenCmm d h g] represents a whole module, \r
** one list element per .o file **\r
Without SplitObjs, the list has exactly one element\r
\r
\r
-------------\r
-OLD BACK END representations (Cmm.hs): \r
+OLD BACK END representations (OldCmm.hs): \r
type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt)\r
-- A whole module\r
newtype ListGraph i = ListGraph [GenBasicBlock i]\r
\r
-------------\r
NEW BACK END representations \r
-* Not Cmm-specific at all\r
- ZipCfg.hs defines Graph, LGraph, FGraph,\r
- ZHead, ZTail, ZBlock ...\r
+* Uses Hoopl library, a zero-boot package\r
+* CmmNode defines a node of a flow graph.\r
+* Cmm defines CmmGraph, CmmTop, Cmm\r
+ - CmmGraph is a closed/closed graph + an entry node.\r
\r
- classes LastNode, HavingSuccessors\r
+ data CmmGraph = CmmGraph { g_entry :: BlockId\r
+ , g_graph :: Graph CmmNode C C }\r
\r
- MkZipCfg.hs: AGraph: building graphs\r
+ - CmmTop is a top level chunk, specialization of GenCmmTop from CmmDecl.hs\r
+ with CmmGraph as a flow graph.\r
+ - Cmm is a collection of CmmTops.\r
\r
-* ZipCfgCmmRep: instantiates ZipCfg for Cmm\r
- data Middle = ...CmmExpr...\r
- data Last = ...CmmExpr...\r
- type CmmGraph = Graph Middle Last\r
+ type Cmm = GenCmm CmmStatic CmmTopInfo CmmGraph\r
+ type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph\r
\r
- type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)\r
- type CmmStackInfo = (ByteOff, Maybe ByteOff)\r
- -- (SP offset on entry, update frame space = SP offset on exit)\r
- -- The new codegen produces CmmZ, but once the stack is \r
- -- manifested we can drop that in favour of \r
- -- GenCmm CmmStatic CmmInfo CmmGraph\r
+ - CmmTop uses CmmTopInfo, which is a CmmInfoTable and CmmStackInfo\r
\r
- Inside a CmmProc:\r
- - CLabel: used\r
- - CmmInfo: partly used by NEW\r
- - CmmFormals: not used at all PERHAPS NOT EVEN BY OLD PIPELINE!\r
+ data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}\r
\r
-* MkZipCfgCmm.hs: smart constructors for ZipCfgCmmRep\r
- Depends on (a) MkZipCfg (Cmm-independent)\r
- (b) ZipCfgCmmRep (Cmm-specific)\r
+ - CmmStackInfo\r
\r
--------------\r
-* SHARED stuff\r
- CmmExpr.hs defines the Cmm expression types\r
- - CmmExpr, CmmReg, Width, CmmLit, LocalReg, GlobalReg\r
- - CmmType, Width etc (saparate module?)\r
- - MachOp (separate module?)\r
- - Area, AreaId etc (separate module?)\r
+ data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff}\r
\r
- BlockId.hs defines BlockId, BlockEnv, BlockSet\r
+ * arg_space = SP offset on entry\r
+ * updfr_space space = SP offset on exit\r
+ Once the staci is manifested, we could drom CmmStackInfo, ie. get\r
+ GenCmm CmmStatic CmmInfoTable CmmGraph, but we do not do that currently.\r
\r
--------------\r
\r
+* MkGraph.hs: smart constructors for Cmm.hs\r
+ Beware, the CmmAGraph defined here does not use AGraph from Hoopl,\r
+ as CmmAGraph can be opened or closed at exit, See the notes in that module.\r
\r
-------------\r
-* Transactions indicate whether or not the result changes: CmmTx \r
- type Tx a = a -> TxRes a\r
- data TxRes a = TxRes ChangeFlag a\r
+* SHARED stuff\r
+ CmmDecl.hs - GenCmm and GenCmmTop types\r
+ CmmExpr.hs - defines the Cmm expression types\r
+ - CmmExpr, CmmReg, CmmLit, LocalReg, GlobalReg\r
+ - Area, AreaId etc (separate module?)\r
+ CmmType.hs - CmmType, Width etc (saparate module?)\r
+ CmmMachOp.hs - MachOp and CallishMachOp types\r
+\r
+ BlockId.hs defines BlockId, BlockEnv, BlockSet\r
+-------------\r
import ClosureInfo
import Constants
-import Cmm
+import OldCmm
import PprCmm ( {- instance Outputable -} )
import SMRep
import Id
import CgMonad
import SMRep
-import Cmm
+import OldCmm
import CLabel
import Constants
import ClosureInfo
import CgStackery
-import CmmUtils
+import OldCmmUtils
import Maybes
import Id
import Name
import ClosureInfo
import SMRep
-import CmmUtils
-import Cmm
+import OldCmmUtils
+import OldCmm
import StgSyn
import StaticFlags
import CgUtils
import ClosureInfo
import SMRep
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import CLabel
import StgSyn
import CostCentre
import CgInfoTbls
import CLabel
import ClosureInfo
-import CmmUtils
-import Cmm
+import OldCmmUtils
+import OldCmm
import SMRep
import CostCentre
import Constants
import CgHpc
import CgUtils
import ClosureInfo
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import VarSet
import Literal
import PrimOp
import CgMonad
import CLabel
-import Cmm
+import OldCmm
-- import BasicTypes
import BlockId
newLabel :: FastString -> ExtFCode BlockId
newLabel name = do
u <- code newUnique
- addLabel name (BlockId u)
- return (BlockId u)
+ addLabel name (mkBlockId u)
+ return (mkBlockId u)
-- | Add add a local function to the environment.
return $
case lookupUFM env name of
Just (Label l) -> l
- _other -> BlockId (newTagUnique (getUnique name) 'L')
+ _other -> mkBlockId (newTagUnique (getUnique name) 'L')
-- | Lookup the location of a named variable.
import Type
import TysPrim
import CLabel
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import SMRep
import ForeignCall
import ClosureInfo
import ClosureInfo
import SMRep
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import Id
import DataCon
import TyCon
module CgHpc (cgTickBox, initHpc, hpcTable) where
-import Cmm
+import OldCmm
import CLabel
import Module
-import CmmUtils
+import OldCmmUtils
import CgUtils
import CgMonad
import CgForeignCall
import CgUtils
import CgMonad
-import CmmUtils
-import Cmm
+import OldCmmUtils
+import OldCmm
import CLabel
import Name
import DataCon
import CgHeapery
import CgInfoTbls
import CgStackery
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import CLabel
import ClosureInfo
import CostCentre
import DynFlags
import BlockId
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import CLabel
import StgSyn (SRT)
import SMRep
newLabelC :: FCode BlockId
newLabelC = do { u <- newUnique
- ; return $ BlockId u }
+ ; return $ mkBlockId u }
checkedAbsC :: CmmStmt -> Code
-- Emit code, eliminating no-ops
data_block = CmmData sect lits
emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
-emitProc info lbl args blocks
- = do { let proc_block = CmmProc info lbl args (ListGraph blocks)
+emitProc info lbl [] blocks
+ = do { let proc_block = CmmProc info lbl (ListGraph blocks)
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
+emitProc _ _ (_:_) _ = panic "emitProc called with nonempty args"
emitSimpleProc :: CLabel -> Code -> Code
-- Emit a procedure whose body is the specified code; no info table
import CgMonad
import CgCallConv
import Id
-import Cmm
+import OldCmm
import StaticFlags
import Outputable
import SMRep
import CgMonad
import CgInfoTbls
import CgUtils
-import Cmm
+import OldCmm
import CLabel
-import CmmUtils
+import OldCmmUtils
import PrimOp
import SMRep
import Module
import CgMonad
import SMRep
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import CLabel
import Id
import CgUtils
import CgProf
import SMRep
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import CLabel
import Constants
import Util
import CgTicky
import ClosureInfo
import SMRep
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import CLabel
import Type
import Id
import CgMonad
import SMRep
-import Cmm
-import CmmUtils
+import OldCmm
+import OldCmmUtils
import CLabel
import Name
import IdInfo
import Constants
import SMRep
-import PprCmm ( {- instances -} )
-import Cmm
+import OldCmm
+import OldCmmUtils
import CLabel
-import CmmUtils
import ForeignCall
import ClosureInfo
import StgSyn (SRT(..))
fixStgRegisters :: RawCmmTop -> RawCmmTop
fixStgRegisters top@(CmmData _ _) = top
-fixStgRegisters (CmmProc info lbl params (ListGraph blocks)) =
+fixStgRegisters (CmmProc info lbl (ListGraph blocks)) =
let blocks' = map fixStgRegBlock blocks
- in CmmProc info lbl params $ ListGraph blocks'
+ in CmmProc info lbl $ ListGraph blocks'
fixStgRegBlock :: CmmBasicBlock -> CmmBasicBlock
fixStgRegBlock (BasicBlock id stmts) =
import CgHpc
import CLabel
-import Cmm
-import CmmUtils
-import PprCmm
+import OldCmm
+import OldCmmUtils
+import OldPprCmm
import StgSyn
import PrelNames
#include "../includes/MachDeps.h"
-import CmmExpr -- CmmType and friends
+import CmmType
import Id
import Type
import TyCon
import StgCmmHpc
import StgCmmTicky
-import MkZipCfgCmm
-import Cmm
+import MkGraph
+import CmmDecl
+import CmmExpr
import CmmUtils
import CLabel
import PprCmm
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[(Id,[Id])])] -- Bindings to convert, with SRTs
-> HpcInfo
- -> IO [CmmZ] -- Output
+ -> IO [Cmm] -- Output
codeGen dflags this_mod data_tycons imported_mods
cost_centre_info stg_binds hpc_info
closures predeclared.
-}
-cgTyCon :: TyCon -> FCode [CmmZ] -- All constructors merged together
+cgTyCon :: TyCon -> FCode [Cmm] -- All constructors merged together
cgTyCon tycon
= do { constrs <- mapM (getCmm . cgDataCon) (tyConDataCons tycon)
; return (extra ++ constrs)
}
-cgEnumerationTyCon :: TyCon -> FCode [CmmZ]
+cgEnumerationTyCon :: TyCon -> FCode [Cmm]
cgEnumerationTyCon tycon
| isEnumerationTyCon tycon
= do { tbl <- getCmm $
--
-----------------------------------------------------------------------------
-module StgCmmBind (
- cgTopRhsClosure,
+module StgCmmBind (
+ cgTopRhsClosure,
cgBind,
emitBlackHoleCode,
pushUpdateFrame
import StgCmmLayout
import StgCmmUtils
import StgCmmClosure
+import StgCmmForeign (emitPrimCall)
-import MkZipCfgCmm
+import MkGraph
import CoreSyn ( AltCon(..) )
import SMRep
-import Cmm
+import CmmDecl
+import CmmExpr
import CmmUtils
import CLabel
import StgSyn
-import CostCentre
+import CostCentre
import Id
import Control.Monad
import Name
-- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY)
; emitDataLits closure_label closure_rep
; let fv_details :: [(NonVoid Id, VirtualHpOffset)]
- (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
+ (_, _, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info)
(addIdReps [])
-- Don't drop the non-void args until the closure info has been made
; forkClosureBody (closureCodeBody True id closure_info ccs
; emit (init <*> body) }
cgBind (StgRec pairs)
- = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
+ = do { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
do { addBindsC $ fst new_binds_inits -- avoid premature deconstruction
; liftM unzip $ listFCs [ cgRhs b e | (b,e) <- pairs ] })
; addBindsC new_binds
m[hp-40] = y_info;
// allocate and initialize z
...
-
+
For each closure, we must generate not only the code to allocate and
initialize the closure itself, but also some Initialization Code that
sets a variable holding the closure pointer.
body@(StgApp fun_id args)
| args `lengthIs` (arity-1)
- && all isFollowableArg (map (idCgRep . stripNV) fvs)
+ && all isFollowableArg (map (idCgRep . stripNV) fvs)
&& isUpdatable upd_flag
- && arity <= mAX_SPEC_AP_SIZE
+ && arity <= mAX_SPEC_AP_SIZE
-- Ha! an Ap thunk
= cgStdThunk bndr cc bi body lf_info payload
reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr]
| otherwise = fvs
-
+
-- MAKE CLOSURE INFO FOR THIS CLOSURE
; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
; mod_name <- getModuleName
; let name = idName bndr
descr = closureDescription mod_name name
fv_details :: [(NonVoid Id, VirtualHpOffset)]
- (tot_wds, ptr_wds, fv_details)
- = mkVirtHeapOffsets (isLFThunk lf_info)
+ (tot_wds, ptr_wds, fv_details)
+ = mkVirtHeapOffsets (isLFThunk lf_info)
(addIdReps (map stripNV reduced_fvs))
closure_info = mkClosureInfo False -- Not static
bndr lf_info tot_wds ptr_wds
; (use_cc, blame_cc) <- chooseDynCostCentres cc args body
; emit (mkComment $ mkFastString "calling allocDynClosure")
; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
- ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
+ ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc
(map toVarArg fv_details)
-
+
-- RETURN
; return $ (regIdInfo bndr lf_info tmp, init) }
= do -- AHA! A STANDARD-FORM THUNK
{ -- LAY OUT THE OBJECT
mod_name <- getModuleName
- ; let (tot_wds, ptr_wds, payload_w_offsets)
+ ; let (tot_wds, ptr_wds, payload_w_offsets)
= mkVirtHeapOffsets (isLFThunk lf_info) (addArgReps payload)
descr = closureDescription mod_name (idName bndr)
closure_info = mkClosureInfo False -- Not static
- bndr lf_info tot_wds ptr_wds
+ bndr lf_info tot_wds ptr_wds
NoC_SRT -- No SRT for a std-form closure
descr
-> [NonVoid Id] -- incoming args to the closure
-> Int -- arity, including void args
-> StgExpr
- -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables
+ -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free vars
-> FCode ()
-{- There are two main cases for the code for closures.
+{- There are two main cases for the code for closures.
* If there are *no arguments*, then the closure is a thunk, and not in
normal form. So it should set up an update frame (if it is
normal form, so there is no need to set up an update frame.
The Macros for GrAnSim are produced at the beginning of the
- argSatisfactionCheck (by calling fetchAndReschedule).
+ argSatisfactionCheck (by calling fetchAndReschedule).
There info if Node points to closure is available. -- HWL -}
closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
| length args == 0 -- No args i.e. thunk
= emitClosureProcAndInfoTable top_lvl bndr cl_info [] $
- (\ (node, _) -> thunkCode cl_info fv_details cc node arity body)
+ \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
= ASSERT( length args > 0 )
- do { -- Allocate the global ticky counter,
- -- and establish the ticky-counter
- -- label for this block
- let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $ clHasCafRefs cl_info
- ; emitTickyCounter cl_info (map stripNV args)
- ; setTickyCtrLabel ticky_ctr_lbl $ do
-
- -- Emit the main entry code
- ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
- -- Emit the slow-entry code (for entering a closure through a PAP)
+ do { -- Allocate the global ticky counter,
+ -- and establish the ticky-counter
+ -- label for this block
+ let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) $
+ clHasCafRefs cl_info
+ ; emitTickyCounter cl_info (map stripNV args)
+ ; setTickyCtrLabel ticky_ctr_lbl $ do
+
+ -- Emit the main entry code
+ ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $
+ \(offset, node, arg_regs) -> do
+ -- Emit slow-entry code (for entering a closure through a PAP)
{ mkSlowEntryCode cl_info arg_regs
; let lf_info = closureLFInfo cl_info
node_points = nodeMustPointToIt lf_info
+ node' = if node_points then Just node else Nothing
; tickyEnterFun cl_info
; whenC node_points (ldvEnterClosure cl_info)
; granYield arg_regs node_points
- -- Main payload
- ; entryHeapCheck (if node_points then Just node else Nothing) arity arg_regs $ do
+ -- Main payload
+ ; entryHeapCheck cl_info offset node' arity arg_regs $ do
{ enterCostCentre cl_info cc body
; fv_bindings <- mapM bind_fv fv_details
-- Load free vars out of closure *after*
- ; if node_points then load_fvs node lf_info fv_bindings else return ()
- ; cgExpr body }} -- heap check, to reduce live vars over check
-
+ -- heap check, to reduce live vars over check
+ ; if node_points then load_fvs node lf_info fv_bindings
+ else return ()
+ ; cgExpr body }}
}
-- A function closure pointer may be tagged, so we
-- according to the calling convention, and jumps to the function's
-- normal entry point. The function's closure is assumed to be in
-- R1/node.
---
--- The slow entry point is used for unknown calls: eg. stg_PAP_entry
+--
+-- The slow entry point is used for unknown calls: eg. stg_PAP_entry
mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
-- If this function doesn't have a specialised ArgDescr, we need
-- to generate the function's arg bitmap and slow-entry code.
-- Here, we emit the slow-entry code.
-mkSlowEntryCode cl_info (_ : arg_regs) -- first arg should already be in `Node'
+mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
+mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
| Just (_, ArgGen _) <- closureFunInfo cl_info
- = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl
- arg_regs jump
+ = emitProcWithConvention Slow CmmNonInfoTable slow_lbl arg_regs jump
| otherwise = return ()
where
caf_refs = clHasCafRefs cl_info
name = closureName cl_info
slow_lbl = mkSlowEntryLabel name caf_refs
fast_lbl = enterLocalIdLabel name caf_refs
- jump = mkJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
- initUpdFrameOff
-mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
+ -- mkDirectJump does not clobber `Node' containing function closure
+ jump = mkDirectJump (mkLblExpr fast_lbl) (map (CmmReg . CmmLocal) arg_regs)
+ initUpdFrameOff
-----------------------------------------
-thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack ->
- LocalReg -> Int -> StgExpr -> FCode ()
-thunkCode cl_info fv_details cc node arity body
- = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
- ; tickyEnterThunk cl_info
- ; ldvEnterClosure cl_info -- NB: Node always points when profiling
- ; granThunk node_points
+thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack
+ -> LocalReg -> Int -> StgExpr -> FCode ()
+thunkCode cl_info fv_details cc node arity body
+ = do { let node_points = nodeMustPointToIt (closureLFInfo cl_info)
+ node' = if node_points then Just node else Nothing
+ ; tickyEnterThunk cl_info
+ ; ldvEnterClosure cl_info -- NB: Node always points when profiling
+ ; granThunk node_points
-- Heap overflow check
- ; entryHeapCheck (if node_points then Just node else Nothing) arity [] $ do
- { -- Overwrite with black hole if necessary
- -- but *after* the heap-overflow check
- dflags <- getDynFlags
- ; whenC (blackHoleOnEntry dflags cl_info && node_points)
- (blackHoleIt cl_info)
-
- -- Push update frame
- ; setupUpdate cl_info node $
- -- We only enter cc after setting up update so
- -- that cc of enclosing scope will be recorded
- -- in update frame CAF/DICT functions will be
- -- subsumed by this enclosing cc
+ ; entryHeapCheck cl_info 0 node' arity [] $ do
+ { -- Overwrite with black hole if necessary
+ -- but *after* the heap-overflow check
+ dflags <- getDynFlags
+ ; whenC (blackHoleOnEntry dflags cl_info && node_points)
+ (blackHoleIt cl_info)
+
+ -- Push update frame
+ ; setupUpdate cl_info node $
+ -- We only enter cc after setting up update so
+ -- that cc of enclosing scope will be recorded
+ -- in update frame CAF/DICT functions will be
+ -- subsumed by this enclosing cc
do { enterCostCentre cl_info cc body
; let lf_info = closureLFInfo cl_info
; fv_bindings <- mapM bind_fv fv_details
; load_fvs node lf_info fv_bindings
- ; cgExpr body }}}
+ ; cgExpr body }}}
------------------------------------------------------------------------
blackHoleIt closure_info = emitBlackHoleCode (closureSingleEntry closure_info)
emitBlackHoleCode :: Bool -> FCode ()
-emitBlackHoleCode is_single_entry
- | eager_blackholing = do
+emitBlackHoleCode is_single_entry
+ | eager_blackholing = do
tickyBlackHole (not is_single_entry)
+ emit (mkStore (cmmOffsetW (CmmReg nodeReg) fixedHdrSize) (CmmReg (CmmGlobal CurrentTSO)))
+ emitPrimCall [] MO_WriteBarrier []
emit (mkStore (CmmReg nodeReg) (CmmLit (CmmLabel bh_lbl)))
- | otherwise =
+ | otherwise =
nopC
where
bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info")
-- currently eager blackholing doesn't work with profiling.
--
-- Previously, eager blackholing was enabled when ticky-ticky
- -- was on. But it didn't work, and it wasn't strictly necessary
- -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
+ -- was on. But it didn't work, and it wasn't strictly necessary
+ -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
-- is unconditionally disabled. -- krc 1/2007
- eager_blackholing = False
+ eager_blackholing = False
setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
-- Nota Bene: this function does not change Node (even if it's a CAF),
= body
| not (isStaticClosure closure_info)
- = if closureUpdReqd closure_info
- then do { tickyPushUpdateFrame;
- ; pushUpdateFrame [CmmReg (CmmLocal node),
- mkLblExpr mkUpdInfoLabel] body }
- else do { tickyUpdateFrameOmitted; body}
-
+ = if not (closureUpdReqd closure_info)
+ then do tickyUpdateFrameOmitted; body
+ else do
+ tickyPushUpdateFrame
+ --dflags <- getDynFlags
+ let es = [CmmReg (CmmLocal node), mkLblExpr mkUpdInfoLabel]
+ --if not opt_SccProfilingOn && dopt Opt_EagerBlackHoling dflags
+ -- then pushUpdateFrame es body -- XXX black hole
+ -- else pushUpdateFrame es body
+ pushUpdateFrame es body
+
| otherwise -- A static closure
= do { tickyUpdateBhCaf closure_info
then do -- Blackhole the (updatable) CAF:
{ upd_closure <- link_caf closure_info True
; pushUpdateFrame [CmmReg (CmmLocal upd_closure),
- mkLblExpr mkUpdInfoLabel] body }
+ mkLblExpr mkUpdInfoLabel] body } -- XXX black hole
else do {tickyUpdateFrameOmitted; body}
}
+-----------------------------------------------------------------------------
+-- Setting up update frames
+
-- Push the update frame on the stack in the Entry area,
-- leaving room for the return address that is already
-- at the old end of the area.
pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
pushUpdateFrame es body
- = do updfr <- getUpdFrameOff
+ = do -- [EZY] I'm not sure if we need to special-case for BH too
+ updfr <- getUpdFrameOff
offset <- foldM push updfr es
withUpdFrameOff offset body
where push off e =
-- allocated black hole to be empty.
--
-- Why do we make a black hole in the heap when we enter a CAF?
---
+--
-- - for a generational garbage collector, which needs a fast
-- test for whether an updatee is in an old generation or not
--
-- ToDo [Feb 04] This entire link_caf nonsense could all be moved
-- into the "newCAF" RTS procedure, which we call anyway, including
-- the allocation of the black-hole indirection closure.
--- That way, code size would fall, the CAF-handling code would
+-- That way, code size would fall, the CAF-handling code would
-- be closer together, and the compiler wouldn't need to know
-- about off_indirectee etc.
{ -- Alloc black hole specifying CC_HDR(Node) as the cost centre
; let use_cc = costCentreFrom (CmmReg nodeReg)
blame_cc = use_cc
- ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc []
+ tso = CmmReg (CmmGlobal CurrentTSO)
+ -- XXX ezyang: FIXME
+ ; (hp_rel, init) <- allocDynClosureCmm bh_cl_info use_cc blame_cc [(tso,fixedHdrSize)]
; emit init
-- Call the RTS function newCAF to add the CAF to the CafList
-- so that the garbage collector can find them
- -- This must be done *before* the info table pointer is overwritten,
+ -- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
[ (CmmReg (CmmGlobal BaseReg), AddrHint),
[node] False
-- node is live, so save it.
- -- Overwrite the closure with a (static) indirection
+ -- Overwrite the closure with a (static) indirection
-- to the newly-allocated black hole
; emit (mkStore (cmmRegOffW nodeReg off_indirectee) (CmmReg (CmmLocal hp_rel)) <*>
mkStore (CmmReg nodeReg) ind_static_info)
------------------------------------------------------------------------
--- Profiling
+-- Profiling
------------------------------------------------------------------------
-- For "global" data constructors the description is simply occurrence
else pprModule mod_name <> char '.' <> ppr name) <>
char '>')
-- showSDocDump, because we want to see the unique on the Name.
-
+
--
-----------------------------------------------------------------------------
-
module StgCmmClosure (
SMRep,
DynTag, tagForCon, isSmallFamily,
import StgSyn
import SMRep
-import Cmm ( ClosureTypeInfo(..), ConstrDescription )
+import CmmDecl ( ClosureTypeInfo(..), ConstrDescription )
import CmmExpr
import CLabel
import StgCmmClosure
import StgCmmProf
-import Cmm
+import CmmExpr
import CLabel
-import MkZipCfgCmm (CmmAGraph, mkNop)
+import MkGraph
import SMRep
import CostCentre
import Module
import CLabel
import BlockId
-import Cmm
+import CmmExpr
import CmmUtils
import FastString
-import PprCmm ( {- instance Outputable -} )
import Id
import VarEnv
import Control.Monad
import StgSyn
-import MkZipCfgCmm
+import MkGraph
import BlockId
import CmmExpr
import CoreSyn
; return con }
maybeAltHeapCheck :: GcPlan -> FCode a -> FCode a
-maybeAltHeapCheck NoGcInAlts code
- = code
-maybeAltHeapCheck (GcInAlts regs _) code
- = altHeapCheck regs code
+maybeAltHeapCheck NoGcInAlts code = code
+maybeAltHeapCheck (GcInAlts regs _) code = altHeapCheck regs code
-----------------------------------------------------------------------------
-- Tail calls
L2:
<default-case code>
-}
+
import StgCmmClosure
import BlockId
-import Cmm
+import CmmDecl
+import CmmExpr
import CmmUtils
-import MkZipCfgCmm hiding (CmmAGraph)
+import OldCmm ( CmmReturnInfo(..) )
+import MkGraph
import Type
import TysPrim
import CLabel
import StaticFlags
import Maybes
import Outputable
-import ZipCfgCmmRep
import BasicTypes
import Control.Monad
emitForeignCall
:: Safety
-> CmmFormals -- where to put the results
- -> MidCallTarget -- the op
+ -> ForeignTarget -- the op
-> CmmActuals -- arguments
-> C_SRT -- the SRT of the calls continuation
-> CmmReturnInfo -- This can say "never returns"
return (tmp,hint)
-}
-load_target_into_temp :: MidCallTarget -> FCode MidCallTarget
+load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
load_target_into_temp (ForeignTarget expr conv) = do
tmp <- maybe_assign_temp expr
return (ForeignTarget tmp conv)
saveThreadState :: CmmAGraph
saveThreadState =
- -- CurrentTSO->sp = Sp;
- mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
+ -- CurrentTSO->stackobj->sp = Sp;
+ mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP) stgSp
<*> closeNursery
-- and save the current cost centre stack in the TSO when profiling:
<*> if opt_SccProfilingOn then
emitSaveThreadState :: BlockId -> FCode ()
emitSaveThreadState bid = do
- -- CurrentTSO->sp = Sp;
- emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
+ -- CurrentTSO->stackobj->sp = Sp;
+ emit $ mkStore (cmmOffset (CmmLoad (cmmOffset stgCurrentTSO tso_stackobj) bWord) stack_SP)
(CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
emit closeNursery
-- and save the current cost centre stack in the TSO when profiling:
closeNursery :: CmmAGraph
closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
-loadThreadState :: LocalReg -> CmmAGraph
-loadThreadState tso = do
+loadThreadState :: LocalReg -> LocalReg -> CmmAGraph
+loadThreadState tso stack = do
-- tso <- newTemp gcWord -- TODO FIXME NOW
+ -- stack <- newTemp gcWord -- TODO FIXME NOW
catAGraphs [
-- tso = CurrentTSO;
mkAssign (CmmLocal tso) stgCurrentTSO,
- -- Sp = tso->sp;
- mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
- bWord),
- -- SpLim = tso->stack + RESERVED_STACK_WORDS;
- mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
+ -- stack = tso->stackobj;
+ mkAssign (CmmLocal stack) (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_stackobj) bWord),
+ -- Sp = stack->sp;
+ mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal stack)) stack_SP) bWord),
+ -- SpLim = stack->stack + RESERVED_STACK_WORDS;
+ mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal stack)) stack_STACK)
rESERVED_STACK_WORDS),
openNursery,
-- and load the current cost centre stack from the TSO when profiling:
mkStore curCCSAddr
(CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
else mkNop]
-emitLoadThreadState :: LocalReg -> FCode ()
-emitLoadThreadState tso = emit $ loadThreadState tso
+emitLoadThreadState :: LocalReg -> LocalReg -> FCode ()
+emitLoadThreadState tso stack = emit $ loadThreadState tso stack
openNursery :: CmmAGraph
openNursery = catAGraphs [
nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
-tso_SP, tso_STACK, tso_CCCS :: ByteOff
-tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
+tso_stackobj, tso_CCCS, stack_STACK, stack_SP :: ByteOff
+tso_stackobj = closureField oFFSET_StgTSO_stackobj
+tso_CCCS = closureField oFFSET_StgTSO_CCCS
+stack_STACK = closureField oFFSET_StgStack_stack
+stack_SP = closureField oFFSET_StgStack_sp
- --ToDo: needs merging with changes to CgForeign
-tso_STACK = tsoFieldB undefined
-tso_SP = tsoFieldB undefined
--- The TSO struct has a variable header, and an optional StgTSOProfInfo in
--- the middle. The fields we're interested in are after the StgTSOProfInfo.
-tsoFieldB :: ByteOff -> ByteOff
-tsoFieldB off
- | opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
- | otherwise = off + fixedHdrSize * wORD_SIZE
-
-tsoProfFieldB :: ByteOff -> ByteOff
-tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
+closureField :: ByteOff -> ByteOff
+closureField off = off + fixedHdrSize * wORD_SIZE
stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
stgSp = CmmReg sp
-- I've left the calls, though, in case anyone wants to resurrect it
import StgCmmMonad
-import Cmm
+import CmmExpr
staticGranHdr :: [CmmLit]
staticGranHdr = []
-----------------------------------------------------------------------------
module StgCmmHeap (
- getVirtHp, setVirtHp, setRealHp,
- getHpRelOffset, hpRel,
+ getVirtHp, setVirtHp, setRealHp,
+ getHpRelOffset, hpRel,
- entryHeapCheck, altHeapCheck,
+ entryHeapCheck, altHeapCheck,
- layOutDynConstr, layOutStaticConstr,
- mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
+ layOutDynConstr, layOutStaticConstr,
+ mkVirtHeapOffsets, mkStaticClosureFields, mkStaticClosure,
- allocDynClosure, emitSetDynHdr
+ allocDynClosure, allocDynClosureCmm, emitSetDynHdr
) where
#include "HsVersions.h"
+import CmmType
import StgSyn
import CLabel
import StgCmmLayout
import StgCmmClosure
import StgCmmEnv
-import MkZipCfgCmm
+import MkGraph
import SMRep
import CmmExpr
import CostCentre
import Outputable
import Module
-import FastString( mkFastString, FastString, fsLit )
+import FastString( mkFastString, fsLit )
import Constants
-
-----------------------------------------------------------
--- Layout of heap objects
+-- Layout of heap objects
-----------------------------------------------------------
layOutDynConstr, layOutStaticConstr
- :: DataCon -> [(PrimRep, a)]
- -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
--- No Void arguments in result
+ :: DataCon -> [(PrimRep, a)]
+ -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
+ -- No Void arguments in result
layOutDynConstr = layOutConstr False
layOutStaticConstr = layOutConstr True
layOutConstr :: Bool -> DataCon -> [(PrimRep, a)]
- -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
+ -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)])
layOutConstr is_static data_con args
= (mkConInfo is_static data_con tot_wds ptr_wds,
things_w_offsets)
where
- (tot_wds, -- #ptr_wds + #nonptr_wds
- ptr_wds, -- #ptr_wds
+ (tot_wds, -- #ptr_wds + #nonptr_wds
+ ptr_wds, -- #ptr_wds
things_w_offsets) = mkVirtHeapOffsets False{-not a thunk-} args
-----------------------------------------------------------
--- Initialise dynamic heap objects
+-- Initialise dynamic heap objects
-----------------------------------------------------------
allocDynClosure
- :: ClosureInfo
- -> CmmExpr -- Cost Centre to stick in the object
- -> CmmExpr -- Cost Centre to blame for this alloc
- -- (usually the same; sometimes "OVERHEAD")
-
- -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of the object
- -- ie Info ptr has offset zero.
- -- No void args in here
- -> FCode (LocalReg, CmmAGraph)
-
--- allocDynClosure allocates the thing in the heap,
+ :: ClosureInfo
+ -> CmmExpr -- Cost Centre to stick in the object
+ -> CmmExpr -- Cost Centre to blame for this alloc
+ -- (usually the same; sometimes "OVERHEAD")
+
+ -> [(NonVoid StgArg, VirtualHpOffset)] -- Offsets from start of object
+ -- ie Info ptr has offset zero.
+ -- No void args in here
+ -> FCode (LocalReg, CmmAGraph)
+
+allocDynClosureCmm
+ :: ClosureInfo -> CmmExpr -> CmmExpr
+ -> [(CmmExpr, VirtualHpOffset)]
+ -> FCode (LocalReg, CmmAGraph)
+
+-- allocDynClosure allocates the thing in the heap,
-- and modifies the virtual Hp to account for this.
-- The second return value is the graph that sets the value of the
-- returned LocalReg, which should point to the closure after executing
-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-- allocDynClosure returns a LocalReg, not a (Hp+8) CmmExpr.
-- Reason:
--- ...allocate object...
--- obj = Hp + 8
--- y = f(z)
--- ...here obj is still valid,
--- but Hp+8 means something quite different...
+-- ...allocate object...
+-- obj = Hp + 8
+-- y = f(z)
+-- ...here obj is still valid,
+-- but Hp+8 means something quite different...
allocDynClosure cl_info use_cc _blame_cc args_w_offsets
- = do { virt_hp <- getVirtHp
-
- -- SAY WHAT WE ARE ABOUT TO DO
- ; tickyDynAlloc cl_info
- ; profDynAlloc cl_info use_cc
- -- ToDo: This is almost certainly wrong
- -- We're ignoring blame_cc. But until we've
- -- fixed the boxing hack in chooseDynCostCentres etc,
- -- we're worried about making things worse by "fixing"
- -- this part to use blame_cc!
-
- -- FIND THE OFFSET OF THE INFO-PTR WORD
- ; let info_offset = virt_hp + 1
- -- info_offset is the VirtualHpOffset of the first
- -- word of the new object
- -- Remember, virtHp points to last allocated word,
- -- ie 1 *before* the info-ptr word of new object.
-
- info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
-
- -- ALLOCATE THE OBJECT
- ; base <- getHpRelOffset info_offset
+ = do { let (args, offsets) = unzip args_w_offsets
+ ; cmm_args <- mapM getArgAmode args -- No void args
+ ; allocDynClosureCmm cl_info use_cc _blame_cc (zip cmm_args offsets)
+ }
+
+allocDynClosureCmm cl_info use_cc _blame_cc amodes_w_offsets
+ = do { virt_hp <- getVirtHp
+
+ -- SAY WHAT WE ARE ABOUT TO DO
+ ; tickyDynAlloc cl_info
+ ; profDynAlloc cl_info use_cc
+ -- ToDo: This is almost certainly wrong
+ -- We're ignoring blame_cc. But until we've
+ -- fixed the boxing hack in chooseDynCostCentres etc,
+ -- we're worried about making things worse by "fixing"
+ -- this part to use blame_cc!
+
+ -- FIND THE OFFSET OF THE INFO-PTR WORD
+ ; let info_offset = virt_hp + 1
+ -- info_offset is the VirtualHpOffset of the first
+ -- word of the new object
+ -- Remember, virtHp points to last allocated word,
+ -- ie 1 *before* the info-ptr word of new object.
+
+ info_ptr = CmmLit (CmmLabel (infoTableLabelFromCI cl_info))
+
+ -- ALLOCATE THE OBJECT
+ ; base <- getHpRelOffset info_offset
; emit (mkComment $ mkFastString "allocDynClosure")
- ; emitSetDynHdr base info_ptr use_cc
- ; let (args, offsets) = unzip args_w_offsets
- ; cmm_args <- mapM getArgAmode args -- No void args
- ; hpStore base cmm_args offsets
-
- -- BUMP THE VIRTUAL HEAP POINTER
- ; setVirtHp (virt_hp + closureSize cl_info)
-
- -- Assign to a temporary and return
- -- Note [Return a LocalReg]
- ; hp_rel <- getHpRelOffset info_offset
- ; getCodeR $ assignTemp hp_rel }
+ ; emitSetDynHdr base info_ptr use_cc
+ ; let (cmm_args, offsets) = unzip amodes_w_offsets
+ ; hpStore base cmm_args offsets
+
+ -- BUMP THE VIRTUAL HEAP POINTER
+ ; setVirtHp (virt_hp + closureSize cl_info)
+
+ -- Assign to a temporary and return
+ -- Note [Return a LocalReg]
+ ; hp_rel <- getHpRelOffset info_offset
+ ; getCodeR $ assignTemp hp_rel }
emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
-emitSetDynHdr base info_ptr ccs
+emitSetDynHdr base info_ptr ccs
= hpStore base header [0..]
where
header :: [CmmExpr]
header = [info_ptr] ++ dynProfHdr ccs
- -- ToDo: Gransim stuff
- -- ToDo: Parallel stuff
- -- No ticky header
+ -- ToDo: Gransim stuff
+ -- ToDo: Parallel stuff
+ -- No ticky header
hpStore :: CmmExpr -> [CmmExpr] -> [VirtualHpOffset] -> FCode ()
-- Store the item (expr,off) in base[off]
hpStore base vals offs
= emit (catAGraphs (zipWith mk_store vals offs))
where
- mk_store val off = mkStore (cmmOffsetW base off) val
+ mk_store val off = mkStore (cmmOffsetW base off) val
-----------------------------------------------------------
--- Layout of static closures
+-- Layout of static closures
-----------------------------------------------------------
-- Make a static closure, adding on any extra padding needed for CAFs,
-- and adding a static link field if necessary.
-mkStaticClosureFields
- :: ClosureInfo
- -> CostCentreStack
- -> Bool -- Has CAF refs
- -> [CmmLit] -- Payload
- -> [CmmLit] -- The full closure
+mkStaticClosureFields
+ :: ClosureInfo
+ -> CostCentreStack
+ -> Bool -- Has CAF refs
+ -> [CmmLit] -- Payload
+ -> [CmmLit] -- The full closure
mkStaticClosureFields cl_info ccs caf_refs payload
- = mkStaticClosure info_lbl ccs payload padding_wds
- static_link_field saved_info_field
+ = mkStaticClosure info_lbl ccs payload padding
+ static_link_field saved_info_field
where
info_lbl = infoTableLabelFromCI cl_info
is_caf = closureNeedsUpdSpace cl_info
- padding_wds
- | not is_caf = []
- | otherwise = ASSERT(null payload) [mkIntCLit 0]
+ padding
+ | not is_caf = []
+ | otherwise = ASSERT(null payload) [mkIntCLit 0]
static_link_field
- | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
- | otherwise = []
+ | is_caf || staticClosureNeedsLink cl_info = [static_link_value]
+ | otherwise = []
saved_info_field
- | is_caf = [mkIntCLit 0]
- | otherwise = []
+ | is_caf = [mkIntCLit 0]
+ | otherwise = []
- -- for a static constructor which has NoCafRefs, we set the
- -- static link field to a non-zero value so the garbage
- -- collector will ignore it.
+ -- for a static constructor which has NoCafRefs, we set the
+ -- static link field to a non-zero value so the garbage
+ -- collector will ignore it.
static_link_value
- | caf_refs = mkIntCLit 0
- | otherwise = mkIntCLit 1
+ | caf_refs = mkIntCLit 0
+ | otherwise = mkIntCLit 1
mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit]
-> [CmmLit] -> [CmmLit] -> [CmmLit] -> [CmmLit]
-mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field
+mkStaticClosure info_lbl ccs payload padding static_link_field saved_info_field
= [CmmLabel info_lbl]
++ variable_header_words
++ concatMap padLitToWord payload
- ++ padding_wds
+ ++ padding
++ static_link_field
++ saved_info_field
where
variable_header_words
- = staticGranHdr
- ++ staticParHdr
- ++ staticProfHdr ccs
- ++ staticTickyHdr
+ = staticGranHdr
+ ++ staticParHdr
+ ++ staticProfHdr ccs
+ ++ staticTickyHdr
--- JD: Simon had ellided this padding, but without it the C back end asserts failure.
--- Maybe it's a bad assertion, and this padding is indeed unnecessary?
+-- JD: Simon had ellided this padding, but without it the C back end asserts
+-- failure. Maybe it's a bad assertion, and this padding is indeed unnecessary?
padLitToWord :: CmmLit -> [CmmLit]
padLitToWord lit = lit : padding pad_length
where width = typeWidth (cmmLitType lit)
| otherwise = CmmInt 0 W64 : padding (n-8)
-----------------------------------------------------------
--- Heap overflow checking
+-- Heap overflow checking
-----------------------------------------------------------
{- Note [Heap checks]
nothing to its caller
* A series of canned entry points like
- r = gc_1p( r )
+ r = gc_1p( r )
where r is a pointer. This performs gc, and
then returns its argument r to its caller.
-
+
* A series of canned entry points like
- gcfun_2p( f, x, y )
+ gcfun_2p( f, x, y )
where f is a function closure of arity 2
This performs garbage collection, keeping alive the
three argument ptrs, and then tail-calls f(x,y)
* entryHeapCheck: Function entry
(a) With a canned GC entry sequence
f( f_clo, x:ptr, y:ptr ) {
- Hp = Hp+8
- if Hp > HpLim goto L
- ...
+ Hp = Hp+8
+ if Hp > HpLim goto L
+ ...
L: HpAlloc = 8
jump gcfun_2p( f_clo, x, y ) }
Note the tail call to the garbage collector;
- it should do no register shuffling
+ it should do no register shuffling
(b) No canned sequence
f( f_clo, x:ptr, y:ptr, ...etc... ) {
- T: Hp = Hp+8
- if Hp > HpLim goto L
- ...
+ T: Hp = Hp+8
+ if Hp > HpLim goto L
+ ...
L: HpAlloc = 8
- call gc() -- Needs an info table
- goto T }
+ call gc() -- Needs an info table
+ goto T }
* altHeapCheck: Immediately following an eval
- Started as
- case f x y of r { (p,q) -> rhs }
+ Started as
+ case f x y of r { (p,q) -> rhs }
(a) With a canned sequence for the results of f
(which is the very common case since
all boxed cases return just one pointer
- ...
- r = f( x, y )
- K: -- K needs an info table
- Hp = Hp+8
- if Hp > HpLim goto L
- ...code for rhs...
+ ...
+ r = f( x, y )
+ K: -- K needs an info table
+ Hp = Hp+8
+ if Hp > HpLim goto L
+ ...code for rhs...
- L: r = gc_1p( r )
- goto K }
+ L: r = gc_1p( r )
+ goto K }
- Here, the info table needed by the call
- to gc_1p should be the *same* as the
- one for the call to f; the C-- optimiser
- spots this sharing opportunity)
+ Here, the info table needed by the call
+ to gc_1p should be the *same* as the
+ one for the call to f; the C-- optimiser
+ spots this sharing opportunity)
(b) No canned sequence for results of f
Note second info table
- ...
- (r1,r2,r3) = call f( x, y )
- K:
- Hp = Hp+8
- if Hp > HpLim goto L
- ...code for rhs...
+ ...
+ (r1,r2,r3) = call f( x, y )
+ K:
+ Hp = Hp+8
+ if Hp > HpLim goto L
+ ...code for rhs...
- L: call gc() -- Extra info table here
- goto K
+ L: call gc() -- Extra info table here
+ goto K
* generalHeapCheck: Anywhere else
e.g. entry to thunk
- case branch *not* following eval,
+ case branch *not* following eval,
or let-no-escape
Exactly the same as the previous case:
- K: -- K needs an info table
- Hp = Hp+8
- if Hp > HpLim goto L
- ...
+ K: -- K needs an info table
+ Hp = Hp+8
+ if Hp > HpLim goto L
+ ...
- L: call gc()
- goto K
+ L: call gc()
+ goto K
-}
--------------------------------------------------------------
-- A heap/stack check at a function or thunk entry point.
-entryHeapCheck :: Maybe LocalReg -- Function (closure environment)
- -> Int -- Arity -- not same as length args b/c of voids
- -> [LocalReg] -- Non-void args (empty for thunk)
- -> FCode ()
- -> FCode ()
+entryHeapCheck :: ClosureInfo
+ -> Int -- Arg Offset
+ -> Maybe LocalReg -- Function (closure environment)
+ -> Int -- Arity -- not same as len args b/c of voids
+ -> [LocalReg] -- Non-void args (empty for thunk)
+ -> FCode ()
+ -> FCode ()
-entryHeapCheck fun arity args code
+entryHeapCheck cl_info offset nodeSet arity args code
= do updfr_sz <- getUpdFrameOff
- heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive
+ heapCheck True (gc_call updfr_sz) code
+
where
+ is_thunk = arity == 0
+ is_fastf = case closureFunInfo cl_info of
+ Just (_, ArgGen _) -> False
+ _otherwise -> True
+
+ args' = map (CmmReg . CmmLocal) args
+ setN = case nodeSet of
+ Just n -> mkAssign nodeReg (CmmReg $ CmmLocal n)
+ Nothing -> mkAssign nodeReg $
+ CmmLit (CmmLabel $ closureLabelFromCI cl_info)
+
+ {- Thunks: Set R1 = node, jump GCEnter1
+ Function (fast): Set R1 = node, jump GCFun
+ Function (slow): Set R1 = node, call generic_gc -}
+ gc_call upd = setN <*> gc_lbl upd
+ gc_lbl upd
+ | is_thunk = mkDirectJump (CmmReg $ CmmGlobal GCEnter1) [] sp
+ | is_fastf = mkDirectJump (CmmReg $ CmmGlobal GCFun) [] sp
+ | otherwise = mkForeignJump Slow (CmmReg $ CmmGlobal GCFun) args' upd
+ where sp = max offset upd
+ {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount.
+ - This is since the ncg inserts spills before the stack/heap check.
+ - This should be fixed up and then we won't need to fix up the Sp on
+ - GC calls, but until then this fishy code works -}
+
+{-
+ -- This code is slightly outdated now and we could easily keep the above
+ -- GC methods. However, there may be some performance gains to be made by
+ -- using more specialised GC entry points. Since the semi generic GCFun
+ -- entry needs to check the node and figure out what registers to save...
+ -- if we provided and used more specialised GC entry points then these
+ -- runtime decisions could be turned into compile time decisions.
+
args' = case fun of Just f -> f : args
Nothing -> args
arg_exprs = map (CmmReg . CmmLocal) args'
gc_call updfr_sz
| arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
- | otherwise = case gc_lbl args' of
- Just _lbl -> panic "StgCmmHeap.entryHeapCheck: gc_lbl not finished"
- -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
- -- arg_exprs updfr_sz
- Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz
+ | otherwise =
+ case gc_lbl args' of
+ Just _lbl -> panic "StgCmmHeap.entryHeapCheck: not finished"
+ -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
+ -- arg_exprs updfr_sz
+ Nothing -> mkCall generic_gc (GC, GC) [] [] updfr_sz
gc_lbl :: [LocalReg] -> Maybe FastString
-{-
gc_lbl [reg]
- | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
- | isFloatType ty = case width of
- W32 -> Just (sLit "stg_gc_f1") -- "stg_gc_fun_f1"
- W64 -> Just (sLit "stg_gc_d1") -- "stg_gc_fun_d1"
- _other -> Nothing
- | otherwise = case width of
- W32 -> Just (sLit "stg_gc_unbx_r1") -- "stg_gc_fun_unbx_r1"
- W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
- _other -> Nothing -- Narrow cases
- where
- ty = localRegType reg
- width = typeWidth ty
--}
+ | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
+ | isFloatType ty = case width of
+ W32 -> Just (sLit "stg_gc_f1")
+ W64 -> Just (sLit "stg_gc_d1")
+ _other -> Nothing
+ | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1")
+ | width == W64 = Just (mkGcLabel "stg_gc_l1")
+ | otherwise = Nothing
+ where
+ ty = localRegType reg
+ width = typeWidth ty
gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
gc_lbl_ptrs :: [Bool] -> Maybe FastString
- -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
+ -- JD: TEMPORARY -- UNTIL THESE FUNCTIONS EXIST...
--gc_lbl_ptrs [True,True] = Just (sLit "stg_gc_fun_2p")
--gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p")
gc_lbl_ptrs _ = Nothing
-
+-}
+
+
+--------------------------------------------------------------
+-- A heap/stack check at in a case alternative
altHeapCheck :: [LocalReg] -> FCode a -> FCode a
altHeapCheck regs code
= do updfr_sz <- getUpdFrameOff
heapCheck False (gc_call updfr_sz) code
- where
- gc_call updfr_sz
- | null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz
- | Just _gc_lbl <- rts_label regs -- Canned call
- = panic "StgCmmHeap.altHeapCheck: rts_label not finished"
- -- mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC)
- -- regs (map (CmmReg . CmmLocal) regs) updfr_sz
- | otherwise -- No canned call, and non-empty live vars
- = mkCall generic_gc (GC, GC) [] [] updfr_sz
-
-{-
- rts_label [reg]
- | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1")
- | isFloatType ty = case width of
- W32 -> Just (sLit "stg_gc_f1")
- W64 -> Just (sLit "stg_gc_d1")
- _other -> Nothing
- | otherwise = case width of
- W32 -> Just (sLit "stg_gc_unbx_r1")
- W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1"
- _other -> Nothing -- Narrow cases
- where
- ty = localRegType reg
- width = typeWidth ty
--}
+ where
+ reg_exprs = map (CmmReg . CmmLocal) regs
+
+ gc_call sp =
+ case rts_label regs of
+ Just gc -> mkCall (CmmLit gc) (GC, GC) regs reg_exprs sp
+ Nothing -> mkCall generic_gc (GC, GC) [] [] sp
+
+ rts_label [reg]
+ | isGcPtrType ty = Just (mkGcLabel "stg_gc_unpt_r1")
+ | isFloatType ty = case width of
+ W32 -> Just (mkGcLabel "stg_gc_f1")
+ W64 -> Just (mkGcLabel "stg_gc_d1")
+ _ -> Nothing
+
+ | width == wordWidth = Just (mkGcLabel "stg_gc_unbx_r1")
+ | width == W64 = Just (mkGcLabel "stg_gc_l1")
+ | otherwise = Nothing
+ where
+ ty = localRegType reg
+ width = typeWidth ty
rts_label _ = Nothing
-generic_gc :: CmmExpr -- The generic GC procedure; no params, no resuls
-generic_gc = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")))
--- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
--- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))
+-- | The generic GC procedure; no params, no results
+generic_gc :: CmmExpr
+generic_gc = CmmLit $ mkGcLabel "stg_gc_noregs"
+
+-- | Create a CLabel for calling a garbage collector entry point
+mkGcLabel :: String -> CmmLit
+mkGcLabel = (CmmLabel . (mkCmmCodeLabel rtsPackageId) . fsLit)
-------------------------------
heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a
heapCheck checkStack do_gc code
= getHeapUsage $ \ hpHw ->
- do { emit $ do_checks checkStack hpHw do_gc
- -- Emit heap checks, but be sure to do it lazily so
- -- that the conditionals on hpHw don't cause a black hole
- ; tickyAllocHeap hpHw
- ; doGranAllocate hpHw
- ; setRealHp hpHw
- ; code }
+ -- Emit heap checks, but be sure to do it lazily so
+ -- that the conditionals on hpHw don't cause a black hole
+ do { emit $ do_checks checkStack hpHw do_gc
+ ; tickyAllocHeap hpHw
+ ; doGranAllocate hpHw
+ ; setRealHp hpHw
+ ; code }
do_checks :: Bool -- Should we check the stack?
- -> WordOff -- Heap headroom
- -> CmmAGraph -- What to do on failure
+ -> WordOff -- Heap headroom
+ -> CmmAGraph -- What to do on failure
-> CmmAGraph
do_checks checkStack alloc do_gc
= withFreshLabel "gc" $ \ loop_id ->
withFreshLabel "gc" $ \ gc_id ->
- mkLabel loop_id
+ mkLabel loop_id
<*> (let hpCheck = if alloc == 0 then mkNop
else mkAssign hpReg bump_hp <*>
- mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
- in if checkStack then
- mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
- else hpCheck)
+ mkCmmIfThen hp_oflo (alloc_n <*> mkBranch gc_id)
+ in if checkStack
+ then mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
+ else hpCheck)
<*> mkComment (mkFastString "outOfLine should follow:")
- <*> outOfLine (mkLabel gc_id
+ <*> outOfLine (mkLabel gc_id
<*> mkComment (mkFastString "outOfLine here")
<*> do_gc
<*> mkBranch loop_id)
- -- Test for stack pointer exhaustion, then
- -- bump heap pointer, and test for heap exhaustion
- -- Note that we don't move the heap pointer unless the
- -- stack check succeeds. Otherwise we might end up
- -- with slop at the end of the current block, which can
- -- confuse the LDV profiler.
+ -- Test for stack pointer exhaustion, then
+ -- bump heap pointer, and test for heap exhaustion
+ -- Note that we don't move the heap pointer unless the
+ -- stack check succeeds. Otherwise we might end up
+ -- with slop at the end of the current block, which can
+ -- confuse the LDV profiler.
where
- alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes
+ alloc_lit = CmmLit (mkIntCLit (alloc*wORD_SIZE)) -- Bytes
bump_hp = cmmOffsetExprB (CmmReg hpReg) alloc_lit
- -- Sp overflow if (Sp - CmmHighStack < SpLim)
- sp_oflo = CmmMachOp mo_wordULt
- [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg)))
+ -- Sp overflow if (Sp - CmmHighStack < SpLim)
+ sp_oflo = CmmMachOp mo_wordULt
+ [CmmMachOp (MO_Sub (typeWidth (cmmRegType spReg)))
[CmmReg spReg, CmmLit CmmHighStackMark],
CmmReg spLimReg]
- -- Hp overflow if (Hp > HpLim)
- -- (Hp has been incremented by now)
- -- HpLim points to the LAST WORD of valid allocation space.
- hp_oflo = CmmMachOp mo_wordUGt
- [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
- save_alloc = mkAssign (CmmGlobal HpAlloc) alloc_lit
+ -- Hp overflow if (Hp > HpLim)
+ -- (Hp has been incremented by now)
+ -- HpLim points to the LAST WORD of valid allocation space.
+ hp_oflo = CmmMachOp mo_wordUGt
+ [CmmReg hpReg, CmmReg (CmmGlobal HpLim)]
+
+ alloc_n = mkAssign (CmmGlobal HpAlloc) alloc_lit
{-
always organise the stack-resident fields into pointers &
non-pointers, and pass the number of each to the heap check code. -}
-unbxTupleHeapCheck
- :: [(Id, GlobalReg)] -- Live registers
- -> WordOff -- no. of stack slots containing ptrs
- -> WordOff -- no. of stack slots containing nonptrs
- -> CmmAGraph -- code to insert in the failure path
- -> FCode ()
- -> FCode ()
+unbxTupleHeapCheck
+ :: [(Id, GlobalReg)] -- Live registers
+ -> WordOff -- no. of stack slots containing ptrs
+ -> WordOff -- no. of stack slots containing nonptrs
+ -> CmmAGraph -- code to insert in the failure path
+ -> FCode ()
+ -> FCode ()
unbxTupleHeapCheck regs ptrs nptrs fail_code code
- -- We can't manage more than 255 pointers/non-pointers
+ -- We can't manage more than 255 pointers/non-pointers
-- in a generic heap check.
| ptrs > 255 || nptrs > 255 = panic "altHeapCheck"
- | otherwise
+ | otherwise
= initHeapUsage $ \ hpHw -> do
- { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
- full_fail_code rts_label
- ; tickyAllocHeap hpHw }
- ; setRealHp hpHw
- ; code }
+ { codeOnly $ do { do_checks 0 {- no stack check -} hpHw
+ full_fail_code rts_label
+ ; tickyAllocHeap hpHw }
+ ; setRealHp hpHw
+ ; code }
where
full_fail_code = fail_code `plusStmts` oneStmt assign_liveness
- assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho!
- (CmmLit (mkWordCLit liveness))
- liveness = mkRegLiveness regs ptrs nptrs
- rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
+ assign_liveness = CmmAssign (CmmGlobal (VanillaReg 9)) -- Ho ho ho!
+ (CmmLit (mkWordCLit liveness))
+ liveness = mkRegLiveness regs ptrs nptrs
+ rts_label = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_ut")))
-{- Old Gransim comment -- I have no idea whether it still makes sense (SLPJ Sep07)
+{- Old Gransim com -- I have no idea whether it still makes sense (SLPJ Sep07)
For GrAnSim the code for doing a heap check and doing a context switch
has been separated. Especially, the HEAP_CHK macro only performs a
heap check. THREAD_CONTEXT_SWITCH should be used for doing a context
in the meantime.
%************************************************************************
-%* *
+%* *
Generic Heap/Stack Checks - used in the RTS
-%* *
+%* *
%************************************************************************
\begin{code}
= do_checks' bytes True assigns stg_gc_gen
where
assigns = mkStmts [
- CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
- CmmAssign (CmmGlobal (VanillaReg 10)) reentry
- ]
+ CmmAssign (CmmGlobal (VanillaReg 9)) liveness,
+ CmmAssign (CmmGlobal (VanillaReg 10)) reentry
+ ]
-- a heap check where R1 points to the closure to enter on return, and
-- we want to assign to Sp[0] on failure (used in AutoApply.cmm:BUILD_PAP).
import StgCmmMonad
import StgCmmForeign
-import MkZipCfgCmm
-import Cmm
+import MkGraph
+import CmmDecl
+import CmmExpr
import CLabel
import Module
import CmmUtils
--
-----------------------------------------------------------------------------
-{-# OPTIONS #-}
--- 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 StgCmmLayout (
mkArgDescr,
emitCall, emitReturn,
import StgCmmUtils
import StgCmmMonad
-import MkZipCfgCmm
+import MkGraph
import SMRep
+import CmmDecl
+import CmmExpr
import CmmUtils
-import Cmm
import CLabel
import StgSyn
import DataCon
-> Id -- name of the closure
-> ClosureInfo -- lots of info abt the closure
-> [NonVoid Id] -- incoming arguments
- -> ((LocalReg, [LocalReg]) -> FCode ()) -- function body
+ -> ((Int, LocalReg, [LocalReg]) -> FCode ()) -- function body
-> FCode ()
emitClosureProcAndInfoTable top_lvl bndr cl_info args body
= do { let lf_info = closureLFInfo cl_info
; let node_points = nodeMustPointToIt lf_info
; arg_regs <- bindArgsToRegs args
; let args' = if node_points then (node : arg_regs) else arg_regs
- conv = if nodeMustPointToIt lf_info
- then NativeNodeCall else NativeDirectCall
- ; emitClosureAndInfoTable cl_info conv args' $ body (node, arg_regs)
+ conv = if nodeMustPointToIt lf_info then NativeNodeCall
+ else NativeDirectCall
+ (offset, _) = mkCallEntry conv args'
+ ; emitClosureAndInfoTable cl_info conv args' $ body (offset, node, arg_regs)
}
-- Data constructors need closures, but not with all the argument handling
where
info_lbl = infoTableLabelFromCI cl_info
--- Convert from 'ClosureInfo' to 'CmmInfo'.
+-- Convert from 'ClosureInfo' to 'CmmInfoTable'.
-- Not used for return points. (The 'smRepClosureTypeInt' call would panic.)
-mkCmmInfo :: ClosureInfo -> FCode CmmInfo
+mkCmmInfo :: ClosureInfo -> FCode CmmInfoTable
mkCmmInfo cl_info
= do { info <- closureTypeInfo cl_info k_with_con_name return
; prof <- if opt_SccProfilingOn then
ad_lit <- mkStringCLit (closureValDescr cl_info)
return $ ProfilingInfo fd_lit ad_lit
else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
- ; return (CmmInfo gc_target Nothing
- (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) }
+ ; return (CmmInfoTable (isStaticClosure cl_info) prof cl_type info) }
where
k_with_con_name con_info con info_lbl =
do cstr <- mkByteStringCLit $ dataConIdentity con
return $ con_info $ makeRelativeRefTo info_lbl cstr
cl_type = smRepClosureTypeInt (closureSMRep cl_info)
- -- The gc_target is to inform the CPS pass when it inserts a stack check.
- -- Since that pass isn't used yet we'll punt for now.
- -- When the CPS pass is fully integrated, this should
- -- be replaced by the label that any heap check jumped to,
- -- so that branch can be shared by both the heap (from codeGen)
- -- and stack checks (from the CPS pass).
- -- JD: Actually, we've decided to go a different route here:
- -- the code generator is now responsible for producing the
- -- stack limit check explicitly, so this field is now obsolete.
- gc_target = Nothing
-
-----------------------------------------------------------------------------
--
-- Info table offsets
import StgCmmClosure
import DynFlags
-import MkZipCfgCmm
-import ZipCfgCmmRep (UpdFrameOffset)
+import MkGraph
import BlockId
-import Cmm
+import CmmDecl
+import CmmExpr
+import CmmNode (UpdFrameOffset)
import CLabel
import TyCon ( PrimRep )
import SMRep
= MkCgState {
cgs_stmts :: CmmAGraph, -- Current procedure
- cgs_tops :: OrdList CmmTopZ,
+ cgs_tops :: OrdList CmmTop,
-- Other procedures and data blocks in this compilation unit
-- Both are ordered only so that we can
-- reduce forward references, when it's easy to do so
where
data_block = CmmData sect lits
-emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals ->
+emitProcWithConvention :: Convention -> CmmInfoTable -> CLabel -> CmmFormals ->
CmmAGraph -> FCode ()
emitProcWithConvention conv info lbl args blocks
= do { us <- newUniqSupply
- ; let (uniq, us') = takeUniqFromSupply us
- (offset, entry) = mkEntry (mkBlockId uniq) conv args
- blks = initUs_ us' $ lgraphOfAGraph $ entry <*> blocks
- ; let proc_block = CmmProc info lbl args ((offset, Just initUpdFrameOff), blks)
+ ; let (offset, entry) = mkCallEntry conv args
+ blks = initUs_ us $ lgraphOfAGraph $ entry <*> blocks
+ ; let sinfo = StackInfo {arg_space = offset, updfr_space = Just initUpdFrameOff}
+ proc_block = CmmProc (TopInfo {info_tbl=info, stack_info=sinfo}) lbl blks
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
-emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
+emitProc :: CmmInfoTable -> CLabel -> CmmFormals -> CmmAGraph -> FCode ()
emitProc = emitProcWithConvention NativeNodeCall
emitSimpleProc :: CLabel -> CmmAGraph -> FCode ()
emitSimpleProc lbl code =
- emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code
+ emitProc CmmNonInfoTable lbl [] code
-getCmm :: FCode () -> FCode CmmZ
+getCmm :: FCode () -> 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)
import StgCmmMonad
import StgCmmUtils
-import MkZipCfgCmm
+import MkGraph
import StgSyn
-import Cmm
+import CmmDecl
+import CmmExpr
import Type ( Type, tyConAppTyCon )
import TyCon
import CLabel
import StgCmmMonad
import SMRep
-import MkZipCfgCmm
-import Cmm
+import MkGraph
+import CmmExpr
+import CmmDecl
import CmmUtils
import CLabel
import SMRep
import StgSyn
-import Cmm
-import MkZipCfgCmm
+import CmmExpr
+import MkGraph
import CmmUtils
import CLabel
tagToClosure, mkTaggedObjectLoad,
- callerSaveVolatileRegs, get_GlobalReg_addr,
+ callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr,
cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord,
cmmUGtWord,
import StgCmmMonad
import StgCmmClosure
import BlockId
-import Cmm hiding (regUsedIn)
-import MkZipCfgCmm
+import CmmDecl
+import CmmExpr hiding (regUsedIn)
+import MkGraph
import CLabel
import CmmUtils
-import PprCmm ( {- instances -} )
import ForeignCall
import IdInfo
CPP-Options: -DOMIT_NATIVE_CODEGEN
Build-Depends: bin-package-db
+ Build-Depends: hoopl
-- GHC 6.4.2 needs to be able to find WCsubst.c, which needs to be
-- able to find WCsubst.h
BlockId
CLabel
Cmm
- CmmBrokenBlock
CmmBuildInfoTables
CmmCPS
- CmmCPSGen
- CmmCPSZ
CmmCallConv
- CmmCommonBlockElimZ
+ CmmCommonBlockElim
CmmContFlowOpt
CmmCvt
+ CmmDecl
CmmExpr
CmmInfo
CmmLex
CmmLint
CmmLive
- CmmLiveZ
+ CmmMachOp
+ CmmNode
CmmOpt
CmmParse
CmmProcPoint
- CmmProcPointZ
CmmSpillReload
CmmStackLayout
- CmmTx
+ CmmType
CmmUtils
- CmmZipUtil
- DFMonad
- Dataflow
- MkZipCfg
- MkZipCfgCmm
+ MkGraph
+ OldCmm
+ OldCmmUtils
+ OldPprCmm
OptimizationFuel
PprBase
PprC
PprCmm
- PprCmmZ
- StackColor
- StackPlacements
- ZipCfg
- ZipCfgCmmRep
- ZipCfgExtras
- ZipDataflow
+ PprCmmDecl
+ PprCmmExpr
Bitmap
CgBindery
CgCallConv
import LlvmMangler
import CLabel
-import Cmm
import CgUtils ( fixStgRegisters )
-import PprCmm
+import OldCmm
+import OldPprCmm
import BufWrite
import DynFlags
llvmCodeGen dflags h us cmms
= let cmm = concat $ map (\(Cmm top) -> top) cmms
(cdata,env) = foldr split ([],initLlvmEnv) cmm
- split (CmmData s d' ) (d,e) = ((s,d'):d,e)
- split (CmmProc i l _ _) (d,e) =
+ split (CmmData s d' ) (d,e) = ((s,d'):d,e)
+ split (CmmProc i l _) (d,e) =
let lbl = strCLabel_llvm $ if not (null i)
then entryLblToInfoLbl l
else l
import CLabel
import CgUtils ( activeStgRegs )
-import Cmm
import Constants
import FastString
+import OldCmm
import qualified Outputable as Outp
import UniqFM
import Unique
import BlockId
import CgUtils ( activeStgRegs, callerSaves )
import CLabel
-import Cmm
-import qualified PprCmm
+import OldCmm
+import qualified OldPprCmm as PprCmm
import OrdList
import BasicTypes
genLlvmProc env (CmmData _ _)
= return (env, [])
-genLlvmProc env (CmmProc _ _ _ (ListGraph []))
+genLlvmProc env (CmmProc _ _ (ListGraph []))
= return (env, [])
-genLlvmProc env (CmmProc info lbl params (ListGraph blocks))
+genLlvmProc env (CmmProc info lbl (ListGraph blocks))
= do
(env', lmblocks, lmdata) <- basicBlocksCodeGen env blocks ([], [])
- let proc = CmmProc info lbl params (ListGraph lmblocks)
+ let proc = CmmProc info lbl (ListGraph lmblocks)
let tops = lmdata ++ [proc]
return (env', tops)
import BlockId
import CLabel
-import Cmm
+import OldCmm
import FastString
import qualified Outputable
import LlvmCodeGen.Data
import CLabel
-import Cmm
+import OldCmm
import FastString
import qualified Outputable
pprLlvmCmmTop _ _ (CmmData _ lmdata)
= (vcat $ map pprLlvmData lmdata, [])
-pprLlvmCmmTop env count (CmmProc info lbl _ (ListGraph blks))
+pprLlvmCmmTop env count (CmmProc info lbl (ListGraph blks))
= let static = CmmDataLabel lbl : info
(idoc, ivar) = if not (null info)
then pprInfoTable env count lbl static
import CmmLint ( cmmLint )
import Packages
import Util
-import Cmm ( RawCmm )
+import OldCmm ( RawCmm )
import HscTypes
import DynFlags
import Config
import Name ( Name, NamedThing(..) )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
-import Cmm ( Cmm )
+import OldCmm ( Cmm )
import PprCmm ( pprCmms )
import CmmParse ( parseCmmFile )
import CmmBuildInfoTables
import CmmCPS
-import CmmCPSZ
import CmmInfo
import OptimizationFuel ( initOptFuelState )
import CmmCvt
-import CmmTx
-import CmmContFlowOpt
+import CmmContFlowOpt ( runCmmContFlowOpts )
import CodeOutput
import NameEnv ( emptyNameEnv )
import NameSet ( emptyNameSet )
stg_binds hpc_info
--- Optionally run experimental Cmm transformations ---
- -- cmms <- optionallyConvertAndOrCPS hsc_env cmms
+ cmms <- optionallyConvertAndOrCPS hsc_env cmms
-- unless certain dflags are on, the identity function
------------------ Code output -----------------------
rawcmms <- cmmToRawCmm cmms
; dumpIfSet_dyn dflags Opt_D_dump_cmmz "Cmm produced by new codegen"
(pprCmms prog)
- ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog
+ ; prog <- return $ map runCmmContFlowOpts prog
-- Control flow optimisation
-- We are building a single SRT for the entire module, so
-- we must thread it through all the procedures as we cps-convert them.
; us <- mkSplitUniqSupply 'S'
; let topSRT = initUs_ us emptySRT
- ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog
+ ; (topSRT, prog) <- foldM (protoCmmCPS hsc_env) (topSRT, []) prog
-- The main CPS conversion
- ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog)
+ ; prog <- return $ map runCmmContFlowOpts (srtToData topSRT : prog)
-- Control flow optimisation, again
; let prog' = map cmmOfZgraph prog
cmms <- if dopt Opt_ConvertToZipCfgAndBack dflags
then mapM (testCmmConversion hsc_env) cmms
else return cmms
- --------- Optionally convert to CPS (MDA) -----------
- cmms <- if not (dopt Opt_ConvertToZipCfgAndBack dflags) &&
- dopt Opt_RunCPS dflags
- then cmmCPS dflags cmms
- else return cmms
return cmms
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 cvtm = runCmmContFlowOpts `liftM` cmmToZgraph cmm
let zgraph = initUs_ us cvtm
us <- mkSplitUniqSupply 'S'
let topSRT = initUs_ us emptySRT
- (_, [cps_zgraph]) <- protoCmmCPSZ hsc_env (topSRT, []) zgraph
+ (_, [cps_zgraph]) <- protoCmmCPS hsc_env (topSRT, []) 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
+ let cvt = cmmOfZgraph $ runCmmContFlowOpts $ chosen_graph
dumpIfSet_dyn dflags Opt_D_dump_cvt_cmm "C-- post-conversion" (ppr cvt)
return cvt
import BlockId
import CgUtils ( fixStgRegisters )
-import Cmm
+import OldCmm
import CmmOpt ( cmmMiniInline, cmmMachOpFold )
-import PprCmm
+import OldPprCmm
import CLabel
import UniqFM
| dopt Opt_SplitObjs dflags = split_marker : tops
| otherwise = tops
- split_marker = CmmProc [] mkSplitMarkerLabel [] (ListGraph [])
+ split_marker = CmmProc [] mkSplitMarkerLabel (ListGraph [])
-- | Do native code generation on all these cmms.
#if i386_TARGET_ARCH
x86fp_kludge :: NatCmmTop Instr -> NatCmmTop Instr
x86fp_kludge top@(CmmData _ _) = top
-x86fp_kludge (CmmProc info lbl params (ListGraph code)) =
- CmmProc info lbl params (ListGraph $ i386_insert_ffrees code)
+x86fp_kludge (CmmProc info lbl (ListGraph code)) =
+ CmmProc info lbl (ListGraph $ i386_insert_ffrees code)
#endif
-> NatCmmTop Instr
sequenceTop top@(CmmData _ _) = top
-sequenceTop (CmmProc info lbl params (ListGraph blocks)) =
- CmmProc info lbl params (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
+sequenceTop (CmmProc info lbl (ListGraph blocks)) =
+ CmmProc info lbl (ListGraph $ makeFarBranches $ sequenceBlocks blocks)
-- The algorithm is very simple (and stupid): we make a graph out of
-- the blocks where there is an edge from one block to another iff 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).
+-- algorithm is implemented in Hoopl.
sequenceBlocks
:: Instruction instr
build_mapping :: GenCmmTop d t (ListGraph Instr)
-> (GenCmmTop d t (ListGraph Instr), UniqFM JumpDest)
build_mapping top@(CmmData _ _) = (top, emptyUFM)
-build_mapping (CmmProc info lbl params (ListGraph []))
- = (CmmProc info lbl params (ListGraph []), emptyUFM)
-build_mapping (CmmProc info lbl params (ListGraph (head:blocks)))
- = (CmmProc info lbl params (ListGraph (head:others)), mapping)
+build_mapping (CmmProc info lbl (ListGraph []))
+ = (CmmProc info lbl (ListGraph []), emptyUFM)
+build_mapping (CmmProc info lbl (ListGraph (head:blocks)))
+ = (CmmProc info lbl (ListGraph (head:others)), mapping)
-- drop the shorted blocks, but don't ever drop the first one,
-- because it is pointed to by a global label.
where
(_, shortcut_blocks, others) = foldl split (emptyBlockSet, [], []) blocks
split (s, shortcut_blocks, others) b@(BasicBlock id [insn])
| Just (DestBlockId dest) <- canShortcut insn,
- (elemBlockSet dest s) || dest == id -- loop checks
+ (setMember dest s) || dest == id -- loop checks
= (s, shortcut_blocks, b : others)
split (s, shortcut_blocks, others) (BasicBlock id [insn])
| Just dest <- canShortcut insn
- = (extendBlockSet s id, (id,dest) : shortcut_blocks, others)
+ = (setInsert id s, (id,dest) : shortcut_blocks, others)
split (s, shortcut_blocks, others) other = (s, shortcut_blocks, other : others)
= CmmData sec (map (shortcutStatic (lookupUFM ufm)) statics)
-- we need to get the jump tables, so apply the mapping to the entries
-- of a CmmData too.
-apply_mapping ufm (CmmProc info lbl params (ListGraph blocks))
- = CmmProc info lbl params (ListGraph $ map short_bb blocks)
+apply_mapping ufm (CmmProc info lbl (ListGraph blocks))
+ = CmmProc info lbl (ListGraph $ map short_bb blocks)
where
short_bb (BasicBlock id insns) = BasicBlock id $! map short_insn insns
short_insn i = shortcutJump (lookupUFM ufm) i
else pprPanic "genMachCode: nonzero final delta" (int final_delta)
}
-
-- -----------------------------------------------------------------------------
-- Generic Cmm optimiser
cmmToCmm :: DynFlags -> RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm _ top@(CmmData _ _) = (top, [])
-cmmToCmm dflags (CmmProc info lbl params (ListGraph blocks)) = runCmmOpt dflags $ do
+cmmToCmm dflags (CmmProc info lbl (ListGraph blocks)) = runCmmOpt dflags $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
- return $ CmmProc info lbl params (ListGraph blocks')
+ return $ CmmProc info lbl (ListGraph blocks')
newtype CmmOptM a = CmmOptM (([CLabel], DynFlags) -> (# a, [CLabel] #))
import Reg
import BlockId
-import Cmm
+import OldCmm
-- | Holds a list of source and destination registers used by a
-- particular instruction.
getBlockIdNat :: NatM BlockId
getBlockIdNat
= do u <- getUniqueNat
- return (BlockId u)
+ return (mkBlockId u)
getNewLabelNat :: NatM CLabel
import NCGMonad
-import Cmm
+import OldCmm
import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel,
mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..),
dynamicLinkerLabelInfo, mkPicBaseLabel,
-> NatM [NatCmmTop PPC.Instr]
initializePicBase_ppc ArchPPC os picReg
- (CmmProc info lab params (ListGraph blocks) : statics)
+ (CmmProc info lab (ListGraph blocks) : statics)
| osElfTarget os
= do
gotOffLabel <- getNewLabelNat
: PPC.ADD picReg picReg (PPC.RIReg tmp)
: insns)
- return (CmmProc info lab params (ListGraph (b' : tail blocks)) : gotOffset : statics)
+ return (CmmProc info lab (ListGraph (b' : tail blocks)) : gotOffset : statics)
initializePicBase_ppc ArchPPC OSDarwin picReg
- (CmmProc info lab params (ListGraph blocks) : statics)
- = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
+ (CmmProc info lab (ListGraph blocks) : statics)
+ = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics)
where BasicBlock bID insns = head blocks
b' = BasicBlock bID (PPC.FETCHPC picReg : insns)
-> NatM [NatCmmTop X86.Instr]
initializePicBase_x86 ArchX86 os picReg
- (CmmProc info lab params (ListGraph blocks) : statics)
+ (CmmProc info lab (ListGraph blocks) : statics)
| osElfTarget os
- = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
+ = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics)
where BasicBlock bID insns = head blocks
b' = BasicBlock bID (X86.FETCHGOT picReg : insns)
initializePicBase_x86 ArchX86 OSDarwin picReg
- (CmmProc info lab params (ListGraph blocks) : statics)
- = return (CmmProc info lab params (ListGraph (b':tail blocks)) : statics)
+ (CmmProc info lab (ListGraph blocks) : statics)
+ = return (CmmProc info lab (ListGraph (b':tail blocks)) : statics)
where BasicBlock bID insns = head blocks
b' = BasicBlock bID (X86.FETCHPC picReg : insns)
-- Our intermediate code:
import BlockId
import PprCmm ( pprExpr )
-import Cmm
+import OldCmm
import CLabel
-- The rest:
import OrdList
import qualified Outputable as O
import Outputable
+import Unique
import DynFlags
import Control.Monad ( mapAndUnzipM )
-> RawCmmTop
-> NatM [NatCmmTop Instr]
-cmmTopCodeGen dflags (CmmProc info lab params (ListGraph blocks)) = do
+cmmTopCodeGen dflags (CmmProc info lab (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
- let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
+ let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
tops = proc : concat statics
os = platformOS $ targetPlatform dflags
case picBaseMb of
-- | Convert a BlockId to some CmmStatic data
jumpTableEntry :: Maybe BlockId -> CmmStatic
jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
-jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
- where blockLabel = mkAsmTempLabel id
+jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
jumpTableEntryRel Nothing
= CmmStaticLit (CmmInt 0 wordWidth)
- jumpTableEntryRel (Just (BlockId id))
+ jumpTableEntryRel (Just blockid)
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
- where blockLabel = mkAsmTempLabel id
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
code = e_code `appOL` t_code `appOL` toOL [
LDATA ReadOnlyData (CmmDataLabel lbl : jumpTable),
import Constants (rESERVED_C_STACK_BYTES)
import BlockId
-import Cmm
+import OldCmm
import FastString
import CLabel
import Outputable
import RegClass
import TargetReg
-import BlockId
-import Cmm
+import OldCmm
import CLabel
-import Unique ( pprUnique )
+import Unique ( pprUnique, Uniquable(..) )
import Pretty
import FastString
import qualified Outputable
pprSectionHeader section $$ vcat (map pprData dats)
-- special case for split markers:
-pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
+pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl
-pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) =
+pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) =
pprSectionHeader Text $$
(if null info then -- blocks guaranteed not null, so label needed
pprLabel lbl
pprBasicBlock :: NatBasicBlock Instr -> Doc
-pprBasicBlock (BasicBlock (BlockId id) instrs) =
- pprLabel (mkAsmTempLabel id) $$
+pprBasicBlock (BasicBlock blockid instrs) =
+ pprLabel (mkAsmTempLabel (getUnique blockid)) $$
vcat (map pprInstr instrs)
RIReg _ -> empty
RIImm _ -> char 'i'
]
-pprInstr (BCC cond (BlockId id)) = hcat [
+pprInstr (BCC cond blockid) = hcat [
char '\t',
ptext (sLit "b"),
pprCond cond,
char '\t',
pprCLabel_asm lbl
]
- where lbl = mkAsmTempLabel id
+ where lbl = mkAsmTempLabel (getUnique blockid)
-pprInstr (BCCFAR cond (BlockId id)) = vcat [
+pprInstr (BCCFAR cond blockid) = vcat [
hcat [
ptext (sLit "\tb"),
pprCond (condNegate cond),
pprCLabel_asm lbl
]
]
- where lbl = mkAsmTempLabel id
+ where lbl = mkAsmTempLabel (getUnique blockid)
pprInstr (JMP lbl) = hcat [ -- an alias for b that takes a CLabel
char '\t',
import PPC.Instr
import BlockId
-import Cmm
+import OldCmm
import CLabel
import Outputable
+import Unique
data JumpDest = DestBlockId BlockId | DestImm Imm
shortcutStatic fn (CmmStaticLit (CmmLabel lab))
| Just uq <- maybeAsmTemp lab
- = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq)))
+ = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq)))
shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
| Just uq <- maybeAsmTemp lbl1
- = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off)
+ = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off)
-- slightly dodgy, we're ignoring the second label, but this
-- works with the way we use CmmLabelDiffOff for jump tables now.
-> BlockId
-> CLabel
-shortBlockId fn blockid@(BlockId uq) =
+shortBlockId fn blockid =
case fn blockid of
Nothing -> mkAsmTempLabel uq
Just (DestBlockId blockid') -> shortBlockId fn blockid'
Just (DestImm (ImmCLbl lbl)) -> lbl
_other -> panic "shortBlockId"
+ where uq = getUnique blockid
import Size
import BlockId
-import Cmm
+import OldCmm
import CLabel ( CLabel )
import Unique
import Instruction
import Reg
-import Cmm
+import OldCmm
import Bag
import Digraph
import UniqFM
slurpJoinMovs live
= slurpCmm emptyBag live
where
- slurpCmm rs CmmData{} = rs
- slurpCmm rs (CmmProc _ _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs)
- slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs
+ slurpCmm rs CmmData{} = rs
+ slurpCmm rs (CmmProc _ _ sccs) = foldl' slurpBlock rs (flattenSCCs sccs)
+ slurpBlock rs (BasicBlock _ instrs) = foldl' slurpLI rs instrs
- slurpLI rs (LiveInstr _ Nothing) = rs
+ slurpLI rs (LiveInstr _ Nothing) = rs
slurpLI rs (LiveInstr instr (Just live))
| Just (r1, r2) <- takeRegRegMoveInstr instr
, elementOfUniqSet r1 $ liveDieRead live
import RegAlloc.Liveness
import Instruction
import Reg
-import Cmm hiding (RegSet)
+import OldCmm hiding (RegSet)
import BlockId
import State
CmmData{}
-> return cmm
- CmmProc info label params sccs
+ CmmProc info label sccs
| LiveInfo static firstId mLiveVRegsOnEntry liveSlotsOnEntry <- info
-> do
-- We should only passed Cmms with the liveness maps filled in, but we'll
-- create empty ones if they're not there just in case.
- let liveVRegsOnEntry = fromMaybe emptyBlockEnv mLiveVRegsOnEntry
+ let liveVRegsOnEntry = fromMaybe mapEmpty mLiveVRegsOnEntry
-- The liveVRegsOnEntry contains the set of vregs that are live on entry to
-- each basic block. If we spill one of those vregs we remove it from that
-- reload instructions after we've done a successful allocation.
let liveSlotsOnEntry' :: Map BlockId (Set Int)
liveSlotsOnEntry'
- = foldBlockEnv patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry
+ = mapFoldWithKey patchLiveSlot liveSlotsOnEntry liveVRegsOnEntry
let info'
= LiveInfo static firstId
-- Apply the spiller to all the basic blocks in the CmmProc.
sccs' <- mapM (mapSCCM (regSpill_block regSlotMap)) sccs
- return $ CmmProc info' label params sccs'
+ return $ CmmProc info' label sccs'
where -- | Given a BlockId and the set of registers live in it,
-- if registers in this block are being spilled to stack slots,
import Reg
import BlockId
-import Cmm
+import OldCmm
import UniqSet
import UniqFM
import Unique
import qualified Data.Map as Map
import qualified Data.Set as Set
-
--
type Slot = Int
CmmData{}
-> return cmm
- CmmProc info label params sccs
+ CmmProc info label sccs
| LiveInfo _ _ _ liveSlotsOnEntry <- info
-> do sccs' <- mapM (mapSCCM (cleanBlockBackward liveSlotsOnEntry)) sccs
- return $ CmmProc info label params sccs'
+ return $ CmmProc info label sccs'
cleanBlockBackward
import GraphBase
import BlockId
-import Cmm
+import OldCmm
import UniqFM
import UniqSet
import Digraph (flattenSCCs)
= execState (countCmm cmm) zeroSpillCostInfo
where
countCmm CmmData{} = return ()
- countCmm (CmmProc info _ _ sccs)
+ countCmm (CmmProc info _ sccs)
= mapM_ (countBlock info)
$ flattenSCCs sccs
-- the info table from the CmmProc
countBlock info (BasicBlock blockId instrs)
| LiveInfo _ _ (Just blockLive) _ <- info
- , Just rsLiveEntry <- lookupBlockEnv blockLive blockId
+ , Just rsLiveEntry <- mapLookup blockId blockLive
, rsLiveEntry_virt <- takeVirtuals rsLiveEntry
= countLIs rsLiveEntry_virt instrs
import Reg
import TargetReg
-import Cmm
+import OldCmm
+import OldPprCmm()
import Outputable
import UniqFM
import UniqSet
import Reg
import BlockId
-import Cmm hiding (RegSet)
+import OldCmm hiding (RegSet)
import Digraph
import Outputable
import Unique
-- adjust the current assignment to remove any vregs that are not live
-- on entry to the destination block.
- let Just live_set = lookupBlockEnv block_live dest
+ let Just live_set = mapLookup dest block_live
let still_live uniq _ = uniq `elemUniqSet_Directly` live_set
let adjusted_assig = filterUFM_Directly still_live assig
, not (elemUniqSet_Directly reg live_set)
, r <- regsOfLoc loc ]
- case lookupBlockEnv block_assig dest of
+ case mapLookup dest block_assig of
Nothing
-> joinToTargets_first
block_live new_blocks block_id instr dest dests
let freeregs' = foldr releaseReg freeregs to_free
-- remember the current assignment on entry to this block.
- setBlockAssigR (extendBlockEnv block_assig dest
- (freeregs', src_assig))
+ setBlockAssigR (mapInsert dest (freeregs', src_assig) block_assig)
joinToTargets' block_live new_blocks block_id instr dests
-- A the end of the current block we will jump to the fixup one,
-- then that will jump to our original destination.
fixup_block_id <- getUniqueR
- let block = BasicBlock (BlockId fixup_block_id)
+ let block = BasicBlock (mkBlockId fixup_block_id)
$ fixUpInstrs ++ mkJumpInstr dest
{- pprTrace
-- fixup block instead.
_ -> let instr' = patchJumpInstr instr
(\bid -> if bid == dest
- then BlockId fixup_block_id
+ then mkBlockId fixup_block_id
else dest)
in joinToTargets' block_live (block : new_blocks) block_id instr' dests
import Reg
import BlockId
-import Cmm hiding (RegSet)
+import OldCmm hiding (RegSet)
import Digraph
import Unique
( CmmData sec d
, Nothing )
-regAlloc (CmmProc (LiveInfo info _ _ _) lbl params [])
- = return ( CmmProc info lbl params (ListGraph [])
+regAlloc (CmmProc (LiveInfo info _ _ _) lbl [])
+ = return ( CmmProc info lbl (ListGraph [])
, Nothing )
-regAlloc (CmmProc static lbl params sccs)
+regAlloc (CmmProc static lbl sccs)
| LiveInfo info (Just first_id) (Just block_live) _ <- static
= do
-- do register allocation on each component.
let ((first':_), rest')
= partition ((== first_id) . blockId) final_blocks
- return ( CmmProc info lbl params (ListGraph (first' : rest'))
+ return ( CmmProc info lbl (ListGraph (first' : rest'))
, Just stats)
-- bogus. to make non-exhaustive match warning go away.
-regAlloc (CmmProc _ _ _ _)
+regAlloc (CmmProc _ _ _)
= panic "RegAllocLinear.regAlloc: no match"
= do
block_assig <- getBlockAssigR
- if isJust (lookupBlockEnv block_assig id)
+ if isJust (mapLookup id block_assig)
|| id == first_id
then do
b' <- processBlock block_live b
initBlock :: BlockId -> RegM ()
initBlock id
= do block_assig <- getBlockAssigR
- case lookupBlockEnv block_assig id of
+ case mapLookup id block_assig of
-- no prior info about this block: assume everything is
-- free and the assignment is empty.
Nothing
import RegAlloc.Liveness
import Instruction
-import Cmm (GenBasicBlock(..))
+import OldCmm (GenBasicBlock(..))
import UniqFM
import Outputable
import Instruction
import BlockId
-import Cmm hiding (RegSet)
-import PprCmm()
+import OldCmm hiding (RegSet)
+import OldPprCmm()
import Digraph
import Outputable
type BlockMap a = BlockEnv a
-emptyBlockMap :: BlockEnv a
-emptyBlockMap = emptyBlockEnv
-
-- | A top level thing which carries liveness information.
type LiveCmmTop instr
mapBlockTopM _ cmm@(CmmData{})
= return cmm
-mapBlockTopM f (CmmProc header label params sccs)
+mapBlockTopM f (CmmProc header label sccs)
= do sccs' <- mapM (mapSCCM f) sccs
- return $ CmmProc header label params sccs'
+ return $ CmmProc header label sccs'
mapSCCM :: Monad m => (a -> m b) -> SCC a -> m (SCC b)
mapSCCM f (AcyclicSCC x)
mapGenBlockTopM _ cmm@(CmmData{})
= return cmm
-mapGenBlockTopM f (CmmProc header label params (ListGraph blocks))
+mapGenBlockTopM f (CmmProc header label (ListGraph blocks))
= do blocks' <- mapM f blocks
- return $ CmmProc header label params (ListGraph blocks')
+ return $ CmmProc header label (ListGraph blocks')
-- | Slurp out the list of register conflicts and reg-reg moves from this top level thing.
= slurpCmm (emptyBag, emptyBag) live
where slurpCmm rs CmmData{} = rs
- slurpCmm rs (CmmProc info _ _ sccs)
+ slurpCmm rs (CmmProc info _ sccs)
= foldl' (slurpSCC info) rs sccs
slurpSCC info rs (AcyclicSCC b)
slurpBlock info rs (BasicBlock blockId instrs)
| LiveInfo _ _ (Just blockLive) _ <- info
- , Just rsLiveEntry <- lookupBlockEnv blockLive blockId
+ , Just rsLiveEntry <- mapLookup blockId blockLive
, (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs
= (consBag rsLiveEntry conflicts, moves)
-> GenCmmTop t t1 [SCC (LiveBasicBlock instr)]
-> Bag (Reg, Reg)
slurpCmm cs CmmData{} = cs
- slurpCmm cs (CmmProc _ _ _ sccs)
+ slurpCmm cs (CmmProc _ _ sccs)
= slurpComp cs (flattenSCCs sccs)
slurpComp :: Bag (Reg, Reg)
= stripCmm live
where stripCmm (CmmData sec ds) = CmmData sec ds
-
- stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label params sccs)
+ stripCmm (CmmProc (LiveInfo info (Just first_id) _ _) label sccs)
= let final_blocks = flattenSCCs sccs
-- make sure the block that was first in the input list
((first':_), rest')
= partition ((== first_id) . blockId) final_blocks
- in CmmProc info label params
+ in CmmProc info label
(ListGraph $ map stripLiveBlock $ first' : rest')
-- procs used for stg_split_markers don't contain any blocks, and have no first_id.
- stripCmm (CmmProc (LiveInfo info Nothing _ _) label params [])
- = CmmProc info label params (ListGraph [])
+ stripCmm (CmmProc (LiveInfo info Nothing _ _) label [])
+ = CmmProc info label (ListGraph [])
-- If the proc has blocks but we don't know what the first one was, then we're dead.
stripCmm proc
= pprPanic "RegAlloc.Liveness.stripLive: no first_id on proc" (ppr proc)
-
+
-- | Strip away liveness information from a basic block,
-- and make real spill instructions out of SPILL, RELOAD pseudos along the way.
where
patchCmm cmm@CmmData{} = cmm
- patchCmm (CmmProc info label params sccs)
+ patchCmm (CmmProc info label sccs)
| LiveInfo static id (Just blockMap) mLiveSlots <- info
= let
patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set
- blockMap' = mapBlockEnv patchRegSet blockMap
+ blockMap' = mapMap patchRegSet blockMap
info' = LiveInfo static id (Just blockMap') mLiveSlots
- in CmmProc info' label params $ map patchSCC sccs
+ in CmmProc info' label $ map patchSCC sccs
| otherwise
= panic "RegAlloc.Liveness.patchEraseLive: no blockMap"
natCmmTopToLive (CmmData i d)
= CmmData i d
-natCmmTopToLive (CmmProc info lbl params (ListGraph []))
- = CmmProc (LiveInfo info Nothing Nothing Map.empty)
- lbl params []
+natCmmTopToLive (CmmProc info lbl (ListGraph []))
+ = CmmProc (LiveInfo info Nothing Nothing Map.empty) lbl []
-natCmmTopToLive (CmmProc info lbl params (ListGraph blocks@(first : _)))
+natCmmTopToLive (CmmProc info lbl (ListGraph blocks@(first : _)))
= let first_id = blockId first
sccs = sccBlocks blocks
sccsLive = map (fmap (\(BasicBlock l instrs) ->
BasicBlock l (map (\i -> LiveInstr (Instr i) Nothing) instrs)))
$ sccs
- in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty)
- lbl params sccsLive
+ in CmmProc (LiveInfo info (Just first_id) Nothing Map.empty) lbl sccsLive
sccBlocks
regLiveness (CmmData i d)
= returnUs $ CmmData i d
-regLiveness (CmmProc info lbl params [])
+regLiveness (CmmProc info lbl [])
| LiveInfo static mFirst _ _ <- info
= returnUs $ CmmProc
- (LiveInfo static mFirst (Just emptyBlockEnv) Map.empty)
- lbl params []
+ (LiveInfo static mFirst (Just mapEmpty) Map.empty)
+ lbl []
-regLiveness (CmmProc info lbl params sccs)
+regLiveness (CmmProc info lbl sccs)
| LiveInfo static mFirst _ liveSlotsOnEntry <- info
= let (ann_sccs, block_live) = computeLiveness sccs
in returnUs $ CmmProc (LiveInfo static mFirst (Just block_live) liveSlotsOnEntry)
- lbl params ann_sccs
+ lbl ann_sccs
-- -----------------------------------------------------------------------------
reverseBlocksInTops top
= case top of
CmmData{} -> top
- CmmProc info lbl params sccs -> CmmProc info lbl params (reverse sccs)
+ CmmProc info lbl sccs -> CmmProc info lbl (reverse sccs)
-- | Computing liveness
-- BlockMaps for equality.
equalBlockMaps a b
= a' == b'
- where a' = map f $ blockEnvToList a
- b' = map f $ blockEnvToList b
+ where a' = map f $ mapToList a
+ b' = map f $ mapToList b
f (key,elt) = (key, uniqSetToList elt)
= let
(regsLiveOnEntry, instrs1)
= livenessBack emptyUniqSet blockmap [] (reverse instrs)
- blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry
+ blockmap' = mapInsert block_id regsLiveOnEntry blockmap
instrs2 = livenessForward regsLiveOnEntry instrs1
not_a_branch = null targets
targetLiveRegs target
- = case lookupBlockEnv blockmap target of
+ = case mapLookup target blockmap of
Just ra -> ra
Nothing -> emptyRegMap
-- Our intermediate code:
import BlockId
-import Cmm
+import OldCmm
import CLabel
-- The rest:
import StaticFlags ( opt_PIC )
import OrdList
import Outputable
+import Unique
import Control.Monad ( mapAndUnzipM )
import DynFlags
-> NatM [NatCmmTop Instr]
cmmTopCodeGen _
- (CmmProc info lab params (ListGraph blocks))
+ (CmmProc info lab (ListGraph blocks))
= do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
- let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
+ let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
let tops = proc : concat statics
return tops
-- | Convert a BlockId to some CmmStatic data
jumpTableEntry :: Maybe BlockId -> CmmStatic
jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
-jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
- where blockLabel = mkAsmTempLabel id
+jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
import NCGMonad
import Size
-import Cmm
+import OldCmm
import OrdList
import Size
import Reg
-import Cmm
+import OldCmm
+import OldPprCmm ()
import Outputable
import OrdList
import Size
import Reg
-import Cmm
+import OldCmm
import CLabel
import BasicTypes
import NCGMonad
import Size
-import Cmm
+import OldCmm
import OrdList
import Outputable
import Instruction
import Reg
import Size
-import Cmm
+import OldCmm
import Outputable
expandTop top@(CmmData{})
= top
-expandTop (CmmProc info lbl params (ListGraph blocks))
- = CmmProc info lbl params (ListGraph $ map expandBlock blocks)
+expandTop (CmmProc info lbl (ListGraph blocks))
+ = CmmProc info lbl (ListGraph $ map expandBlock blocks)
-- | Expand out synthetic instructions in this block
import Size
import Reg
-import Cmm
-import BlockId
+import OldCmm
+import Control.Monad (liftM)
import OrdList
import Outputable
return (Any II32 code__2)
condIntReg cond x y = do
- bid1@(BlockId _) <- getBlockIdNat
- bid2@(BlockId _) <- getBlockIdNat
+ bid1 <- liftM (\a -> seq a a) getBlockIdNat
+ bid2 <- liftM (\a -> seq a a) getBlockIdNat
CondCode _ cond cond_code <- condIntCode cond x y
let
code__2 dst
condFltReg :: Cond -> CmmExpr -> CmmExpr -> NatM Register
condFltReg cond x y = do
- bid1@(BlockId _) <- getBlockIdNat
- bid2@(BlockId _) <- getBlockIdNat
+ bid1 <- liftM (\a -> seq a a) getBlockIdNat
+ bid2 <- liftM (\a -> seq a a) getBlockIdNat
CondCode _ cond cond_code <- condFltCode cond x y
let
import NCGMonad
import Reg
-import Cmm
+import OldCmm
getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock)
getRegister :: CmmExpr -> NatM Register
import Size
import Reg
-import Cmm
+import OldCmm
import OrdList
import Outputable
import SPARC.Ppr ()
import Instruction
-import Cmm
+import OldCmm
import Outputable
where
-import Cmm
+import OldCmm
import CLabel
import BlockId
import Size
import BlockId
-import Cmm
+import OldCmm
import FastString
import FastBool
import Outputable
import Size
import PprBase
-import BlockId
-import Cmm
+import OldCmm
+import OldPprCmm()
import CLabel
-import Unique ( pprUnique )
+import Unique ( Uniquable(..), pprUnique )
import qualified Outputable
import Outputable (Outputable, panic)
import Pretty
pprSectionHeader section $$ vcat (map pprData dats)
-- special case for split markers:
-pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
+pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl
-pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) =
+pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) =
pprSectionHeader Text $$
(if null info then -- blocks guaranteed not null, so label needed
pprLabel lbl
pprBasicBlock :: NatBasicBlock Instr -> Doc
-pprBasicBlock (BasicBlock (BlockId id) instrs) =
- pprLabel (mkAsmTempLabel id) $$
+pprBasicBlock (BasicBlock blockid instrs) =
+ pprLabel (mkAsmTempLabel (getUnique blockid)) $$
vcat (map pprInstr instrs)
]
-pprInstr (BI cond b (BlockId id))
+pprInstr (BI cond b blockid)
= hcat [
ptext (sLit "\tb"), pprCond cond,
if b then pp_comma_a else empty,
char '\t',
- pprCLabel_asm (mkAsmTempLabel id)
+ pprCLabel_asm (mkAsmTempLabel (getUnique blockid))
]
-pprInstr (BF cond b (BlockId id))
+pprInstr (BF cond b blockid)
= hcat [
ptext (sLit "\tfb"), pprCond cond,
if b then pp_comma_a else empty,
char '\t',
- pprCLabel_asm (mkAsmTempLabel id)
+ pprCLabel_asm (mkAsmTempLabel (getUnique blockid))
]
pprInstr (JMP addr) = (<>) (ptext (sLit "\tjmp\t")) (pprAddr addr)
import RegClass
import Size
-import PprCmm ()
+-- import PprCmm ()
import Unique
import Outputable
import CLabel
import BlockId
-import Cmm
+import OldCmm
import Panic
+import Unique
shortcutStatic fn (CmmStaticLit (CmmLabel lab))
| Just uq <- maybeAsmTemp lab
- = CmmStaticLit (CmmLabel (shortBlockId fn (BlockId uq)))
+ = CmmStaticLit (CmmLabel (shortBlockId fn (mkBlockId uq)))
shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
| Just uq <- maybeAsmTemp lbl1
- = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (BlockId uq)) lbl2 off)
+ = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn (mkBlockId uq)) lbl2 off)
-- slightly dodgy, we're ignoring the second label, but this
-- works with the way we use CmmLabelDiffOff for jump tables now.
shortBlockId :: (BlockId -> Maybe JumpDest) -> BlockId -> CLabel
-shortBlockId fn blockid@(BlockId uq) =
+shortBlockId fn blockid =
case fn blockid of
- Nothing -> mkAsmTempLabel uq
+ Nothing -> mkAsmTempLabel (getUnique blockid)
Just (DestBlockId blockid') -> shortBlockId fn blockid'
Just (DestImm (ImmCLbl lbl)) -> lbl
_other -> panic "shortBlockId"
where
-import Cmm
+import OldCmm
import Outputable
-- It looks very like the old MachRep, but it's now of purely local
import RegClass
import Size
-import CmmExpr (wordWidth)
+import CmmType (wordWidth)
import Outputable
import Unique
import FastTypes
import BasicTypes
import BlockId
import PprCmm ( pprExpr )
-import Cmm
+import OldCmm
+import OldPprCmm
import CLabel
import ClosureInfo ( C_SRT(..) )
import Pretty
import qualified Outputable as O
import Outputable
+import Unique
import FastString
import FastBool ( isFastTrue )
import Constants ( wORD_SIZE )
-> RawCmmTop
-> NatM [NatCmmTop Instr]
-cmmTopCodeGen dynflags
- (CmmProc info lab params (ListGraph blocks)) = do
+cmmTopCodeGen dynflags (CmmProc info lab (ListGraph blocks)) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
- let proc = CmmProc info lab params (ListGraph $ concat nat_blocks)
+ let proc = CmmProc info lab (ListGraph $ concat nat_blocks)
tops = proc : concat statics
os = platformOS $ targetPlatform dynflags
-- | Convert a BlockId to some CmmStatic data
jumpTableEntry :: Maybe BlockId -> CmmStatic
jumpTableEntry Nothing = CmmStaticLit (CmmInt 0 wordWidth)
-jumpTableEntry (Just (BlockId id)) = CmmStaticLit (CmmLabel blockLabel)
- where blockLabel = mkAsmTempLabel id
+jumpTableEntry (Just blockid) = CmmStaticLit (CmmLabel blockLabel)
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
-- -----------------------------------------------------------------------------
jumpTableEntryRel Nothing
= CmmStaticLit (CmmInt 0 wordWidth)
- jumpTableEntryRel (Just (BlockId id))
+ jumpTableEntryRel (Just blockid)
= CmmStaticLit (CmmLabelDiffOff blockLabel lbl 0)
- where blockLabel = mkAsmTempLabel id
+ where blockLabel = mkAsmTempLabel (getUnique blockid)
op = OpAddr (AddrBaseIndex (EABaseReg tableReg)
(EAIndex reg wORD_SIZE) (ImmInt 0))
import TargetReg
import BlockId
-import Cmm
+import OldCmm
import FastString
import FastBool
import Outputable
-- This helper shortcuts a sequence of branches.
-- The blockset helps avoid following cycles.
shortcutJump :: (BlockId -> Maybe JumpDest) -> Instr -> Instr
-shortcutJump fn insn = shortcutJump' fn emptyBlockSet insn
+shortcutJump fn insn = shortcutJump' fn (setEmpty :: BlockSet) insn
where shortcutJump' fn seen insn@(JXX cc id) =
- if elemBlockSet id seen then insn
+ if setMember id seen then insn
else case fn id of
Nothing -> insn
Just (DestBlockId id') -> shortcutJump' fn seen' (JXX cc id')
Just (DestImm imm) -> shortcutJump' fn seen' (JXX_GBL cc imm)
- where seen' = extendBlockSet seen id
+ where seen' = setInsert id seen
shortcutJump' _ _ other = other
-- Here because it knows about JumpDest
shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic
shortcutStatic fn (CmmStaticLit (CmmLabel lab))
| Just uq <- maybeAsmTemp lab
- = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (BlockId uq)))
+ = CmmStaticLit (CmmLabel (shortBlockId fn emptyUniqSet (mkBlockId uq)))
shortcutStatic fn (CmmStaticLit (CmmLabelDiffOff lbl1 lbl2 off))
| Just uq <- maybeAsmTemp lbl1
- = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (BlockId uq)) lbl2 off)
+ = CmmStaticLit (CmmLabelDiffOff (shortBlockId fn emptyUniqSet (mkBlockId uq)) lbl2 off)
-- slightly dodgy, we're ignoring the second label, but this
-- works with the way we use CmmLabelDiffOff for jump tables now.
-> BlockId
-> CLabel
-shortBlockId fn seen blockid@(BlockId uq) =
+shortBlockId fn seen blockid =
case (elementOfUniqSet uq seen, fn blockid) of
(True, _) -> mkAsmTempLabel uq
(_, Nothing) -> mkAsmTempLabel uq
(_, Just (DestBlockId blockid')) -> shortBlockId fn (addOneToUniqSet seen uq) blockid'
(_, Just (DestImm (ImmCLbl lbl))) -> lbl
(_, _other) -> panic "shortBlockId"
+ where uq = getUnique blockid
import PprBase
-import BlockId
-import Cmm
+import OldCmm
import CLabel
import Config
-import Unique ( pprUnique )
+import Unique ( pprUnique, Uniquable(..) )
import Pretty
import FastString
import qualified Outputable
pprSectionHeader section $$ vcat (map pprData dats)
-- special case for split markers:
-pprNatCmmTop (CmmProc [] lbl _ (ListGraph [])) = pprLabel lbl
+pprNatCmmTop (CmmProc [] lbl (ListGraph [])) = pprLabel lbl
-pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) =
+pprNatCmmTop (CmmProc info lbl (ListGraph blocks)) =
pprSectionHeader Text $$
(if null info then -- blocks guaranteed not null, so label needed
pprLabel lbl
pprBasicBlock :: NatBasicBlock Instr -> Doc
-pprBasicBlock (BasicBlock (BlockId id) instrs) =
- pprLabel (mkAsmTempLabel id) $$
+pprBasicBlock (BasicBlock blockid instrs) =
+ pprLabel (mkAsmTempLabel (getUnique blockid)) $$
vcat (map pprInstr instrs)
pprInstr (SETCC cond op) = pprCondInstr (sLit "set") cond (pprOperand II8 op)
-pprInstr (JXX cond (BlockId id))
+pprInstr (JXX cond blockid)
= pprCondInstr (sLit "j") cond (pprCLabel_asm lab)
- where lab = mkAsmTempLabel id
+ where lab = mkAsmTempLabel (getUnique blockid)
pprInstr (JXX_GBL cond imm) = pprCondInstr (sLit "j") cond (pprImm imm)
import RegClass
import BlockId
-import Cmm
+import OldCmm
import CLabel ( CLabel )
import Pretty
import Outputable ( panic )
#
# We assume that the stage0 compiler has a suitable bytestring package,
# so we don't have to include it below.
-STAGE0_PACKAGES = Cabal hpc extensible-exceptions binary bin-package-db
+STAGE0_PACKAGES = Cabal hpc extensible-exceptions binary bin-package-db hoopl
# These packages are installed, but are installed hidden
# Why install them at all? Because the 'ghc' package depends on them
$(eval $(call addPackage,Cabal))
$(eval $(call addPackage,binary))
$(eval $(call addPackage,bin-package-db))
+$(eval $(call addPackage,hoopl))
$(eval $(call addPackage,mtl))
$(eval $(call addPackage,utf8-string))
$(eval $(call addPackage,xhtml))
$(eval $(call build-package,libraries/Cabal,dist-boot,0))
$(eval $(call build-package,libraries/binary,dist-boot,0))
$(eval $(call build-package,libraries/bin-package-db,dist-boot,0))
+$(eval $(call build-package,libraries/hoopl,dist-boot,0))
# register the boot packages in strict sequence, because running
# multiple ghc-pkgs in parallel doesn't work (registrations may get
libraries/binary_dist-boot_EXTRA_HC_OPTS += -fno-warn-unused-imports
libraries/binary_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports -fno-warn-identities
+# Temporarily turn off -Werror for some Hoopl modules that have
+# non-exhaustive pattern-match warnings
+libraries/hoopl/src/Compiler/Hoopl/Util_HC_OPTS += -Wwarn
+libraries/hoopl/src/Compiler/Hoopl/GraphUtil_HC_OPTS += -Wwarn
+libraries/hoopl/src/Compiler/Hoopl/MkGraph_HC_OPTS += -Wwarn
+libraries/hoopl/src/Compiler/Hoopl/XUtil_HC_OPTS += -Wwarn
+libraries/hoopl/src/Compiler/Hoopl/Pointed_HC_OPTS += -Wwarn
+libraries/hoopl/src/Compiler/Hoopl/Passes/Dominator_HC_OPTS += -Wwarn
+
# primitive has a warning about deprecated use of GHC.IOBase
libraries/primitive_dist-install_EXTRA_HC_OPTS += -Wwarn
libraries/haskeline - packages/haskeline darcs http://code.haskell.org/haskeline/
libraries/haskell98 - packages/haskell98 darcs -
libraries/haskell2010 - packages/haskell2010 darcs -
+libraries/hoopl - packages/hoopl darcs -
libraries/hpc - packages/hpc darcs -
libraries/integer-gmp - packages/integer-gmp darcs -
libraries/integer-simple - packages/integer-simple darcs -
import Distribution.Simple.LocalBuildInfo
import Distribution.Simple.Program
import Distribution.Simple.Program.HcPkg
-import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic)
+import Distribution.Simple.Utils (defaultPackageDesc, writeFileAtomic, toUTF8)
import Distribution.Simple.Build (writeAutogenFiles)
import Distribution.Simple.Register
import Distribution.Text
Installed.haddockHTMLs = ["../" ++ display (packageId pd)]
}
content = Installed.showInstalledPackageInfo final_ipi ++ "\n"
- writeFileAtomic (distdir </> "inplace-pkg-config") content
+ writeFileAtomic (distdir </> "inplace-pkg-config") (toUTF8 content)
_ -> error "Inconsistent lib components; can't happen?"
let
projects / ghc-hetmet.git / commitdiff