X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fcmm%2FCmm.hs;h=a6b215b38febae7e5d24bb386a8b2a4fdfc83d1a;hp=3fd5e441a65e9a54764a2a0829376430b24f67b5;hb=d0faaa6fa0cecd23c5670fd199e9206275313666;hpb=d76b6a05ab36066e8aeb67d58e25992d1ef83a8a diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 3fd5e44..a6b215b 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -1,362 +1,181 @@ ------------------------------------------------------------------------------ --- --- 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(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, - GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, - CmmReturnInfo(..), - CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, CmmKind, - CmmFormalsWithoutKinds, CmmFormalWithoutKind, - CmmHinted(..), - CmmSafety(..), - CmmCallTarget(..), - CmmStatic(..), Section(..), - module CmmExpr, - - BlockId(..), mkBlockId, - BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv, - BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, - ) where +-- Cmm representations using Hoopl's Graph CmmNode e x. +{-# LANGUAGE GADTs #-} +{-# OPTIONS_GHC -fno-warn-warnings-deprecations #-} + +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} +#if __GLASGOW_HASKELL__ >= 701 +-- GHC 7.0.1 improved incomplete pattern warnings with GADTs +{-# OPTIONS_GHC -fwarn-incomplete-patterns #-} +#endif + +module Cmm + ( CmmGraph, GenCmmGraph(..), CmmBlock + , CmmStackInfo(..), CmmTopInfo(..), Cmm, CmmTop + , CmmReplGraph, GenCmmReplGraph, CmmFwdRewrite, CmmBwdRewrite + + , modifyGraph + , lastNode, replaceLastNode, insertBetween + , ofBlockMap, toBlockMap, insertBlock + , ofBlockList, toBlockList, bodyToBlockList + , foldGraphBlocks, mapGraphNodes, postorderDfs + + , analFwd, analBwd, analRewFwd, analRewBwd + , dataflowPassFwd, dataflowPassBwd + , module CmmNode + ) +where + +import BlockId +import CmmDecl +import CmmNode +import OptimizationFuel as F +import SMRep +import UniqSupply -#include "HsVersions.h" +import Compiler.Hoopl +import Control.Monad +import Data.Maybe +import Panic -import CmmExpr -import MachOp -import CLabel -import ForeignCall -import SMRep -import ClosureInfo -import Outputable -import FastString - -import Data.Word - -import ZipCfg ( BlockId(..), mkBlockId - , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv - , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet - ) - --- A [[BlockId]] is a local label. --- Local labels must be unique within an entire compilation unit, not --- just a single top-level item, because local labels map one-to-one --- with assembly-language labels. - ------------------------------------------------------------------------------ --- Cmm, CmmTop, CmmBasicBlock ------------------------------------------------------------------------------ - --- 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 - CmmFormalsWithoutKinds -- 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 - (Maybe UpdateFrame) -- Update frame - CmmInfoTable -- Info table - --- Info table as a haskell data type -data CmmInfoTable - = CmmInfoTable - ProfilingInfo - ClosureTypeTag -- Int - ClosureTypeInfo - | CmmNonInfoTable -- Procedure doesn't need an info table - --- 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 FunType FunArity ArgDescr SlowEntry - | ThunkInfo ClosureLayout C_SRT - | ThunkSelectorInfo SelectorOffset C_SRT - | ContInfo - [Maybe LocalReg] -- Forced stack parameters - C_SRT - -data CmmReturnInfo = CmmMayReturn - | CmmNeverReturns - --- 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 FunType = StgHalfWord -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 - = CmmNop - | CmmComment FastString - - | CmmAssign CmmReg CmmExpr -- Assign to register - - | CmmStore CmmExpr CmmExpr -- Assign to memory location. Size is - -- given by cmmExprRep of the rhs. - - | CmmCall -- A call (forign, native or primitive), with - CmmCallTarget - CmmFormals -- zero or more results - CmmActuals -- 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, - CmmActuals -- with these parameters. - - | CmmReturn -- Return from a native C-- function, - CmmActuals -- with these return values. - -type CmmKind = MachHint -data CmmHinted a = CmmHinted { hintlessCmm :: a, cmmHint :: CmmKind } - deriving (Eq) -type CmmActual = CmmHinted CmmExpr -type CmmFormal = CmmHinted LocalReg -type CmmActuals = [CmmActual] -type CmmFormals = [CmmFormal] -type CmmFormalWithoutKind = LocalReg -type CmmFormalsWithoutKinds = [CmmFormalWithoutKind] - -data CmmSafety = CmmUnsafe | CmmSafe C_SRT - --- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals' -instance UserOfLocalRegs a => UserOfLocalRegs (CmmHinted a) where - foldRegsUsed f set (CmmHinted a _) = foldRegsUsed f set a - -instance UserOfLocalRegs CmmStmt where - foldRegsUsed f set s = stmt s set - where stmt (CmmNop) = id - stmt (CmmComment {}) = id - stmt (CmmAssign _ e) = gen e - stmt (CmmStore e1 e2) = gen e1 . gen e2 - stmt (CmmCall target _ es _ _) = gen target . gen es - stmt (CmmBranch _) = id - stmt (CmmCondBranch e _) = gen e - stmt (CmmSwitch e _) = gen e - stmt (CmmJump e es) = gen e . gen es - stmt (CmmReturn es) = gen es - gen a set = foldRegsUsed f set a - -instance UserOfLocalRegs CmmCallTarget where - foldRegsUsed f set (CmmCallee e _) = foldRegsUsed f set e - foldRegsUsed _ set (CmmPrim {}) = set - ---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) - -{- -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. - ------------------------------------------------------------------------------ --- 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. +#include "HsVersions.h" +------------------------------------------------- +-- CmmBlock, CmmGraph and Cmm + +type CmmGraph = GenCmmGraph CmmNode +data GenCmmGraph n = CmmGraph { g_entry :: BlockId, g_graph :: Graph n C C } +type CmmBlock = Block CmmNode C C + +type CmmReplGraph e x = GenCmmReplGraph CmmNode e x +type GenCmmReplGraph n e x = FuelUniqSM (Maybe (Graph n 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 + +modifyGraph :: (Graph n C C -> Graph n' C C) -> GenCmmGraph n -> GenCmmGraph n' +modifyGraph f g = CmmGraph {g_entry=g_entry g, g_graph=f (g_graph g)} + +toBlockMap :: CmmGraph -> LabelMap CmmBlock +toBlockMap (CmmGraph {g_graph=GMany NothingO body NothingO}) = body + +ofBlockMap :: BlockId -> LabelMap CmmBlock -> CmmGraph +ofBlockMap entry bodyMap = CmmGraph {g_entry=entry, g_graph=GMany NothingO bodyMap NothingO} + +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" + + 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 n f -> FwdPass m n f +analBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdPass m n 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 n f -> FwdRewrite m n f -> FwdPass m n f +analRewBwd :: Monad m => DataflowLattice f -> BwdTransfer n f -> BwdRewrite m n f -> BwdPass m n 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 :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> FwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, 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 :: NonLocal n => GenCmmGraph n -> [(BlockId, f)] -> BwdPass FuelUniqSM n f -> FuelUniqSM (GenCmmGraph n, 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)