diff options
| author | Simon Marlow <marlowsd@gmail.com> | 2011-01-24 12:16:50 +0000 |
|---|---|---|
| committer | Simon Marlow <marlowsd@gmail.com> | 2011-01-24 12:16:50 +0000 |
| commit | 889c084e943779e76d19f2ef5e970ff655f511eb (patch) | |
| tree | 56bba8db5c08c72dc1a85ecb2987e6c16c0fd635 | |
| parent | f1a90f54590e5a7a32a9c3ef2950740922b1f425 (diff) | |
| download | haskell-889c084e943779e76d19f2ef5e970ff655f511eb.tar.gz | |
Merge in new code generator branch.
This changes the new code generator to make use of the Hoopl package
for dataflow analysis. Hoopl is a new boot package, and is maintained
in a separate upstream git repository (as usual, GHC has its own
lagging darcs mirror in http://darcs.haskell.org/packages/hoopl).
During this merge I squashed recent history into one patch. I tried
to rebase, but the history had some internal conflicts of its own
which made rebase extremely confusing, so I gave up. The history I
squashed was:
- Update new codegen to work with latest Hoopl
- Add some notes on new code gen to cmm-notes
- Enable Hoopl lag package.
- Add SPJ note to cmm-notes
- Improve GC calls on new code generator.
Work in this branch was done by:
- Milan Straka <fox@ucw.cz>
- John Dias <dias@cs.tufts.edu>
- David Terei <davidterei@gmail.com>
Edward Z. Yang <ezyang@mit.edu> merged in further changes from GHC HEAD
and fixed a few bugs.
141 files changed, 5735 insertions, 10239 deletions
diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs index 01ddcd2b95..c28201c92b 100644 --- a/compiler/cmm/BlockId.hs +++ b/compiler/cmm/BlockId.hs @@ -1,23 +1,21 @@ +{- 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 @@ -31,129 +29,40 @@ most assembly languages allow, a label is visible throughout the entire 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 diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 4ea7f00b6a..076922e3fb 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -1,422 +1,171 @@ ------------------------------------------------------------------------------ --- --- 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) diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs deleted file mode 100644 index 17b81783d6..0000000000 --- a/compiler/cmm/CmmBrokenBlock.hs +++ /dev/null @@ -1,421 +0,0 @@ - -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 diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs index 4e3879f6be..3d0d6fb426 100644 --- a/compiler/cmm/CmmBuildInfoTables.hs +++ b/compiler/cmm/CmmBuildInfoTables.hs @@ -1,15 +1,17 @@ -{-# 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" @@ -17,39 +19,34 @@ where 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 @@ -155,21 +152,17 @@ live_ptrs oldByte slotEnv areaMap bid = -- 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 @@ -193,17 +186,15 @@ type CAFEnv = BlockEnv CAFSet -- 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 @@ -211,11 +202,8 @@ cafTransfers = BackwardTransfers first middle last _ -> 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 @@ -249,7 +237,7 @@ addCAF caf srt = , 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)) @@ -262,7 +250,7 @@ srtToData srt = Cmm [CmmData RelocatableReadOnlyData (CmmDataLabel (lbl srt) : t -- 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 @@ -305,7 +293,7 @@ buildSRTs topSRT topCAFMap 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 = @@ -323,7 +311,7 @@ maxBmpSize :: Int 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 @@ -344,13 +332,13 @@ to_SRT top_srt off len bmp -- 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 @@ -383,109 +371,43 @@ mkTopCAFInfo localCAFs = foldl addToTop Map.empty g 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? @@ -502,96 +424,72 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g = -- 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" diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index 7bfdf8437e..372562cfca 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -1,412 +1,168 @@ +{-# 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) diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs deleted file mode 100644 index 45d0aebe3c..0000000000 --- a/compiler/cmm/CmmCPSGen.hs +++ /dev/null @@ -1,517 +0,0 @@ -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)) diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs deleted file mode 100644 index 23e57d72b6..0000000000 --- a/compiler/cmm/CmmCPSZ.hs +++ /dev/null @@ -1,183 +0,0 @@ -{-# 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) diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 3fb347f7d2..24adb99df7 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -8,9 +8,10 @@ module CmmCallConv ( #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 diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElim.hs index 90e70080f2..c0761fce6a 100644 --- a/compiler/cmm/CmmCommonBlockElimZ.hs +++ b/compiler/cmm/CmmCommonBlockElim.hs @@ -1,15 +1,20 @@ -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 @@ -38,8 +43,8 @@ my_trace = if False then pprTrace else \_ _ a -> a 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 @@ -57,26 +62,28 @@ common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, 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)) @@ -87,24 +94,36 @@ upd_graph g subst = map_nodes id middle last g -- 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 @@ -113,16 +132,12 @@ hash_block (Block _ t) = 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. @@ -130,33 +145,28 @@ hash_block (Block _ t) = 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' diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 64a23155cc..42fc239e28 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -1,88 +1,84 @@ +{-# 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' @@ -94,131 +90,129 @@ branchChainElimZ :: Tx CmmGraph -- 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 diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 4d413257be..9382d8d1ed 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -1,4 +1,6 @@ -{-# LANGUAGE PatternGuards #-} +{-# LANGUAGE GADTs #-} +-- ToDo: remove +{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-} module CmmCvt ( cmmToZgraph, cmmOfZgraph ) @@ -6,179 +8,170 @@ where 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 diff --git a/compiler/cmm/CmmDecl.hs b/compiler/cmm/CmmDecl.hs new file mode 100644 index 0000000000..e2da59beac --- /dev/null +++ b/compiler/cmm/CmmDecl.hs @@ -0,0 +1,150 @@ +----------------------------------------------------------------------------- +-- +-- 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. + diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 8a5bab1f6c..3ae2996213 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,18 +1,6 @@ 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 @@ -24,37 +12,20 @@ module CmmExpr , 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) ----------------------------------------------------------------------------- @@ -319,6 +290,12 @@ instance UserOfSlots a => UserOfSlots [a] where 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 @@ -464,695 +441,3 @@ globalRegType (LongReg _) = cmmBits W64 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. - --} - diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 2549453288..a606da2aec 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -2,12 +2,11 @@ module CmmInfo ( emptyContInfoTable, cmmToRawCmm, mkInfoTable, - mkBareInfoTable ) where #include "HsVersions.h" -import Cmm +import OldCmm import CmmUtils import CLabel @@ -18,7 +17,6 @@ import CgInfoTbls import CgCallConv import CgUtils import SMRep -import ZipCfgCmmRep import Constants import Panic @@ -29,10 +27,9 @@ import UniqSupply 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] @@ -78,10 +75,10 @@ cmmToRawCmm cmm = do 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 @@ -91,7 +88,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = -- 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 = @@ -110,7 +107,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = -- 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 @@ -118,7 +115,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = -- 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 @@ -127,7 +124,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = -- 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) @@ -135,7 +132,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = 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) @@ -146,30 +143,18 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = 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 @@ -178,7 +163,7 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks | 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 diff --git a/compiler/cmm/CmmLex.x b/compiler/cmm/CmmLex.x index 50e9aea9e8..0a1929056a 100644 --- a/compiler/cmm/CmmLex.x +++ b/compiler/cmm/CmmLex.x @@ -23,7 +23,7 @@ module CmmLex ( CmmToken(..), cmmlex, ) where -import Cmm +import OldCmm import Lexer import SrcLoc diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 2fc4a74daf..95b1eef6a3 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -17,10 +17,10 @@ module CmmLint ( ) where import BlockId -import Cmm +import OldCmm import CLabel import Outputable -import PprCmm +import OldPprCmm() import Constants import FastString @@ -48,9 +48,9 @@ runCmmLint l p = 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 {}) @@ -142,7 +142,7 @@ lintCmmStmt labels = lint 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 () @@ -180,14 +180,14 @@ addLintInfo info thing = 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])) @@ -196,4 +196,4 @@ cmmLintAssignErr stmt e_ty r_ty cmmLintDubiousWordOffset :: CmmExpr -> CmmLint a cmmLintDubiousWordOffset expr = cmmLintErr (text "offset is not a multiple of words: " $$ - nest 2 (pprExpr expr)) + nest 2 (ppr expr)) diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index ed659776a8..78867b0ce3 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -1,18 +1,24 @@ -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 ----------------------------------------------------------------------------- @@ -20,193 +26,50 @@ 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 diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs deleted file mode 100644 index ea9b2e5079..0000000000 --- a/compiler/cmm/CmmLiveZ.hs +++ /dev/null @@ -1,84 +0,0 @@ - -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) diff --git a/compiler/cmm/CmmMachOp.hs b/compiler/cmm/CmmMachOp.hs new file mode 100644 index 0000000000..5e1ac16f78 --- /dev/null +++ b/compiler/cmm/CmmMachOp.hs @@ -0,0 +1,465 @@ + +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) diff --git a/compiler/cmm/CmmNode.hs b/compiler/cmm/CmmNode.hs new file mode 100644 index 0000000000..12d534ea53 --- /dev/null +++ b/compiler/cmm/CmmNode.hs @@ -0,0 +1,303 @@ +-- 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 diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index fa25e24c7b..53281b0312 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -21,8 +21,7 @@ module CmmOpt ( #include "HsVersions.h" -import Cmm -import CmmExpr +import OldCmm import CmmUtils import CLabel import StaticFlags @@ -532,12 +531,12 @@ exactLog2 x_ -} 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 ] diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 51f29a85e7..8c2498e5f8 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -37,8 +37,8 @@ import CgClosure import CostCentre import BlockId -import Cmm -import PprCmm +import OldCmm +import OldPprCmm() import CmmUtils import CmmLex import CLabel diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index de8cfa378b..d0d54d909d 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -1,119 +1,560 @@ -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. +-} diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs deleted file mode 100644 index c972ad59ab..0000000000 --- a/compiler/cmm/CmmProcPointZ.hs +++ /dev/null @@ -1,554 +0,0 @@ -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. --} diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index c457383e6b..0c0099434d 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -1,4 +1,4 @@ -{-# 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 @@ -16,23 +16,19 @@ module CmmSpillReload 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] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -69,117 +65,122 @@ changeRegs f live = live { in_regs = f (in_regs live) } 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 @@ -195,12 +196,12 @@ data AvailRegs = UniverseMinus RegSet 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 @@ -227,68 +228,58 @@ elemAvail :: AvailRegs -> LocalReg -> Bool 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 --------------------- diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs index df1b89c9ba..4756bbd152 100644 --- a/compiler/cmm/CmmStackLayout.hs +++ b/compiler/cmm/CmmStackLayout.hs @@ -1,7 +1,10 @@ -{-# 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 @@ -9,23 +12,20 @@ module CmmStackLayout 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 @@ -64,24 +64,23 @@ import qualified FiniteMap 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. @@ -120,10 +119,21 @@ liveKill (a, hi, w) set = -- pprTrace "killing slots in area" (ppr a) $ -- 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 @@ -141,7 +151,7 @@ removeLiveSlotDefs = foldSlotsDefd removeSlot 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, @@ -151,17 +161,17 @@ liveLastIn l env = liveInSlots l (liveLastOut env l) -- 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 @@ -187,7 +197,7 @@ areaBuilder = Builder fold words 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) @@ -198,48 +208,49 @@ areaBuilder = Builder fold words -- 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 @@ -308,19 +319,15 @@ allocSlotFrom ig areaSize from areaMap area = -- 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 @@ -338,10 +345,10 @@ layout procPoints env entry_off g = -- 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 @@ -352,28 +359,19 @@ layout procPoints env entry_off g = (_, 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) $ @@ -389,9 +387,9 @@ layout procPoints env entry_off g = -- 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) @@ -399,68 +397,64 @@ manifestSP areaMap entry_off g@(LGraph entry _blocks) = 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) @@ -470,19 +464,17 @@ maxSlot slotOff g = fold_blocks (fold_fwd_block (\ _ x -> x) highSlot highSlot) -- 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) diff --git a/compiler/cmm/CmmTx.hs b/compiler/cmm/CmmTx.hs deleted file mode 100644 index af9b7f1adf..0000000000 --- a/compiler/cmm/CmmTx.hs +++ /dev/null @@ -1,58 +0,0 @@ -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' diff --git a/compiler/cmm/CmmType.hs b/compiler/cmm/CmmType.hs new file mode 100644 index 0000000000..6988ae6905 --- /dev/null +++ b/compiler/cmm/CmmType.hs @@ -0,0 +1,318 @@ + +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. + +-} + diff --git a/compiler/cmm/CmmUtils.hs b/compiler/cmm/CmmUtils.hs index 69320a2f66..35f2471361 100644 --- a/compiler/cmm/CmmUtils.hs +++ b/compiler/cmm/CmmUtils.hs @@ -6,10 +6,7 @@ -- ----------------------------------------------------------------------------- -module CmmUtils( - CmmStmts, noStmts, oneStmt, mkStmts, plusStmts, stmtList, - isNopStmt, - +module CmmUtils( primRepCmmType, primRepForeignHint, typeCmmType, typeForeignHint, @@ -21,8 +18,6 @@ module CmmUtils( mkIntCLit, zeroCLit, mkLblExpr, - - maybeAssignTemp, loadArgsIntoTemps ) where #include "HsVersions.h" @@ -31,10 +26,9 @@ import TyCon ( PrimRep(..) ) import Type ( Type, typePrimRep ) import CLabel -import Cmm -import OrdList +import CmmDecl +import CmmExpr import Outputable -import Unique --------------------------------------------------- -- @@ -73,55 +67,6 @@ typeForeignHint = primRepForeignHint . typePrimRep --------------------------------------------------- -- --- 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 -- --------------------------------------------------- @@ -225,29 +170,3 @@ zeroCLit = CmmInt 0 wordWidth 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)) diff --git a/compiler/cmm/CmmZipUtil.hs b/compiler/cmm/CmmZipUtil.hs deleted file mode 100644 index a91d76f31d..0000000000 --- a/compiler/cmm/CmmZipUtil.hs +++ /dev/null @@ -1,39 +0,0 @@ - -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) - - - diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs deleted file mode 100644 index 4c254e68aa..0000000000 --- a/compiler/cmm/DFMonad.hs +++ /dev/null @@ -1,223 +0,0 @@ -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) diff --git a/compiler/cmm/Dataflow.hs b/compiler/cmm/Dataflow.hs deleted file mode 100644 index fc1b5769f6..0000000000 --- a/compiler/cmm/Dataflow.hs +++ /dev/null @@ -1,55 +0,0 @@ -{-# 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) diff --git a/compiler/cmm/MkGraph.hs b/compiler/cmm/MkGraph.hs new file mode 100644 index 0000000000..69b481b501 --- /dev/null +++ b/compiler/cmm/MkGraph.hs @@ -0,0 +1,409 @@ +{-# 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) diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs deleted file mode 100644 index fa93f7690a..0000000000 --- a/compiler/cmm/MkZipCfg.hs +++ /dev/null @@ -1,371 +0,0 @@ -{-# 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... --} - - diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs deleted file mode 100644 index 46f0659e1a..0000000000 --- a/compiler/cmm/MkZipCfgCmm.hs +++ /dev/null @@ -1,269 +0,0 @@ -{-# 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) diff --git a/compiler/cmm/OldCmm.hs b/compiler/cmm/OldCmm.hs new file mode 100644 index 0000000000..57d458cc95 --- /dev/null +++ b/compiler/cmm/OldCmm.hs @@ -0,0 +1,271 @@ +----------------------------------------------------------------------------- +-- +-- 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 diff --git a/compiler/cmm/OldCmmUtils.hs b/compiler/cmm/OldCmmUtils.hs new file mode 100644 index 0000000000..ea9ef8a54a --- /dev/null +++ b/compiler/cmm/OldCmmUtils.hs @@ -0,0 +1,98 @@ +----------------------------------------------------------------------------- +-- +-- 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)) diff --git a/compiler/cmm/OldPprCmm.hs b/compiler/cmm/OldPprCmm.hs new file mode 100644 index 0000000000..4b0db35bd8 --- /dev/null +++ b/compiler/cmm/OldPprCmm.hs @@ -0,0 +1,273 @@ +---------------------------------------------------------------------------- +-- +-- 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 diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index 175dcd09b1..e1f1e3c39e 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -1,3 +1,4 @@ +{-# 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 @@ -5,27 +6,25 @@ -- 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" @@ -45,45 +44,44 @@ initOptFuelState = 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' @@ -92,49 +90,51 @@ runFuelIO fs (FuelMonad f) = 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) + diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index a36a356d6d..10c9f18310 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -34,8 +34,8 @@ module PprC ( -- Cmm stuff import BlockId -import Cmm -import PprCmm () -- Instances only +import OldCmm +import OldPprCmm () -- Instances only import CLabel import ForeignCall import ClosureInfo @@ -99,7 +99,7 @@ pprC (Cmm tops) = vcat $ intersperse blankLine $ map pprTop tops -- 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 diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index f5c5a49b92..cede69e06f 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -5,9 +5,8 @@ -- (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. -- @@ -30,601 +29,234 @@ -- 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 diff --git a/compiler/cmm/PprCmmDecl.hs b/compiler/cmm/PprCmmDecl.hs new file mode 100644 index 0000000000..1f520bfc90 --- /dev/null +++ b/compiler/cmm/PprCmmDecl.hs @@ -0,0 +1,196 @@ +---------------------------------------------------------------------------- +-- +-- 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") diff --git a/compiler/cmm/PprCmmExpr.hs b/compiler/cmm/PprCmmExpr.hs new file mode 100644 index 0000000000..0614e8e0b0 --- /dev/null +++ b/compiler/cmm/PprCmmExpr.hs @@ -0,0 +1,275 @@ +---------------------------------------------------------------------------- +-- +-- 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 diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs deleted file mode 100644 index 075f0e457b..0000000000 --- a/compiler/cmm/PprCmmZ.hs +++ /dev/null @@ -1,88 +0,0 @@ - -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 diff --git a/compiler/cmm/README b/compiler/cmm/README deleted file mode 100644 index fd87e88748..0000000000 --- a/compiler/cmm/README +++ /dev/null @@ -1,94 +0,0 @@ -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 diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs deleted file mode 100644 index bf5f9a0fda..0000000000 --- a/compiler/cmm/StackColor.hs +++ /dev/null @@ -1,133 +0,0 @@ - -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 diff --git a/compiler/cmm/StackPlacements.hs b/compiler/cmm/StackPlacements.hs deleted file mode 100644 index 5cac288573..0000000000 --- a/compiler/cmm/StackPlacements.hs +++ /dev/null @@ -1,248 +0,0 @@ - -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 - diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs deleted file mode 100644 index 1001f23b77..0000000000 --- a/compiler/cmm/ZipCfg.hs +++ /dev/null @@ -1,705 +0,0 @@ -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 - diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs deleted file mode 100644 index 0f00641efd..0000000000 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ /dev/null @@ -1,563 +0,0 @@ -{-# 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 diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs deleted file mode 100644 index 0f8eeb0d2b..0000000000 --- a/compiler/cmm/ZipCfgExtras.hs +++ /dev/null @@ -1,76 +0,0 @@ -{-# 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 diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs deleted file mode 100644 index 4355775a29..0000000000 --- a/compiler/cmm/ZipDataflow.hs +++ /dev/null @@ -1,1064 +0,0 @@ -{-# 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) diff --git a/compiler/cmm/cmm-notes b/compiler/cmm/cmm-notes index 084590086c..0852711f96 100644 --- a/compiler/cmm/cmm-notes +++ b/compiler/cmm/cmm-notes @@ -1,35 +1,89 @@ -Notes on new codegen (Sept 09)
+Notes on new codegen (Aug 10)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Things to do:
+ - We insert spills for variables before the stack check! This is the reason for
+ some fishy code in StgCmmHeap.entryHeapCheck where we are doing some strange
+ things to fix up the stack pointer before GC calls/jumps.
- - SDM (2010-02-26) can we remove the Foreign constructor from Convention?
- Reason: we never generate code for a function with the Foreign
- calling convention, and the code for calling foreign calls is generated
+ The reason spills are inserted before the sp check is that at the entry to a
+ function we always store the parameters passed in registers to local variables.
+ The spill pass simply inserts spills at variable definitions. We instead should
+ sink the spills so that we can avoid spilling them on branches that never
+ reload them.
+
+ This will fix the spill before stack check problem but only really as a side
+ effect. A 'real fix' probably requires making the spiller know about sp checks.
+
+ - There is some silly stuff happening with the Sp. We end up with code like:
+ Sp = Sp + 8; R1 = _vwf::I64; Sp = Sp -8
+ Seems to be perhaps caused by the issue above but also maybe a optimisation
+ pass needed?
+
+ - Proc pass all arguments on the stack, adding more code and slowing down things
+ a lot. We either need to fix this or even better would be to get rid of
+ proc points.
+
+ - CmmInfo.cmmToRawCmm uses Old.Cmm, so it is called after converting Cmm.Cmm to
+ Old.Cmm. We should abstract it to work on both representations, it needs only to
+ convert a CmmInfoTable to [CmmStatic].
+
+ - The MkGraph currenty uses a different semantics for <*> than Hoopl. Maybe
+ we could convert codeGen/StgCmm* clients to the Hoopl's semantics?
+ It's all deeply unsatisfactory.
+
+ - Improve preformance of Hoopl.
+
+ A nofib comparison of -fasm vs -fnewcodegen nofib compilation parameters
+ (using the same ghc-cmm branch +libraries compiled by the old codegenerator)
+ is at http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.oldghchoopl.txt
+ - the code produced is 10.9% slower, the compilation is +118% slower!
- - All dataflow analyses are in the FuelMonad, even though they
- are guarnteed to consume no fuel. This seems silly
+ The same comparison with ghc-head with zip representation is at
+ http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.oldghczip.txt
+ - the code produced is 11.7% slower, the compilation is +78% slower.
- - CmmContFlowOpt.runCmmContFlowOptZs is not called!
- - Why is runCmmOpts called from HscMain? Seems too "high up".
- In fact HscMain calls (runCmmOpts cmmCfgOptsZ) which is what
- runCmmContFlowOptZs does. Tidy up!
+ When compiling nofib, ghc-cmm + libraries compiled with -fnew-codegen
+ is 23.7% slower (http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.hooplghcoldgen.txt).
+ When compiling nofib, ghc-head + libraries compiled with -fnew-codegen
+ is 31.4% slower (http://fox.auryn.cz/msrc/0517_hoopl/32bit.oldghcoldgen.zipghcoldgen.txt).
+ So we generate a bit better code, but it takes us longer!
+
+ - Are all blockToNodeList and blockOfNodeList really needed? Maybe we could
+ splice blocks instead?
+
+ In the CmmContFlowOpt.blockConcat, using Dataflow seems too clumsy. Still,
+ a block catenation function would be probably nicer than blockToNodeList
+ / blockOfNodeList combo.
+
+ - loweSafeForeignCall seems too lowlevel. Just use Dataflow. After that
+ delete splitEntrySeq from HooplUtils.
+
+ - manifestSP seems to touch a lot of the graph representation. It is
+ also slow for CmmSwitch nodes O(block_nodes * switch_statements).
+ Maybe rewrite manifestSP to use Dataflow?
+
+ - Sort out Label, LabelMap, LabelSet versus BlockId, BlockEnv, BlockSet
+ dichotomy. Mostly this means global replace, but we also need to make
+ Label an instance of Outputable (probably in the Outputable module).
+
+ - NB that CmmProcPoint line 283 has a hack that works around a GADT-related
+ bug in 6.10.
+
+ - SDM (2010-02-26) can we remove the Foreign constructor from Convention?
+ Reason: we never generate code for a function with the Foreign
+ calling convention, and the code for calling foreign calls is generated
- AsmCodeGen has a generic Cmm optimiser; move this into new pipeline
- - AsmCodeGen has post-native-cg branch elimiator (shortCutBranches);
+ - AsmCodeGen has post-native-cg branch eliminator (shortCutBranches);
we ultimately want to share this with the Cmm branch eliminator.
- At the moment, references to global registers like Hp are "lowered"
- late (in AsmCodeGen.fixAssignTop and cmmToCmm). We should do this
- early, in the new native codegen, much in the way that we lower
- calling conventions. Might need to be a bit sophisticated about
- aliasing.
-
- - Refactor Cmm so that it contains only shared stuff
- Add a module MoribundCmm which contains stuff from
- Cmm for old code gen path
+ late (in CgUtils.fixStgRegisters). We should do this early, in the
+ new native codegen, much in the way that we lower calling conventions.
+ Might need to be a bit sophisticated about aliasing.
- Question: currently we lift procpoints to become separate
CmmProcs. Do we still want to do this?
@@ -58,20 +112,6 @@ Things to do: - See "CAFs" below; we want to totally refactor the way SRTs are calculated
- - Change
- type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
- to
- type CmmZ = GenCmm CmmStatic (CmmInfo, CmmStackInfo) CmmGraph
- -- And perhaps take opportunity to prune CmmInfo?
-
- - Clarify which fields of CmmInfo are still used
- - Maybe get rid of CmmFormals arg of CmmProc in all versions?
-
- - We aren't sure whether cmmToRawCmm is actively used by the new pipeline; check
- And what does CmmBuildInfoTables do?!
-
- - Nuke CmmZipUtil, move zipPreds into ZipCfg
-
- Pull out Areas into its own module
Parameterise AreaMap
Add ByteWidth = Int
@@ -83,6 +123,9 @@ Things to do: -- rET_SMALL etc ==> CmmInfo
Check that there are no other imports from codeGen in cmm/
+ - If you eliminate a label by branch chain elimination,
+ what happens if there's an Area associated with that label?
+
- Think about a non-flattened representation?
- LastCall:
@@ -105,7 +148,7 @@ Things to do: http://hackage.haskell.org/trac/ghc/wiki/Commentary/Compiler/NewCodeGenPipeline
- - We believe that all of CmmProcPointZ.addProcPointProtocols is dead. What
+ - We believe that all of CmmProcPoint.addProcPointProtocols is dead. What
goes wrong if we simply never call it?
- Something fishy in CmmStackLayout.hs
@@ -150,75 +193,57 @@ Things to do: move the whole splitting game into the C back end *only*
(guided by the procpoint set)
-
----------------------------------------------------
Modules in cmm/
----------------------------------------------------
--------- Dead stuff ------------
-CmmProcPoint Dead: Michael Adams
-CmmCPS Dead: Michael Adams
-CmmCPSGen.hs Dead: Michael Adams
-CmmBrokenBlock.hs Dead: Michael Adams
-CmmLive.hs Dead: Michael Adams
-CmmProcPoint.hs Dead: Michael Adams
-Dataflow.hs Dead: Michael Adams
-StackColor.hs Norman?
-StackPlacements.hs Norman?
-
+-------- Testing stuff ------------
HscMain.optionallyConvertAndOrCPS
testCmmConversion
-DynFlags: -fconvert-to-zipper-and-back, -frun-cps, -frun-cpsz
+DynFlags: -fconvert-to-zipper-and-back, -frun-cpsz
-------- Moribund stuff ------------
+OldCmm.hs Definition of flowgraph of old representation
+OldCmmUtil.hs Utilites that operates mostly on on CmmStmt
+OldPprCmm.hs Pretty print for CmmStmt, GenBasicBlock and ListGraph
CmmCvt.hs Conversion between old and new Cmm reps
CmmOpt.hs Hopefully-redundant optimiser
-CmmZipUtil.hs Only one function; move elsewhere
-------- Stuff to keep ------------
-CmmCPSZ.hs Driver for new pipeline
+CmmCPS.hs Driver for new pipeline
-CmmLiveZ.hs Liveness analysis, dead code elim
-CmmProcPointZ.hs Identifying and splitting out proc-points
+CmmLive.hs Liveness analysis, dead code elim
+CmmProcPoint.hs Identifying and splitting out proc-points
CmmSpillReload.hs Save and restore across calls
-CmmCommonBlockElimZ.hs Common block elim
+CmmCommonBlockElim.hs Common block elim
CmmContFlowOpt.hs Other optimisations (branch-chain, merging)
CmmBuildInfoTables.hs New info-table
CmmStackLayout.hs and stack layout
CmmCallConv.hs
-CmmInfo.hs Defn of InfoTables, and conversion to exact layout
+CmmInfo.hs Defn of InfoTables, and conversion to exact byte layout
---------- Cmm data types --------------
-ZipCfgCmmRep.hs Cmm instantiations of dataflow graph framework
-MkZipCfgCmm.hs Cmm instantiations of dataflow graph framework
+Cmm.hs Cmm instantiations of dataflow graph framework
+MkGraph.hs Interface for building Cmm for codeGen/Stg*.hs modules
+
+CmmDecl.hs Shared Cmm types of both representations
+CmmExpr.hs Type of Cmm expression
+CmmType.hs Type of Cmm types and their widths
+CmmMachOp.hs MachOp type and accompanying utilities
-Cmm.hs Key module; a mix of old and new stuff
- so needs tidying up in due course
-CmmExpr.hs
CmmUtils.hs
CmmLint.hs
PprC.hs Pretty print Cmm in C syntax
-PprCmm.hs Pretty printer for Cmm
-PprCmmZ.hs Additional stuff for zipper rep
-
-CLabel.hs CLabel
-
----------- Dataflow modules --------------
- Goal: separate library; for now, separate directory
-
-MkZipCfg.hs
-ZipCfg.hs
-ZipCfgExtras.hs
-ZipDataflow.hs
-CmmTx.hs Transactions
-OptimizationFuel.hs Fuel
-BlockId.hs BlockId, BlockEnv, BlockSet
-DFMonad.hs
+PprCmm.hs Pretty printer for CmmGraph.
+PprCmmDecl.hs Pretty printer for common Cmm types.
+PprCmmExpr.hs Pretty printer for Cmm expressions.
+CLabel.hs CLabel
+BlockId.hs BlockId, BlockEnv, BlockSet
----------------------------------------------------
Top-level structure
@@ -234,7 +259,7 @@ DFMonad.hs * HscMain.tryNewCodeGen
- STG->Cmm: StgCmm.codeGen (new codegen)
- Optimise: CmmContFlowOpt (simple optimisations, very self contained)
- - Cps convert: CmmCPSZ.protoCmmCPSZ
+ - Cps convert: CmmCPS.protoCmmCPS
- Optimise: CmmContFlowOpt again
- Convert: CmmCvt.cmmOfZgraph (convert to old rep) very self contained
@@ -243,23 +268,23 @@ DFMonad.hs ----------------------------------------------------
- CmmCPSZ.protoCmmCPSZ The new pipeline
+ CmmCPS.protoCmmCPS The new pipeline
----------------------------------------------------
-CmmCPSZprotoCmmCPSZ:
+CmmCPS.protoCmmCPS:
1. Do cpsTop for each procedures separately
2. Build SRT representation; this spans multiple procedures
(unless split-objs)
cpsTop:
- * CmmCommonBlockElimZ.elimCommonBlocks:
+ * CmmCommonBlockElim.elimCommonBlocks:
eliminate common blocks
- * CmmProcPointZ.minimalProcPointSet
+ * CmmProcPoint.minimalProcPointSet
identify proc-points
no change to graph
- * CmmProcPointZ.addProcPointProtocols
+ * CmmProcPoint.addProcPointProtocols
something to do with the MA optimisation
probably entirely unnecessary
@@ -289,11 +314,11 @@ cpsTop: Manifest the stack pointer
* Split into separate procedures
- - CmmProcPointZ.procPointAnalysis
+ - CmmProcPoint.procPointAnalysis
Given set of proc points, which blocks are reachable from each
Claim: too few proc-points => code duplication, but program still works??
- - CmmProcPointZ.splitAtProcPoints
+ - CmmProcPoint.splitAtProcPoints
Using this info, split into separate procedures
- CmmBuildInfoTables.setInfoTableStackMap
@@ -334,7 +359,7 @@ of calls don't need an info table. Figuring out proc-points
~~~~~~~~~~~~~~~~~~~~~~~~
Proc-points are identified by
-CmmProcPointZ.minimalProcPointSet/extendPPSet Although there isn't
+CmmProcPoint.minimalProcPointSet/extendPPSet Although there isn't
that much code, JD thinks that it could be done much more nicely using
a dominator analysis, using the Dataflow Engine.
@@ -387,7 +412,7 @@ a dominator analysis, using the Dataflow Engine. f's keep-alive refs to include h1.
* The SRT info is the C_SRT field of Cmm.ClosureTypeInfo in a
- CmmInfoTable attached to each CmmProc. CmmCPSZ.toTops actually does
+ CmmInfoTable attached to each CmmProc. CmmCPS.toTops actually does
the attaching, right at the end of the pipeline. The C_SRT part
gives offsets within a single, shared table of closure pointers.
@@ -398,7 +423,7 @@ a dominator analysis, using the Dataflow Engine. Foreign calls
----------------------------------------------------
-See Note [Foreign calls] in ZipCfgCmmRep! This explains that a safe
+See Note [Foreign calls] in CmmNode! This explains that a safe
foreign call must do this:
save thread state
push info table (on thread stack) to describe frame
@@ -433,7 +458,7 @@ NEW PLAN for foreign calls: Cmm representations
----------------------------------------------------
-* Cmm.hs
+* CmmDecl.hs
The type [GenCmm d h g] represents a whole module,
** one list element per .o file **
Without SplitObjs, the list has exactly one element
@@ -448,7 +473,7 @@ NEW PLAN for foreign calls: -------------
-OLD BACK END representations (Cmm.hs):
+OLD BACK END representations (OldCmm.hs):
type Cmm = GenCmm CmmStatic CmmInfo (ListGraph CmmStmt)
-- A whole module
newtype ListGraph i = ListGraph [GenBasicBlock i]
@@ -463,49 +488,47 @@ OLD BACK END representations (Cmm.hs): -------------
NEW BACK END representations
-* Not Cmm-specific at all
- ZipCfg.hs defines Graph, LGraph, FGraph,
- ZHead, ZTail, ZBlock ...
+* Uses Hoopl library, a zero-boot package
+* CmmNode defines a node of a flow graph.
+* Cmm defines CmmGraph, CmmTop, Cmm
+ - CmmGraph is a closed/closed graph + an entry node.
- classes LastNode, HavingSuccessors
+ data CmmGraph = CmmGraph { g_entry :: BlockId
+ , g_graph :: Graph CmmNode C C }
- MkZipCfg.hs: AGraph: building graphs
+ - CmmTop is a top level chunk, specialization of GenCmmTop from CmmDecl.hs
+ with CmmGraph as a flow graph.
+ - Cmm is a collection of CmmTops.
-* ZipCfgCmmRep: instantiates ZipCfg for Cmm
- data Middle = ...CmmExpr...
- data Last = ...CmmExpr...
- type CmmGraph = Graph Middle Last
+ type Cmm = GenCmm CmmStatic CmmTopInfo CmmGraph
+ type CmmTop = GenCmmTop CmmStatic CmmTopInfo CmmGraph
- type CmmZ = GenCmm CmmStatic CmmInfo (CmmStackInfo, CmmGraph)
- type CmmStackInfo = (ByteOff, Maybe ByteOff)
- -- (SP offset on entry, update frame space = SP offset on exit)
- -- The new codegen produces CmmZ, but once the stack is
- -- manifested we can drop that in favour of
- -- GenCmm CmmStatic CmmInfo CmmGraph
+ - CmmTop uses CmmTopInfo, which is a CmmInfoTable and CmmStackInfo
- Inside a CmmProc:
- - CLabel: used
- - CmmInfo: partly used by NEW
- - CmmFormals: not used at all PERHAPS NOT EVEN BY OLD PIPELINE!
+ data CmmTopInfo = TopInfo {info_tbl :: CmmInfoTable, stack_info :: CmmStackInfo}
-* MkZipCfgCmm.hs: smart constructors for ZipCfgCmmRep
- Depends on (a) MkZipCfg (Cmm-independent)
- (b) ZipCfgCmmRep (Cmm-specific)
+ - CmmStackInfo
--------------
-* SHARED stuff
- CmmExpr.hs defines the Cmm expression types
- - CmmExpr, CmmReg, Width, CmmLit, LocalReg, GlobalReg
- - CmmType, Width etc (saparate module?)
- - MachOp (separate module?)
- - Area, AreaId etc (separate module?)
+ data CmmStackInfo = StackInfo {arg_space :: ByteOff, updfr_space :: Maybe ByteOff}
- BlockId.hs defines BlockId, BlockEnv, BlockSet
+ * arg_space = SP offset on entry
+ * updfr_space space = SP offset on exit
+ Once the staci is manifested, we could drom CmmStackInfo, ie. get
+ GenCmm CmmStatic CmmInfoTable CmmGraph, but we do not do that currently.
--------------
+* MkGraph.hs: smart constructors for Cmm.hs
+ Beware, the CmmAGraph defined here does not use AGraph from Hoopl,
+ as CmmAGraph can be opened or closed at exit, See the notes in that module.
-------------
-* Transactions indicate whether or not the result changes: CmmTx
- type Tx a = a -> TxRes a
- data TxRes a = TxRes ChangeFlag a
+* SHARED stuff
+ CmmDecl.hs - GenCmm and GenCmmTop types
+ CmmExpr.hs - defines the Cmm expression types
+ - CmmExpr, CmmReg, CmmLit, LocalReg, GlobalReg
+ - Area, AreaId etc (separate module?)
+ CmmType.hs - CmmType, Width etc (saparate module?)
+ CmmMachOp.hs - MachOp and CallishMachOp types
+
+ BlockId.hs defines BlockId, BlockEnv, BlockSet
+-------------
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs index 9a043f1efd..d8675c53df 100644 --- a/compiler/codeGen/CgBindery.lhs +++ b/compiler/codeGen/CgBindery.lhs @@ -39,7 +39,7 @@ import CLabel import ClosureInfo import Constants -import Cmm +import OldCmm import PprCmm ( {- instance Outputable -} ) import SMRep import Id diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs index f16a9b5e18..f3013cd5a6 100644 --- a/compiler/codeGen/CgCallConv.hs +++ b/compiler/codeGen/CgCallConv.hs @@ -32,13 +32,13 @@ import CgUtils 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 diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs index 9f24fba379..1eea96c1b0 100644 --- a/compiler/codeGen/CgCase.lhs +++ b/compiler/codeGen/CgCase.lhs @@ -27,8 +27,8 @@ import CgInfoTbls import ClosureInfo import SMRep -import CmmUtils -import Cmm +import OldCmmUtils +import OldCmm import StgSyn import StaticFlags diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs index 60ba7f8652..da44122a4d 100644 --- a/compiler/codeGen/CgClosure.lhs +++ b/compiler/codeGen/CgClosure.lhs @@ -31,8 +31,8 @@ import CgCallConv import CgUtils import ClosureInfo import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import StgSyn import CostCentre diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs index 0981811ee7..8768008776 100644 --- a/compiler/codeGen/CgCon.lhs +++ b/compiler/codeGen/CgCon.lhs @@ -32,8 +32,8 @@ import CgTicky import CgInfoTbls import CLabel import ClosureInfo -import CmmUtils -import Cmm +import OldCmmUtils +import OldCmm import SMRep import CostCentre import Constants diff --git a/compiler/codeGen/CgExpr.lhs b/compiler/codeGen/CgExpr.lhs index 71087ca7c5..1f11495b60 100644 --- a/compiler/codeGen/CgExpr.lhs +++ b/compiler/codeGen/CgExpr.lhs @@ -29,8 +29,8 @@ import CgPrimOp import CgHpc import CgUtils import ClosureInfo -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import VarSet import Literal import PrimOp diff --git a/compiler/codeGen/CgExtCode.hs b/compiler/codeGen/CgExtCode.hs index 0e0a802445..12efa03da0 100644 --- a/compiler/codeGen/CgExtCode.hs +++ b/compiler/codeGen/CgExtCode.hs @@ -39,7 +39,7 @@ where import CgMonad import CLabel -import Cmm +import OldCmm -- import BasicTypes import BlockId @@ -128,8 +128,8 @@ newLocal ty name = do 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. @@ -162,7 +162,7 @@ lookupLabel name = do 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. diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs index cdaccc98a8..ec16946318 100644 --- a/compiler/codeGen/CgForeignCall.hs +++ b/compiler/codeGen/CgForeignCall.hs @@ -25,8 +25,8 @@ import CgUtils import Type import TysPrim import CLabel -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import SMRep import ForeignCall import ClosureInfo diff --git a/compiler/codeGen/CgHeapery.lhs b/compiler/codeGen/CgHeapery.lhs index 174e510cb5..3ff646ca07 100644 --- a/compiler/codeGen/CgHeapery.lhs +++ b/compiler/codeGen/CgHeapery.lhs @@ -34,8 +34,8 @@ import CgCallConv import ClosureInfo import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import Id import DataCon import TyCon diff --git a/compiler/codeGen/CgHpc.hs b/compiler/codeGen/CgHpc.hs index d02c949b5e..8da2715ac2 100644 --- a/compiler/codeGen/CgHpc.hs +++ b/compiler/codeGen/CgHpc.hs @@ -8,10 +8,10 @@ module CgHpc (cgTickBox, initHpc, hpcTable) where -import Cmm +import OldCmm import CLabel import Module -import CmmUtils +import OldCmmUtils import CgUtils import CgMonad import CgForeignCall diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index f704a69c18..e04079d666 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -31,8 +31,8 @@ import CgCallConv import CgUtils import CgMonad -import CmmUtils -import Cmm +import OldCmmUtils +import OldCmm import CLabel import Name import DataCon diff --git a/compiler/codeGen/CgLetNoEscape.lhs b/compiler/codeGen/CgLetNoEscape.lhs index 5870cece99..ed21833f8c 100644 --- a/compiler/codeGen/CgLetNoEscape.lhs +++ b/compiler/codeGen/CgLetNoEscape.lhs @@ -24,8 +24,8 @@ import CgCon import CgHeapery import CgInfoTbls import CgStackery -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import ClosureInfo import CostCentre diff --git a/compiler/codeGen/CgMonad.lhs b/compiler/codeGen/CgMonad.lhs index 44c1cc4416..8a3b664fc1 100644 --- a/compiler/codeGen/CgMonad.lhs +++ b/compiler/codeGen/CgMonad.lhs @@ -63,8 +63,8 @@ import {-# SOURCE #-} CgBindery ( CgBindings, nukeVolatileBinds ) import DynFlags import BlockId -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import StgSyn (SRT) import SMRep @@ -709,7 +709,7 @@ labelC id = emitCgStmt (CgLabel id) newLabelC :: FCode BlockId newLabelC = do { u <- newUnique - ; return $ BlockId u } + ; return $ mkBlockId u } checkedAbsC :: CmmStmt -> Code -- Emit code, eliminating no-ops @@ -742,10 +742,11 @@ emitData sect lits 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 diff --git a/compiler/codeGen/CgParallel.hs b/compiler/codeGen/CgParallel.hs index cfef25c161..682f28aad4 100644 --- a/compiler/codeGen/CgParallel.hs +++ b/compiler/codeGen/CgParallel.hs @@ -17,7 +17,7 @@ module CgParallel( import CgMonad import CgCallConv import Id -import Cmm +import OldCmm import StaticFlags import Outputable import SMRep diff --git a/compiler/codeGen/CgPrimOp.hs b/compiler/codeGen/CgPrimOp.hs index d0da575cf6..8ca42250a9 100644 --- a/compiler/codeGen/CgPrimOp.hs +++ b/compiler/codeGen/CgPrimOp.hs @@ -18,9 +18,9 @@ import CgBindery import CgMonad import CgInfoTbls import CgUtils -import Cmm +import OldCmm import CLabel -import CmmUtils +import OldCmmUtils import PrimOp import SMRep import Module diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs index 7491334c21..0cf209e89c 100644 --- a/compiler/codeGen/CgProf.hs +++ b/compiler/codeGen/CgProf.hs @@ -37,8 +37,8 @@ import CgUtils import CgMonad import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Id diff --git a/compiler/codeGen/CgStackery.lhs b/compiler/codeGen/CgStackery.lhs index 532127a147..0d45b6eb90 100644 --- a/compiler/codeGen/CgStackery.lhs +++ b/compiler/codeGen/CgStackery.lhs @@ -26,8 +26,8 @@ import CgMonad import CgUtils import CgProf import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Constants import Util diff --git a/compiler/codeGen/CgTailCall.lhs b/compiler/codeGen/CgTailCall.lhs index 89c050406f..a3dbe6a1a8 100644 --- a/compiler/codeGen/CgTailCall.lhs +++ b/compiler/codeGen/CgTailCall.lhs @@ -28,8 +28,8 @@ import CgUtils import CgTicky import ClosureInfo import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Type import Id diff --git a/compiler/codeGen/CgTicky.hs b/compiler/codeGen/CgTicky.hs index 7e8c5ca964..45cede5ca9 100644 --- a/compiler/codeGen/CgTicky.hs +++ b/compiler/codeGen/CgTicky.hs @@ -44,8 +44,8 @@ import CgUtils import CgMonad import SMRep -import Cmm -import CmmUtils +import OldCmm +import OldCmmUtils import CLabel import Name diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs index 9d111ca9d8..922d330b26 100644 --- a/compiler/codeGen/CgUtils.hs +++ b/compiler/codeGen/CgUtils.hs @@ -61,10 +61,9 @@ import Id 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(..)) @@ -1081,9 +1080,9 @@ get_Regtable_addr_from_offset rep offset = 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) = diff --git a/compiler/codeGen/CodeGen.lhs b/compiler/codeGen/CodeGen.lhs index 81267f21f9..6ce8fca55b 100644 --- a/compiler/codeGen/CodeGen.lhs +++ b/compiler/codeGen/CodeGen.lhs @@ -28,9 +28,9 @@ import CgUtils import CgHpc import CLabel -import Cmm -import CmmUtils -import PprCmm +import OldCmm +import OldCmmUtils +import OldPprCmm import StgSyn import PrelNames diff --git a/compiler/codeGen/SMRep.lhs b/compiler/codeGen/SMRep.lhs index 1667af8637..f35118d1c9 100644 --- a/compiler/codeGen/SMRep.lhs +++ b/compiler/codeGen/SMRep.lhs @@ -39,7 +39,7 @@ module SMRep ( #include "../includes/MachDeps.h" -import CmmExpr -- CmmType and friends +import CmmType import Id import Type import TyCon diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 52809da502..26ace0780f 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -23,8 +23,9 @@ import StgCmmClosure import StgCmmHpc import StgCmmTicky -import MkZipCfgCmm -import Cmm +import MkGraph +import CmmDecl +import CmmExpr import CmmUtils import CLabel import PprCmm @@ -53,7 +54,7 @@ codeGen :: DynFlags -> 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 @@ -287,7 +288,7 @@ For charlike and intlike closures there is a fixed array of static 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) @@ -304,7 +305,7 @@ cgTyCon tycon ; return (extra ++ constrs) } -cgEnumerationTyCon :: TyCon -> FCode [CmmZ] +cgEnumerationTyCon :: TyCon -> FCode [Cmm] cgEnumerationTyCon tycon | isEnumerationTyCon tycon = do { tbl <- getCmm $ diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 6451840f04..bfb749cb69 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -6,8 +6,8 @@ -- ----------------------------------------------------------------------------- -module StgCmmBind ( - cgTopRhsClosure, +module StgCmmBind ( + cgTopRhsClosure, cgBind, emitBlackHoleCode, pushUpdateFrame @@ -26,15 +26,17 @@ import StgCmmGran 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 @@ -78,7 +80,7 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do -- 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 @@ -97,7 +99,7 @@ cgBind (StgNonRec name rhs) ; 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 @@ -125,7 +127,7 @@ cgBind (StgRec pairs) 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. @@ -239,9 +241,9 @@ mkRhsClosure bndr cc bi 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 @@ -268,7 +270,7 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body 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 @@ -276,8 +278,8 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body ; 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 @@ -295,9 +297,9 @@ mkRhsClosure bndr cc _ fvs upd_flag srt args body ; (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) } @@ -319,12 +321,12 @@ cgStdThunk bndr cc _bndr_info body lf_info payload = 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 @@ -359,10 +361,10 @@ closureCodeBody :: Bool -- whether this is a top-level binding -> [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 @@ -372,42 +374,46 @@ closureCodeBody :: Bool -- whether this is a top-level binding 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 @@ -426,55 +432,56 @@ load_fvs node lf_info = mapCs (\ (reg, off) -> -- 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 }}} ------------------------------------------------------------------------ @@ -487,11 +494,13 @@ blackHoleIt :: ClosureInfo -> FCode () 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") @@ -507,11 +516,11 @@ emitBlackHoleCode is_single_entry -- 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), @@ -522,12 +531,17 @@ setupUpdate closure_info node body = 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 @@ -535,16 +549,20 @@ setupUpdate closure_info node body 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 = @@ -563,7 +581,7 @@ pushUpdateFrame es body -- 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 -- @@ -581,7 +599,7 @@ pushUpdateFrame es body -- 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. @@ -598,12 +616,14 @@ link_caf cl_info _is_upd = do { -- 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), @@ -611,7 +631,7 @@ link_caf cl_info _is_upd = do [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) @@ -629,7 +649,7 @@ link_caf cl_info _is_upd = do ------------------------------------------------------------------------ --- Profiling +-- Profiling ------------------------------------------------------------------------ -- For "global" data constructors the description is simply occurrence @@ -648,4 +668,4 @@ closureDescription mod_name name else pprModule mod_name <> char '.' <> ppr name) <> char '>') -- showSDocDump, because we want to see the unique on the Name. - + diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index d66dda5021..fe09f6851b 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -11,7 +11,6 @@ -- ----------------------------------------------------------------------------- - module StgCmmClosure ( SMRep, DynTag, tagForCon, isSmallFamily, @@ -73,7 +72,7 @@ import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..)) import StgSyn import SMRep -import Cmm ( ClosureTypeInfo(..), ConstrDescription ) +import CmmDecl ( ClosureTypeInfo(..), ConstrDescription ) import CmmExpr import CLabel diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index cebd743e94..633d577c73 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -25,9 +25,9 @@ import StgCmmUtils import StgCmmClosure import StgCmmProf -import Cmm +import CmmExpr import CLabel -import MkZipCfgCmm (CmmAGraph, mkNop) +import MkGraph import SMRep import CostCentre import Module diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index cd94c58daa..469f58d7df 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -35,10 +35,9 @@ import StgCmmClosure import CLabel import BlockId -import Cmm +import CmmExpr import CmmUtils import FastString -import PprCmm ( {- instance Outputable -} ) import Id import VarEnv import Control.Monad diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 94afb80f5b..eee4a08bc7 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -27,7 +27,7 @@ import StgCmmClosure import StgSyn -import MkZipCfgCmm +import MkGraph import BlockId import CmmExpr import CoreSyn @@ -455,10 +455,8 @@ cgAltRhss gc_plan bndr alts ; 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 @@ -610,3 +608,4 @@ we should still generate the same code: L2: <default-case code> -} + diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 7ddf597f40..9a15cf0d06 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -24,9 +24,11 @@ import StgCmmUtils 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 @@ -36,7 +38,6 @@ import Constants import StaticFlags import Maybes import Outputable -import ZipCfgCmmRep import BasicTypes import Control.Monad @@ -111,7 +112,7 @@ emitPrimCall res op args 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" @@ -145,7 +146,7 @@ load_args_into_temps = mapM arg_assign_temp 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) @@ -171,8 +172,8 @@ maybe_assign_temp e 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 @@ -181,8 +182,8 @@ saveThreadState = 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: @@ -193,17 +194,19 @@ emitSaveThreadState bid = do 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: @@ -211,8 +214,8 @@ loadThreadState tso = do 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 [ @@ -242,22 +245,15 @@ 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_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 diff --git a/compiler/codeGen/StgCmmGran.hs b/compiler/codeGen/StgCmmGran.hs index 27e6114356..b6a1ae66bb 100644 --- a/compiler/codeGen/StgCmmGran.hs +++ b/compiler/codeGen/StgCmmGran.hs @@ -19,7 +19,7 @@ module StgCmmGran ( -- I've left the calls, though, in case anyone wants to resurrect it import StgCmmMonad -import Cmm +import CmmExpr staticGranHdr :: [CmmLit] staticGranHdr = [] diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 4163723947..0015da1cac 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -7,19 +7,20 @@ ----------------------------------------------------------------------------- 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 @@ -31,7 +32,7 @@ import StgCmmGran import StgCmmClosure import StgCmmEnv -import MkZipCfgCmm +import MkGraph import SMRep import CmmExpr @@ -41,49 +42,53 @@ import TyCon 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 @@ -93,84 +98,89 @@ allocDynClosure -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -- 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 @@ -188,44 +198,44 @@ mkStaticClosureFields cl_info ccs caf_refs payload 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) @@ -238,7 +248,7 @@ padLitToWord lit = lit : padding pad_length | otherwise = CmmInt 0 W64 : padding (n-8) ----------------------------------------------------------- --- Heap overflow checking +-- Heap overflow checking ----------------------------------------------------------- {- Note [Heap checks] @@ -251,12 +261,12 @@ convention. 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) @@ -266,213 +276,251 @@ These are used in the following circumstances * 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 {- @@ -483,34 +531,34 @@ which will be in registers, and the others will be on the stack. We 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 @@ -530,9 +578,9 @@ again on re-entry because someone else might have stolen the resource in the meantime. %************************************************************************ -%* * +%* * Generic Heap/Stack Checks - used in the RTS -%* * +%* * %************************************************************************ \begin{code} @@ -541,9 +589,9 @@ hpChkGen bytes liveness reentry = 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). diff --git a/compiler/codeGen/StgCmmHpc.hs b/compiler/codeGen/StgCmmHpc.hs index e39a1013e3..a93af34961 100644 --- a/compiler/codeGen/StgCmmHpc.hs +++ b/compiler/codeGen/StgCmmHpc.hs @@ -12,8 +12,9 @@ import StgCmmUtils import StgCmmMonad import StgCmmForeign -import MkZipCfgCmm -import Cmm +import MkGraph +import CmmDecl +import CmmExpr import CLabel import Module import CmmUtils diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index 21e55ee074..eddf257e5f 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -6,13 +6,6 @@ -- ----------------------------------------------------------------------------- -{-# 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, @@ -42,10 +35,11 @@ import StgCmmTicky import StgCmmUtils import StgCmmMonad -import MkZipCfgCmm +import MkGraph import SMRep +import CmmDecl +import CmmExpr import CmmUtils -import Cmm import CLabel import StgSyn import DataCon @@ -462,7 +456,7 @@ emitClosureProcAndInfoTable :: Bool -- top-level? -> 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 @@ -474,9 +468,10 @@ emitClosureProcAndInfoTable top_lvl bndr cl_info args body ; 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 @@ -491,9 +486,9 @@ emitClosureAndInfoTable cl_info conv args body 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 @@ -501,25 +496,13 @@ mkCmmInfo cl_info 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 diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 72f9cec393..919a5d0eee 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -51,10 +51,11 @@ module StgCmmMonad ( 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 @@ -243,7 +244,7 @@ data CgState = 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 @@ -599,25 +600,25 @@ emitData sect lits 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) diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 1c1fab1ba6..8f688f023c 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -18,9 +18,10 @@ import StgCmmEnv import StgCmmMonad import StgCmmUtils -import MkZipCfgCmm +import MkGraph import StgSyn -import Cmm +import CmmDecl +import CmmExpr import Type ( Type, tyConAppTyCon ) import TyCon import CLabel diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index 944729f287..36d05acf90 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -38,8 +38,9 @@ import StgCmmUtils import StgCmmMonad import SMRep -import MkZipCfgCmm -import Cmm +import MkGraph +import CmmExpr +import CmmDecl import CmmUtils import CLabel diff --git a/compiler/codeGen/StgCmmTicky.hs b/compiler/codeGen/StgCmmTicky.hs index 3fa579b80c..e8642eb4e6 100644 --- a/compiler/codeGen/StgCmmTicky.hs +++ b/compiler/codeGen/StgCmmTicky.hs @@ -48,8 +48,8 @@ import StgCmmMonad import SMRep import StgSyn -import Cmm -import MkZipCfgCmm +import CmmExpr +import MkGraph import CmmUtils import CLabel diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 4b1446a7e2..48416e3f69 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -20,7 +20,7 @@ module StgCmmUtils ( tagToClosure, mkTaggedObjectLoad, - callerSaveVolatileRegs, get_GlobalReg_addr, + callerSaves, callerSaveVolatileRegs, get_GlobalReg_addr, cmmAndWord, cmmOrWord, cmmNegate, cmmEqWord, cmmNeWord, cmmUGtWord, @@ -49,11 +49,11 @@ module StgCmmUtils ( 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 diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index cc4c562a9d..32d13f839b 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -92,6 +92,7 @@ Library 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 @@ -188,45 +189,37 @@ Library 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 diff --git a/compiler/llvmGen/LlvmCodeGen.hs b/compiler/llvmGen/LlvmCodeGen.hs index b4d407d277..ba5c1ece1d 100644 --- a/compiler/llvmGen/LlvmCodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen.hs @@ -16,9 +16,9 @@ import LlvmCodeGen.Ppr import LlvmMangler import CLabel -import Cmm import CgUtils ( fixStgRegisters ) -import PprCmm +import OldCmm +import OldPprCmm import BufWrite import DynFlags @@ -38,8 +38,8 @@ llvmCodeGen :: DynFlags -> Handle -> UniqSupply -> [RawCmm] -> IO () 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 diff --git a/compiler/llvmGen/LlvmCodeGen/Base.hs b/compiler/llvmGen/LlvmCodeGen/Base.hs index 408a553fd2..80d88e6b14 100644 --- a/compiler/llvmGen/LlvmCodeGen/Base.hs +++ b/compiler/llvmGen/LlvmCodeGen/Base.hs @@ -27,9 +27,9 @@ import LlvmCodeGen.Regs import CLabel import CgUtils ( activeStgRegs ) -import Cmm import Constants import FastString +import OldCmm import qualified Outputable as Outp import UniqFM import Unique diff --git a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs index cd135de5cb..f5dd3bbf83 100644 --- a/compiler/llvmGen/LlvmCodeGen/CodeGen.hs +++ b/compiler/llvmGen/LlvmCodeGen/CodeGen.hs @@ -13,8 +13,8 @@ import LlvmCodeGen.Regs import BlockId import CgUtils ( activeStgRegs, callerSaves ) import CLabel -import Cmm -import qualified PprCmm +import OldCmm +import qualified OldPprCmm as PprCmm import OrdList import BasicTypes @@ -39,14 +39,14 @@ genLlvmProc :: LlvmEnv -> RawCmmTop -> UniqSM (LlvmEnv, [LlvmCmmTop]) 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) diff --git a/compiler/llvmGen/LlvmCodeGen/Data.hs b/compiler/llvmGen/LlvmCodeGen/Data.hs index 0c403e04de..3e486a544f 100644 --- a/compiler/llvmGen/LlvmCodeGen/Data.hs +++ b/compiler/llvmGen/LlvmCodeGen/Data.hs @@ -13,7 +13,7 @@ import LlvmCodeGen.Base import BlockId import CLabel -import Cmm +import OldCmm import FastString import qualified Outputable diff --git a/compiler/llvmGen/LlvmCodeGen/Ppr.hs b/compiler/llvmGen/LlvmCodeGen/Ppr.hs index 853f1b14c5..911592bc20 100644 --- a/compiler/llvmGen/LlvmCodeGen/Ppr.hs +++ b/compiler/llvmGen/LlvmCodeGen/Ppr.hs @@ -13,7 +13,7 @@ import LlvmCodeGen.Base import LlvmCodeGen.Data import CLabel -import Cmm +import OldCmm import FastString import qualified Outputable @@ -82,7 +82,7 @@ pprLlvmCmmTop :: LlvmEnv -> Int -> LlvmCmmTop -> (Doc, [LlvmVar]) 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 diff --git a/compiler/main/CodeOutput.lhs b/compiler/main/CodeOutput.lhs index 921bbde447..85f34025fc 100644 --- a/compiler/main/CodeOutput.lhs +++ b/compiler/main/CodeOutput.lhs @@ -26,7 +26,7 @@ import PprC ( writeCs ) import CmmLint ( cmmLint ) import Packages import Util -import Cmm ( RawCmm ) +import OldCmm ( RawCmm ) import HscTypes import DynFlags import Config diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index 01ec74002d..312772eff8 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -113,17 +113,15 @@ import TyCon ( TyCon, isDataTyCon ) 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 ) @@ -894,7 +892,7 @@ hscGenHardCode cgguts mod_summary 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 @@ -974,17 +972,17 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods ; 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 @@ -999,11 +997,6 @@ optionallyConvertAndOrCPS hsc_env cmms = 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 @@ -1014,17 +1007,15 @@ testCmmConversion hsc_env cmm = 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 diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs index 68d25de699..7a38540baa 100644 --- a/compiler/nativeGen/AsmCodeGen.lhs +++ b/compiler/nativeGen/AsmCodeGen.lhs @@ -63,9 +63,9 @@ import NCGMonad import BlockId import CgUtils ( fixStgRegisters ) -import Cmm +import OldCmm import CmmOpt ( cmmMiniInline, cmmMachOpFold ) -import PprCmm +import OldPprCmm import CLabel import UniqFM @@ -205,7 +205,7 @@ nativeCodeGen dflags h us cmms | 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. @@ -421,8 +421,8 @@ cmmNativeGen dflags us cmm count #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 @@ -498,8 +498,8 @@ sequenceTop -> 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 @@ -509,7 +509,7 @@ sequenceTop (CmmProc info lbl params (ListGraph blocks)) = -- 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 @@ -626,10 +626,10 @@ shortcutBranches dflags tops 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 @@ -639,11 +639,11 @@ build_mapping (CmmProc info lbl params (ListGraph (head:blocks))) (_, 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) @@ -658,8 +658,8 @@ apply_mapping ufm (CmmData sec statics) = 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 @@ -704,7 +704,6 @@ genMachCode dflags cmm_top else pprPanic "genMachCode: nonzero final delta" (int final_delta) } - -- ----------------------------------------------------------------------------- -- Generic Cmm optimiser @@ -730,9 +729,9 @@ Ideas for other things we could do (ToDo): 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] #)) diff --git a/compiler/nativeGen/Instruction.hs b/compiler/nativeGen/Instruction.hs index 22c37a5b12..918198cb9c 100644 --- a/compiler/nativeGen/Instruction.hs +++ b/compiler/nativeGen/Instruction.hs @@ -13,7 +13,7 @@ where import Reg import BlockId -import Cmm +import OldCmm -- | Holds a list of source and destination registers used by a -- particular instruction. diff --git a/compiler/nativeGen/NCGMonad.hs b/compiler/nativeGen/NCGMonad.hs index 8b9629b1d8..2a7376838a 100644 --- a/compiler/nativeGen/NCGMonad.hs +++ b/compiler/nativeGen/NCGMonad.hs @@ -120,7 +120,7 @@ addImportNat imp getBlockIdNat :: NatM BlockId getBlockIdNat = do u <- getUniqueNat - return (BlockId u) + return (mkBlockId u) getNewLabelNat :: NatM CLabel diff --git a/compiler/nativeGen/PIC.hs b/compiler/nativeGen/PIC.hs index fbe51999b5..c375ab4707 100644 --- a/compiler/nativeGen/PIC.hs +++ b/compiler/nativeGen/PIC.hs @@ -63,7 +63,7 @@ import Reg import NCGMonad -import Cmm +import OldCmm import CLabel ( CLabel, ForeignLabelSource(..), pprCLabel, mkDynamicLinkerLabel, DynamicLinkerLabelInfo(..), dynamicLinkerLabelInfo, mkPicBaseLabel, @@ -713,7 +713,7 @@ initializePicBase_ppc -> 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 @@ -739,11 +739,11 @@ initializePicBase_ppc ArchPPC os picReg : 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) @@ -766,15 +766,15 @@ initializePicBase_x86 -> 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) diff --git a/compiler/nativeGen/PPC/CodeGen.hs b/compiler/nativeGen/PPC/CodeGen.hs index 8a4228b578..29b9a54d49 100644 --- a/compiler/nativeGen/PPC/CodeGen.hs +++ b/compiler/nativeGen/PPC/CodeGen.hs @@ -41,7 +41,7 @@ import Platform -- Our intermediate code: import BlockId import PprCmm ( pprExpr ) -import Cmm +import OldCmm import CLabel -- The rest: @@ -49,6 +49,7 @@ import StaticFlags ( opt_PIC ) import OrdList import qualified Outputable as O import Outputable +import Unique import DynFlags import Control.Monad ( mapAndUnzipM ) @@ -74,10 +75,10 @@ cmmTopCodeGen -> 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 @@ -221,8 +222,8 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 -- | 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) @@ -1130,9 +1131,9 @@ genSwitch expr ids 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), diff --git a/compiler/nativeGen/PPC/Instr.hs b/compiler/nativeGen/PPC/Instr.hs index d4d809825d..6aeccd3a87 100644 --- a/compiler/nativeGen/PPC/Instr.hs +++ b/compiler/nativeGen/PPC/Instr.hs @@ -28,7 +28,7 @@ import Reg import Constants (rESERVED_C_STACK_BYTES) import BlockId -import Cmm +import OldCmm import FastString import CLabel import Outputable diff --git a/compiler/nativeGen/PPC/Ppr.hs b/compiler/nativeGen/PPC/Ppr.hs index 2d8f0444fe..9fb86c013e 100644 --- a/compiler/nativeGen/PPC/Ppr.hs +++ b/compiler/nativeGen/PPC/Ppr.hs @@ -33,12 +33,11 @@ import Reg 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 @@ -56,9 +55,9 @@ pprNatCmmTop (CmmData section dats) = 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 @@ -90,8 +89,8 @@ pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ +pprBasicBlock (BasicBlock blockid instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ vcat (map pprInstr instrs) @@ -511,16 +510,16 @@ pprInstr (CMPL sz reg ri) = hcat [ 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), @@ -531,7 +530,7 @@ pprInstr (BCCFAR cond (BlockId id)) = vcat [ 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', diff --git a/compiler/nativeGen/PPC/RegInfo.hs b/compiler/nativeGen/PPC/RegInfo.hs index 2a23bbb269..91c9e15e62 100644 --- a/compiler/nativeGen/PPC/RegInfo.hs +++ b/compiler/nativeGen/PPC/RegInfo.hs @@ -23,10 +23,11 @@ import PPC.Regs import PPC.Instr import BlockId -import Cmm +import OldCmm import CLabel import Outputable +import Unique data JumpDest = DestBlockId BlockId | DestImm Imm @@ -42,11 +43,11 @@ shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic 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. @@ -58,10 +59,11 @@ shortBlockId -> 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 diff --git a/compiler/nativeGen/PPC/Regs.hs b/compiler/nativeGen/PPC/Regs.hs index e00dd7e496..73e0c2023e 100644 --- a/compiler/nativeGen/PPC/Regs.hs +++ b/compiler/nativeGen/PPC/Regs.hs @@ -55,7 +55,7 @@ import RegClass import Size import BlockId -import Cmm +import OldCmm import CLabel ( CLabel ) import Unique diff --git a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs index 556f91c228..1eaf00f3a2 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Coalesce.hs @@ -12,7 +12,7 @@ import RegAlloc.Liveness import Instruction import Reg -import Cmm +import OldCmm import Bag import Digraph import UniqFM @@ -67,11 +67,11 @@ slurpJoinMovs 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 diff --git a/compiler/nativeGen/RegAlloc/Graph/Spill.hs b/compiler/nativeGen/RegAlloc/Graph/Spill.hs index 7e744e6337..4eabb3b0b4 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Spill.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Spill.hs @@ -12,7 +12,7 @@ where import RegAlloc.Liveness import Instruction import Reg -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import BlockId import State @@ -89,12 +89,12 @@ regSpill_top regSlotMap cmm 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 @@ -103,7 +103,7 @@ regSpill_top regSlotMap cmm -- 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 @@ -113,7 +113,7 @@ regSpill_top regSlotMap cmm -- 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, diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs index ef4f0887d9..38c33b708a 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillClean.hs @@ -33,7 +33,7 @@ import Instruction import Reg import BlockId -import Cmm +import OldCmm import UniqSet import UniqFM import Unique @@ -47,7 +47,6 @@ import Data.Set (Set) import qualified Data.Map as Map import qualified Data.Set as Set - -- type Slot = Int @@ -291,10 +290,10 @@ cleanTopBackward cmm 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 diff --git a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs index 0dc25f58d2..330a410312 100644 --- a/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs +++ b/compiler/nativeGen/RegAlloc/Graph/SpillCost.hs @@ -24,7 +24,7 @@ import Reg import GraphBase import BlockId -import Cmm +import OldCmm import UniqFM import UniqSet import Digraph (flattenSCCs) @@ -71,7 +71,7 @@ slurpSpillCostInfo cmm = execState (countCmm cmm) zeroSpillCostInfo where countCmm CmmData{} = return () - countCmm (CmmProc info _ _ sccs) + countCmm (CmmProc info _ sccs) = mapM_ (countBlock info) $ flattenSCCs sccs @@ -79,7 +79,7 @@ slurpSpillCostInfo cmm -- 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 diff --git a/compiler/nativeGen/RegAlloc/Graph/Stats.hs b/compiler/nativeGen/RegAlloc/Graph/Stats.hs index 51554d6953..5ff7bff91a 100644 --- a/compiler/nativeGen/RegAlloc/Graph/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Graph/Stats.hs @@ -27,7 +27,8 @@ import RegClass import Reg import TargetReg -import Cmm +import OldCmm +import OldPprCmm() import Outputable import UniqFM import UniqSet diff --git a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs index a9367f9f01..903082fc26 100644 --- a/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs +++ b/compiler/nativeGen/RegAlloc/Linear/JoinToTargets.hs @@ -23,7 +23,7 @@ import Instruction import Reg import BlockId -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph import Outputable import Unique @@ -86,7 +86,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) -- 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 @@ -96,7 +96,7 @@ joinToTargets' block_live new_blocks block_id instr (dest:dests) , 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 @@ -118,8 +118,7 @@ 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 @@ -173,7 +172,7 @@ joinToTargets_again -- 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 @@ -190,7 +189,7 @@ joinToTargets_again -- 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 diff --git a/compiler/nativeGen/RegAlloc/Linear/Main.hs b/compiler/nativeGen/RegAlloc/Linear/Main.hs index de771523b9..5fab944e09 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Main.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Main.hs @@ -102,7 +102,7 @@ import Instruction import Reg import BlockId -import Cmm hiding (RegSet) +import OldCmm hiding (RegSet) import Digraph import Unique @@ -132,11 +132,11 @@ regAlloc (CmmData sec d) ( 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. @@ -148,11 +148,11 @@ regAlloc (CmmProc static lbl params sccs) 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" @@ -228,7 +228,7 @@ process first_id block_live (b@(BasicBlock id _) : blocks) = 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 @@ -259,7 +259,7 @@ processBlock block_live (BasicBlock id instrs) 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 diff --git a/compiler/nativeGen/RegAlloc/Linear/Stats.hs b/compiler/nativeGen/RegAlloc/Linear/Stats.hs index 137168e942..c80f77f893 100644 --- a/compiler/nativeGen/RegAlloc/Linear/Stats.hs +++ b/compiler/nativeGen/RegAlloc/Linear/Stats.hs @@ -10,7 +10,7 @@ import RegAlloc.Linear.Base import RegAlloc.Liveness import Instruction -import Cmm (GenBasicBlock(..)) +import OldCmm (GenBasicBlock(..)) import UniqFM import Outputable diff --git a/compiler/nativeGen/RegAlloc/Liveness.hs b/compiler/nativeGen/RegAlloc/Liveness.hs index 903fa4c577..a2030fafa9 100644 --- a/compiler/nativeGen/RegAlloc/Liveness.hs +++ b/compiler/nativeGen/RegAlloc/Liveness.hs @@ -35,8 +35,8 @@ import Reg import Instruction import BlockId -import Cmm hiding (RegSet) -import PprCmm() +import OldCmm hiding (RegSet) +import OldPprCmm() import Digraph import Outputable @@ -64,9 +64,6 @@ emptyRegMap = emptyUFM type BlockMap a = BlockEnv a -emptyBlockMap :: BlockEnv a -emptyBlockMap = emptyBlockEnv - -- | A top level thing which carries liveness information. type LiveCmmTop instr @@ -243,9 +240,9 @@ mapBlockTopM 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) @@ -275,9 +272,9 @@ mapGenBlockTopM 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. @@ -293,7 +290,7 @@ slurpConflicts live = 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) @@ -304,7 +301,7 @@ slurpConflicts live 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) @@ -372,7 +369,7 @@ slurpReloadCoalesce live -> 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) @@ -469,8 +466,7 @@ stripLive live = 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 @@ -479,17 +475,17 @@ stripLive live ((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. @@ -554,14 +550,14 @@ patchEraseLive patchF cmm 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" @@ -630,19 +626,17 @@ natCmmTopToLive 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 @@ -670,18 +664,18 @@ regLiveness 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 -- ----------------------------------------------------------------------------- @@ -730,7 +724,7 @@ reverseBlocksInTops :: LiveCmmTop instr -> LiveCmmTop instr 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 @@ -803,8 +797,8 @@ livenessSCCs blockmap done -- 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) @@ -821,7 +815,7 @@ livenessBlock blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry + blockmap' = mapInsert block_id regsLiveOnEntry blockmap instrs2 = livenessForward regsLiveOnEntry instrs1 @@ -928,7 +922,7 @@ liveness1 liveregs blockmap (LiveInstr instr _) not_a_branch = null targets targetLiveRegs target - = case lookupBlockEnv blockmap target of + = case mapLookup target blockmap of Just ra -> ra Nothing -> emptyRegMap diff --git a/compiler/nativeGen/SPARC/CodeGen.hs b/compiler/nativeGen/SPARC/CodeGen.hs index c430e18579..d08d10d437 100644 --- a/compiler/nativeGen/SPARC/CodeGen.hs +++ b/compiler/nativeGen/SPARC/CodeGen.hs @@ -36,13 +36,14 @@ import NCGMonad -- 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 @@ -54,11 +55,11 @@ cmmTopCodeGen -> 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 @@ -161,8 +162,8 @@ temporary, then do the other computation, and then use the temporary: -- | 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) diff --git a/compiler/nativeGen/SPARC/CodeGen/Amode.hs b/compiler/nativeGen/SPARC/CodeGen/Amode.hs index c3f4a28a31..8f1fad8dd3 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Amode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Amode.hs @@ -15,7 +15,7 @@ import SPARC.Base import NCGMonad import Size -import Cmm +import OldCmm import OrdList diff --git a/compiler/nativeGen/SPARC/CodeGen/Base.hs b/compiler/nativeGen/SPARC/CodeGen/Base.hs index c85d8065ad..57fb7c9e90 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Base.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Base.hs @@ -22,7 +22,8 @@ import SPARC.RegPlate import Size import Reg -import Cmm +import OldCmm +import OldPprCmm () import Outputable import OrdList diff --git a/compiler/nativeGen/SPARC/CodeGen/CCall.hs b/compiler/nativeGen/SPARC/CodeGen/CCall.hs index 71d318838e..106b6734fa 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CCall.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CCall.hs @@ -19,7 +19,7 @@ import Instruction import Size import Reg -import Cmm +import OldCmm import CLabel import BasicTypes diff --git a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs index 4093c7fe80..0f6b12b627 100644 --- a/compiler/nativeGen/SPARC/CodeGen/CondCode.hs +++ b/compiler/nativeGen/SPARC/CodeGen/CondCode.hs @@ -17,7 +17,7 @@ import SPARC.Base import NCGMonad import Size -import Cmm +import OldCmm import OrdList import Outputable diff --git a/compiler/nativeGen/SPARC/CodeGen/Expand.hs b/compiler/nativeGen/SPARC/CodeGen/Expand.hs index 2becccb30d..d4500e8a8e 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Expand.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Expand.hs @@ -14,7 +14,7 @@ import SPARC.Ppr () import Instruction import Reg import Size -import Cmm +import OldCmm import Outputable @@ -25,8 +25,8 @@ expandTop :: NatCmmTop Instr -> NatCmmTop Instr 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 diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs index 4ae87df33d..9d6aa5e646 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs @@ -22,9 +22,9 @@ import NCGMonad import Size import Reg -import Cmm -import BlockId +import OldCmm +import Control.Monad (liftM) import OrdList import Outputable @@ -638,8 +638,8 @@ condIntReg NE x y = do 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 @@ -664,8 +664,8 @@ condIntReg cond x y = do 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 diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot index 35aac56148..4816a1d9a7 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot +++ b/compiler/nativeGen/SPARC/CodeGen/Gen32.hs-boot @@ -10,7 +10,7 @@ import SPARC.CodeGen.Base import NCGMonad import Reg -import Cmm +import OldCmm getSomeReg :: CmmExpr -> NatM (Reg, InstrBlock) getRegister :: CmmExpr -> NatM Register diff --git a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs index 8e6271e0a3..180ec315ee 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Gen64.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Gen64.hs @@ -21,7 +21,7 @@ import Instruction import Size import Reg -import Cmm +import OldCmm import OrdList import Outputable diff --git a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs index 56f71e44ed..ca4c8e4994 100644 --- a/compiler/nativeGen/SPARC/CodeGen/Sanity.hs +++ b/compiler/nativeGen/SPARC/CodeGen/Sanity.hs @@ -12,7 +12,7 @@ import SPARC.Instr import SPARC.Ppr () import Instruction -import Cmm +import OldCmm import Outputable diff --git a/compiler/nativeGen/SPARC/Imm.hs b/compiler/nativeGen/SPARC/Imm.hs index 7ed30fd3bb..bcb35b2ab5 100644 --- a/compiler/nativeGen/SPARC/Imm.hs +++ b/compiler/nativeGen/SPARC/Imm.hs @@ -8,7 +8,7 @@ module SPARC.Imm ( where -import Cmm +import OldCmm import CLabel import BlockId diff --git a/compiler/nativeGen/SPARC/Instr.hs b/compiler/nativeGen/SPARC/Instr.hs index 00b57f9b06..79b4629e54 100644 --- a/compiler/nativeGen/SPARC/Instr.hs +++ b/compiler/nativeGen/SPARC/Instr.hs @@ -38,7 +38,7 @@ import Reg import Size import BlockId -import Cmm +import OldCmm import FastString import FastBool import Outputable diff --git a/compiler/nativeGen/SPARC/Ppr.hs b/compiler/nativeGen/SPARC/Ppr.hs index cb11d36d65..a63661f145 100644 --- a/compiler/nativeGen/SPARC/Ppr.hs +++ b/compiler/nativeGen/SPARC/Ppr.hs @@ -34,11 +34,11 @@ import Reg 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 @@ -53,9 +53,9 @@ pprNatCmmTop (CmmData section dats) = 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 @@ -87,8 +87,8 @@ pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ +pprBasicBlock (BasicBlock blockid instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ vcat (map pprInstr instrs) @@ -526,20 +526,20 @@ pprInstr (FxTOy size1 size2 reg1 reg2) ] -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) diff --git a/compiler/nativeGen/SPARC/Regs.hs b/compiler/nativeGen/SPARC/Regs.hs index 98151ecfa5..1fea9d6179 100644 --- a/compiler/nativeGen/SPARC/Regs.hs +++ b/compiler/nativeGen/SPARC/Regs.hs @@ -37,7 +37,7 @@ import Reg import RegClass import Size -import PprCmm () +-- import PprCmm () import Unique import Outputable diff --git a/compiler/nativeGen/SPARC/ShortcutJump.hs b/compiler/nativeGen/SPARC/ShortcutJump.hs index f560f82f9a..c0c33432db 100644 --- a/compiler/nativeGen/SPARC/ShortcutJump.hs +++ b/compiler/nativeGen/SPARC/ShortcutJump.hs @@ -14,9 +14,10 @@ import SPARC.Imm import CLabel import BlockId -import Cmm +import OldCmm import Panic +import Unique @@ -37,11 +38,11 @@ shortcutStatic :: (BlockId -> Maybe JumpDest) -> CmmStatic -> CmmStatic 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. @@ -50,9 +51,9 @@ shortcutStatic _ other_static 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" diff --git a/compiler/nativeGen/Size.hs b/compiler/nativeGen/Size.hs index 3be5430e82..6b5b1aff59 100644 --- a/compiler/nativeGen/Size.hs +++ b/compiler/nativeGen/Size.hs @@ -22,7 +22,7 @@ module Size ( where -import Cmm +import OldCmm import Outputable -- It looks very like the old MachRep, but it's now of purely local diff --git a/compiler/nativeGen/TargetReg.hs b/compiler/nativeGen/TargetReg.hs index 1a8d88380d..35b49d1809 100644 --- a/compiler/nativeGen/TargetReg.hs +++ b/compiler/nativeGen/TargetReg.hs @@ -27,7 +27,7 @@ import Reg import RegClass import Size -import CmmExpr (wordWidth) +import CmmType (wordWidth) import Outputable import Unique import FastTypes diff --git a/compiler/nativeGen/X86/CodeGen.hs b/compiler/nativeGen/X86/CodeGen.hs index 02abd04642..44311a4186 100644 --- a/compiler/nativeGen/X86/CodeGen.hs +++ b/compiler/nativeGen/X86/CodeGen.hs @@ -47,7 +47,8 @@ import Platform import BasicTypes import BlockId import PprCmm ( pprExpr ) -import Cmm +import OldCmm +import OldPprCmm import CLabel import ClosureInfo ( C_SRT(..) ) @@ -58,6 +59,7 @@ import OrdList import Pretty import qualified Outputable as O import Outputable +import Unique import FastString import FastBool ( isFastTrue ) import Constants ( wORD_SIZE ) @@ -93,11 +95,10 @@ cmmTopCodeGen -> 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 @@ -271,8 +272,8 @@ is32BitInteger i = i64 <= 0x7fffffff && i64 >= -0x80000000 -- | 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) -- ----------------------------------------------------------------------------- @@ -1926,9 +1927,9 @@ genSwitch expr ids 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)) diff --git a/compiler/nativeGen/X86/Instr.hs b/compiler/nativeGen/X86/Instr.hs index b9cdf7f991..28b7997139 100644 --- a/compiler/nativeGen/X86/Instr.hs +++ b/compiler/nativeGen/X86/Instr.hs @@ -21,7 +21,7 @@ import Reg import TargetReg import BlockId -import Cmm +import OldCmm import FastString import FastBool import Outputable @@ -778,24 +778,24 @@ canShortcut _ = Nothing -- 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. @@ -808,10 +808,11 @@ shortBlockId -> 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 diff --git a/compiler/nativeGen/X86/Ppr.hs b/compiler/nativeGen/X86/Ppr.hs index f26e2e6c08..7944a38ff4 100644 --- a/compiler/nativeGen/X86/Ppr.hs +++ b/compiler/nativeGen/X86/Ppr.hs @@ -32,11 +32,10 @@ import Reg 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 @@ -57,9 +56,9 @@ pprNatCmmTop (CmmData section dats) = 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 @@ -91,8 +90,8 @@ pprNatCmmTop (CmmProc info lbl _ (ListGraph blocks)) = pprBasicBlock :: NatBasicBlock Instr -> Doc -pprBasicBlock (BasicBlock (BlockId id) instrs) = - pprLabel (mkAsmTempLabel id) $$ +pprBasicBlock (BasicBlock blockid instrs) = + pprLabel (mkAsmTempLabel (getUnique blockid)) $$ vcat (map pprInstr instrs) @@ -619,9 +618,9 @@ pprInstr (CLTD II64) = ptext (sLit "\tcqto") 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) diff --git a/compiler/nativeGen/X86/Regs.hs b/compiler/nativeGen/X86/Regs.hs index 943a7a3b6d..094b74dc37 100644 --- a/compiler/nativeGen/X86/Regs.hs +++ b/compiler/nativeGen/X86/Regs.hs @@ -54,7 +54,7 @@ import Reg import RegClass import BlockId -import Cmm +import OldCmm import CLabel ( CLabel ) import Pretty import Outputable ( panic ) @@ -308,7 +308,7 @@ TH_PACKAGES := $(DPH_PACKAGES) # # 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 @@ -391,6 +391,7 @@ $(eval $(call addPackage,template-haskell)) $(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)) @@ -675,6 +676,7 @@ $(eval $(call build-package,libraries/extensible-exceptions,dist-boot,0)) $(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 diff --git a/mk/validate-settings.mk b/mk/validate-settings.mk index 56acca4e87..c000f852a5 100644 --- a/mk/validate-settings.mk +++ b/mk/validate-settings.mk @@ -62,6 +62,15 @@ libraries/haskeline_dist-install_EXTRA_HC_OPTS += -fno-warn-unused-imports 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 @@ -59,6 +59,7 @@ libraries/ghc-prim - packages/ghc-prim darc 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 - diff --git a/utils/ghc-cabal/Main.hs b/utils/ghc-cabal/Main.hs index a4566f1132..d75696fa2c 100644 --- a/utils/ghc-cabal/Main.hs +++ b/utils/ghc-cabal/Main.hs @@ -11,7 +11,7 @@ import Distribution.Simple.Configure 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 @@ -298,7 +298,7 @@ generate config_args distdir directory 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 |