From e6243a818496aad82b6f47511d3bd9bc800f747d Mon Sep 17 00:00:00 2001 From: "dias@eecs.harvard.edu" Date: Mon, 13 Oct 2008 13:25:56 +0000 Subject: [PATCH] Big collection of patches for the new codegen branch. o Fixed bug that emitted the copy-in code for closure entry in the wrong place -- at the initialization of the closure. o Refactored some of the closure entry code. o Added code to check that no LocalRegs are live-in to a procedure -- trip up some buggy programs earlier o Fixed environment bindings for thunks -- we weren't (re)binding the free variables in a thunk o Fixed a bug in proc-point splitting that dropped some updates to the entry block in a procedure. o Fixed improper calls to code that generates CmmLit's for strings o New invariant on cg_loc in CgIdInfo: the expression is always tagged o Code to load free vars on entry to a thunk was (wrongly) placed before the heap check. o Some of the StgCmm code was redundantly passing around Id's along with CgIdInfo's; no more. o Initialize the LocalReg's that point to a closure before allocating and initializing the closure itself -- otherwise, we have problems with recursive closure bindings o BlockEnv and BlockSet types are now abstract. o Update frames: - push arguments in Old call area - keep track of the return sp in the FCode monad - keep the return sp in every call, tail call, and return (because it might be different at different call sites, e.g. tail calls to the gc after a heap check are performed before pushing the update frame) - set the sp appropriately on returns and tail calls o Reduce call, tail call, and return to a single LastCall node o Added slow entry code, using different calling conventions on entry and tail call o More fixes to the calling convention code. The tricky stuff is all about the closure environment: it must be passed in R1, but in non-closures, there is no such argument, so we can't treat all arguments the same way: the closure environment is special. Maybe the right step forward would be to define a different calling convention for closure arguments. o Let-no-escapes need to be emitted out-of-line -- otherwise, we drop code. o Respect RTS requirement of word alignment for pointers My stack allocation can pack sub-word values into a single word on the stack, but it wasn't requiring word-alignment for pointers. It does now, by word-aligning both pointer registers and call areas. o CmmLint was over-aggresively ruling out non-word-aligned memory references, which may be kosher now that we can spill small values into a single word. o Wrong label order on a conditional branch when compiling switches. o void args weren't dropped in many cases. To help prevent this kind of mistake, I defined a NonVoid wrapper, which I'm applying only to Id's for now, although there are probably other good candidates. o A little code refactoring: separate modules for procpoint analysis splitting, stack layout, and building infotables. o Stack limit check: insert along with the heap limit check, using a symbolic constant (a special CmmLit), then replace it when the stack layout is known. o Removed last node: MidAddToContext o Adding block id as a literal: means that the lowering of the calling conventions no longer has to produce labels early, which was inhibiting common-block elimination. Will also make it easier for the non-procpoint-splitting path. o Info tables: don't try to describe the update frame! o Over aggressive use of NonVoid!!!! Don't drop the non-void args before setting the type of the closure!!! o Sanity checking: Added a pass to stub dead dead slots on the stack (only ~10 lines with the dataflow framework) o More sanity checking: Check that incoming pointer arguments are non-stubbed. Note: these checks are still subject to dead-code removal, but they should still be quite helpful. o Better sanity checking: why stop at function arguments? Instead, in mkAssign, check that _any_ assignment to a pointer type is non-null -- the sooner the crash, the easier it is to debug. Still need to add the debugging flag to turn these checks on explicitly. o Fixed yet another calling convention bug. This time, the calls to the GC were wrong. I've added a new convention for GC calls and invoked it where appropriate. We should really straighten out the calling convention stuff: some of the code (and documentation) is spread across the compiler, and there's some magical use of the node register that should really be handled (not avoided) by calling conventions. o Switch bug: the arms in mkCmmLitSwitch weren't returning to a single join point. o Environment shadowing problem in Stg->Cmm: When a closure f is bound at the top-level, we should not bind f to the node register on entry to the closure. Why? Because if the body of f contains a let-bound closure g that refers to f, we want to make sure that it refers to the static closure for f. Normally, this would all be fine, because when we compile a closure, we rebind free variables in the environment. But f doesn't look like a free variable because it's a static value. So, the binding for f remains in the environment when we compile g, inconveniently referring to the wrong thing. Now, I bind the variable in the local environment only if the closure is not bound at the top level. It's still okay to make assumptions about the node holding the closure environment; we just won't find the binding in the environment, so code that names the closure will now directly get the label of the static closure, not the node register holding a pointer to the static closure. o Don't generate bogus Cmm code containing SRTs during the STG -> Cmm pass! The tables made reference to some labels that don't exist when we compute and generate the tables in the back end. o Safe foreign calls need some special treatment (at least until we have the integrated codegen). In particular: o they need info tables o they are not procpoints -- the successor had better be in the same procedure o we cannot (yet) implement the calling conventions early, which means we have to carry the calling-conv info all the way to the end o We weren't following the old convention when registering a module. Now, we use update frames to push any new modules that have to be registered and enter the youngest one on the stack. We also use the update frame machinery to specify that the return should pop the return address off the stack. o At each safe foreign call, an infotable must be at the bottom of the stack, and the TSO->sp must point to it. o More problems with void args in a direct call to a function: We were checking the args (minus voids) to check whether the call was saturated, which caused problems when the function really wasn't saturated because it took an extra void argument. o Forgot to distinguish integer != from floating != during Stg->Cmm o Updating slotEnv and areaMap to include safe foreign calls The dataflow analyses that produce the slotEnv and areaMap give results for each basic block, but we also need the results for a safe foreign call, which is a middle node. After running the dataflow analysis, we have another pass that updates the results to includ any safe foreign calls. o Added a static flag for the debugging technique that inserts instructions to stub dead slots on the stack and crashes when a stubbed value is loaded into a pointer-typed LocalReg. o C back end expects to see return continuations before their call sites. Sorted the flowgraphs appropriately after splitting. o PrimOp calling conventions are special -- unlimited registers, no stack Yet another calling convention... o More void value problems: if the RHS of a case arm is a void-typed variable, don't try to return it. o When calling some primOp, they may allocate memory; if so, we need to do a heap check when we return from the call. --- compiler/cmm/BlockId.hs | 130 +++++-- compiler/cmm/CLabel.hs | 20 +- compiler/cmm/Cmm.hs | 10 +- compiler/cmm/CmmBrokenBlock.hs | 2 +- compiler/cmm/CmmCPS.hs | 23 +- compiler/cmm/CmmCPSZ.hs | 100 +++-- compiler/cmm/CmmCallConv.hs | 79 ++-- compiler/cmm/CmmCommonBlockElimZ.hs | 91 +++-- compiler/cmm/CmmContFlowOpt.hs | 82 ++-- compiler/cmm/CmmCvt.hs | 49 ++- compiler/cmm/CmmExpr.hs | 37 +- compiler/cmm/CmmInfo.hs | 25 +- compiler/cmm/CmmLint.hs | 12 +- compiler/cmm/CmmLive.hs | 22 +- compiler/cmm/CmmLiveZ.hs | 40 +- compiler/cmm/CmmOpt.hs | 3 +- compiler/cmm/CmmParse.y | 14 +- compiler/cmm/CmmProcPoint.hs | 16 +- compiler/cmm/CmmProcPointZ.hs | 685 ++++++---------------------------- compiler/cmm/CmmSpillReload.hs | 139 +++---- compiler/cmm/CmmZipUtil.hs | 3 +- compiler/cmm/DFMonad.hs | 7 +- compiler/cmm/MkZipCfg.hs | 62 +-- compiler/cmm/MkZipCfgCmm.hs | 150 +++++--- compiler/cmm/OptimizationFuel.hs | 5 +- compiler/cmm/PprC.hs | 8 + compiler/cmm/PprCmm.hs | 26 +- compiler/cmm/PprCmmZ.hs | 22 +- compiler/cmm/StackColor.hs | 4 +- compiler/cmm/ZipCfg.hs | 82 ++-- compiler/cmm/ZipCfgCmmRep.hs | 237 ++++++------ compiler/cmm/ZipCfgExtras.hs | 4 +- compiler/cmm/ZipDataflow.hs | 77 ++-- compiler/codeGen/CgInfoTbls.hs | 6 +- compiler/codeGen/StgCmm.hs | 81 ++-- compiler/codeGen/StgCmmBind.hs | 320 +++++++++------- compiler/codeGen/StgCmmClosure.hs | 71 ++-- compiler/codeGen/StgCmmCon.hs | 26 +- compiler/codeGen/StgCmmEnv.hs | 71 ++-- compiler/codeGen/StgCmmExpr.hs | 126 ++++--- compiler/codeGen/StgCmmForeign.hs | 129 +++---- compiler/codeGen/StgCmmHeap.hs | 132 ++++--- compiler/codeGen/StgCmmLayout.hs | 112 ++++-- compiler/codeGen/StgCmmMonad.hs | 103 +++-- compiler/codeGen/StgCmmPrim.hs | 8 +- compiler/codeGen/StgCmmProf.hs | 5 +- compiler/codeGen/StgCmmUtils.hs | 42 ++- compiler/ghc.cabal.in | 2 + compiler/main/HscMain.lhs | 26 +- compiler/main/StaticFlagParser.hs | 1 + compiler/main/StaticFlags.hs | 3 + compiler/nativeGen/MachRegs.lhs | 2 + compiler/nativeGen/PprMach.hs | 2 +- compiler/nativeGen/RegAllocLinear.hs | 15 +- compiler/nativeGen/RegLiveness.hs | 30 +- compiler/nativeGen/RegSpillCost.hs | 3 +- 56 files changed, 1814 insertions(+), 1768 deletions(-) diff --git a/compiler/cmm/BlockId.hs b/compiler/cmm/BlockId.hs index 2e4d452..01ddcd2 100644 --- a/compiler/cmm/BlockId.hs +++ b/compiler/cmm/BlockId.hs @@ -1,12 +1,18 @@ module BlockId ( BlockId(..), mkBlockId -- ToDo: BlockId should be abstract, but it isn't yet - , BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv, mkBlockEnv, mapBlockEnv - , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet, sizeBlockSet, mkBlockSet - , foldBlockEnv, blockLbl, infoTblLbl + , 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 + , blockLbl, infoTblLbl, retPtLbl ) where import CLabel import IdInfo +import Maybes import Name import Outputable import UniqFM @@ -21,15 +27,15 @@ import UniqSet Although a 'BlockId' is a local label, for reasons of implementation, 'BlockId's must be unique within an entire compilation unit. The reason is that each local label is mapped to an assembly-language label, and in -most assembly languages allow, a label is visible throughout the enitre +most assembly languages allow, a label is visible throughout the entire compilation unit in which it appears. -} -newtype BlockId = BlockId Unique +data BlockId = BlockId Unique deriving (Eq,Ord) instance Uniquable BlockId where - getUnique (BlockId u) = u + getUnique (BlockId id) = id mkBlockId :: Unique -> BlockId mkBlockId uniq = BlockId uniq @@ -38,36 +44,116 @@ instance Show BlockId where show (BlockId u) = show u instance Outputable BlockId where - ppr = ppr . getUnique + ppr (BlockId id) = ppr id + +retPtLbl :: BlockId -> CLabel +retPtLbl (BlockId id) = mkReturnPtLabel id blockLbl :: BlockId -> CLabel -blockLbl id = mkEntryLabel (mkFCallName (getUnique id) "block") NoCafRefs +blockLbl (BlockId id) = mkEntryLabel (mkFCallName id "block") NoCafRefs infoTblLbl :: BlockId -> CLabel -infoTblLbl id = mkInfoTableLabel (mkFCallName (getUnique id) "block") NoCafRefs +infoTblLbl (BlockId id) = mkInfoTableLabel (mkFCallName id "block") NoCafRefs + +-- Block environments: Id blocks +newtype BlockEnv a = BlockEnv (UniqFM {- id -} a) -type BlockEnv a = UniqFM {- BlockId -} 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 = emptyUFM +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 = listToUFM +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 = lookupUFM +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 = addToUFM +extendBlockEnv (BlockEnv env) (BlockId id) x = BlockEnv (addToUFM env id x) + mapBlockEnv :: (a -> b) -> BlockEnv a -> BlockEnv b -mapBlockEnv = mapUFM +mapBlockEnv f (BlockEnv env) = BlockEnv (mapUFM f env) + foldBlockEnv :: (BlockId -> a -> b -> b) -> b -> BlockEnv a -> b -foldBlockEnv f = foldUFM_Directly (\u x y -> f (mkBlockId u) x y) +foldBlockEnv f b (BlockEnv env) = + foldUFM_Directly (\u x y -> f (mkBlockId u) x y) b env + +foldBlockEnv' :: (a -> b -> b) -> b -> BlockEnv a -> b +foldBlockEnv' f b (BlockEnv env) = foldUFM f b env + +plusBlockEnv :: BlockEnv elt -> BlockEnv elt -> BlockEnv elt +plusBlockEnv (BlockEnv x) (BlockEnv y) = BlockEnv (plusUFM x y) + +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 + -type BlockSet = UniqSet BlockId emptyBlockSet :: BlockSet -emptyBlockSet = emptyUniqSet +emptyBlockSet = BlockSet emptyUniqSet + +isEmptyBlockSet :: BlockSet -> Bool +isEmptyBlockSet (BlockSet s) = isEmptyUniqSet s + +unitBlockSet :: BlockId -> BlockSet +unitBlockSet = extendBlockSet emptyBlockSet + elemBlockSet :: BlockId -> BlockSet -> Bool -elemBlockSet = elementOfUniqSet +elemBlockSet (BlockId id) (BlockSet set) = elementOfUniqSet id set + extendBlockSet :: BlockSet -> BlockId -> BlockSet -extendBlockSet = addOneToUniqSet +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 = mkUniqSet +mkBlockSet = foldl extendBlockSet emptyBlockSet + +unionBlockSets :: BlockSet -> BlockSet -> BlockSet +unionBlockSets (BlockSet s) (BlockSet s') = BlockSet (unionUniqSets s s') + sizeBlockSet :: BlockSet -> Int -sizeBlockSet = sizeUniqSet +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 diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs index ffa93fb..aa72b65 100644 --- a/compiler/cmm/CLabel.hs +++ b/compiler/cmm/CLabel.hs @@ -107,7 +107,7 @@ module CLabel ( mkHpcModuleNameLabel, hasCAF, - infoLblToEntryLbl, entryLblToInfoLbl, + infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl, needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel, isMathFun, isCFunctionLabel, isGcPtrLabel, labelDynamic, @@ -458,11 +458,23 @@ entryLblToInfoLbl (RtsLabel (RtsEntryFS s)) = RtsLabel (RtsInfoFS s) entryLblToInfoLbl (RtsLabel (RtsRetFS s)) = RtsLabel (RtsRetInfoFS s) entryLblToInfoLbl l = pprPanic "CLabel.entryLblToInfoLbl" (pprCLabel l) +cvtToClosureLbl (IdLabel n c InfoTable) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c Entry) = IdLabel n c Closure +cvtToClosureLbl (IdLabel n c ConEntry) = IdLabel n c Closure +cvtToClosureLbl l@(IdLabel n c Closure) = l +cvtToClosureLbl l = pprPanic "cvtToClosureLbl" (pprCLabel l) + +cvtToSRTLbl (IdLabel n c InfoTable) = mkSRTLabel n c +cvtToSRTLbl (IdLabel n c Entry) = mkSRTLabel n c +cvtToSRTLbl (IdLabel n c ConEntry) = mkSRTLabel n c +cvtToSRTLbl l@(IdLabel n c Closure) = mkSRTLabel n c +cvtToSRTLbl l = pprPanic "cvtToSRTLbl" (pprCLabel l) + -- ----------------------------------------------------------------------------- -- Does a CLabel refer to a CAF? hasCAF :: CLabel -> Bool -hasCAF (IdLabel _ MayHaveCafRefs Closure) = True -hasCAF _ = False +hasCAF (IdLabel _ MayHaveCafRefs _) = True +hasCAF _ = False -- ----------------------------------------------------------------------------- -- Does a CLabel need declaring before use or not? @@ -823,7 +835,7 @@ pprCLbl ModuleRegdLabel pprCLbl (ForeignLabel str _ _) = ftext str -pprCLbl (IdLabel name _ flavor) = ppr name <> ppIdFlavor flavor +pprCLbl (IdLabel name cafs flavor) = ppr name <> ppIdFlavor flavor pprCLbl (CC_Label cc) = ppr cc pprCLbl (CCS_Label ccs) = ppr ccs diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs index 5e52a57..2ee259c 100644 --- a/compiler/cmm/Cmm.hs +++ b/compiler/cmm/Cmm.hs @@ -13,7 +13,8 @@ module Cmm ( cmmMapGraph, cmmTopMapGraph, cmmMapGraphM, cmmTopMapGraphM, CmmInfo(..), UpdateFrame(..), - CmmInfoTable(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag, + CmmInfoTable(..), HasStaticClosure, ClosureTypeInfo(..), ConstrDescription, + ProfilingInfo(..), ClosureTypeTag, GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts, mapBlockStmts, CmmReturnInfo(..), CmmStmt(..), CmmActual, CmmActuals, CmmFormal, CmmFormals, @@ -137,7 +138,8 @@ 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 f (CmmProc h l args g) = + f (showSDoc $ ppr l) g >>= return . CmmProc h l args cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds ----------------------------------------------------------------------------- @@ -147,17 +149,21 @@ cmmTopMapGraphM _ (CmmData s ds) = return $ CmmData s ds 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. diff --git a/compiler/cmm/CmmBrokenBlock.hs b/compiler/cmm/CmmBrokenBlock.hs index ffb7f02..851f008 100644 --- a/compiler/cmm/CmmBrokenBlock.hs +++ b/compiler/cmm/CmmBrokenBlock.hs @@ -420,4 +420,4 @@ cmmBlockFromBrokenBlock (BrokenBlock ident _ stmts _ exit) = ----------------------------------------------------------------------------- -- | Build a mapping so we can lookup a 'BrokenBlock' by its 'BlockId' blocksToBlockEnv :: [BrokenBlock] -> BlockEnv BrokenBlock -blocksToBlockEnv blocks = listToUFM $ map (\b -> (brokenBlockId b, b)) blocks +blocksToBlockEnv blocks = mkBlockEnv $ map (\b -> (brokenBlockId b, b)) blocks diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs index f00a93c..acdd2a6 100644 --- a/compiler/cmm/CmmCPS.hs +++ b/compiler/cmm/CmmCPS.hs @@ -219,7 +219,7 @@ collectNonProcPointTargets proc_points blocks current_targets new_blocks = new_targets (map (:[]) targets) where - blocks' = map (lookupWithDefaultUFM blocks (panic "TODO")) new_blocks + 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, @@ -241,8 +241,8 @@ 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 = lookupWithDefaultUFM blocks unknown_block start - children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children) + start_block = lookupWithDefaultBEnv blocks unknown_block start + children_blocks = map (lookupWithDefaultBEnv blocks unknown_block) (uniqSetToList children) unknown_block = panic "unknown block in gatherBlocksIntoContinuation" body = start_block : children_blocks @@ -268,7 +268,7 @@ gatherBlocksIntoContinuation live proc_points blocks start = ContinuationEntry args _ _ -> args ControlEntry -> uniqSetToList $ - lookupWithDefaultUFM live unknown_block start + lookupWithDefaultBEnv live unknown_block start -- it's a proc-point, pass lives in parameter registers -------------------------------------------------------------------------------- @@ -282,7 +282,7 @@ selectContinuationFormat live continuations = where -- User written continuations selectContinuationFormat' (Continuation - (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt)))) + (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format srt)))) label formals _ _) = (formals, Just label, format) -- Either user written non-continuation code @@ -296,7 +296,7 @@ selectContinuationFormat live continuations = in (formals, Just label, map Just $ uniqSetToList $ - lookupWithDefaultUFM live unknown_block ident) + lookupWithDefaultBEnv live unknown_block ident) unknown_block = panic "unknown BlockId in selectContinuationFormat" @@ -388,10 +388,11 @@ applyContinuationFormat :: [(CLabel, ContinuationFormat)] -> Continuation CmmInfo -- User written continuations -applyContinuationFormat formats (Continuation - (Right (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo _ srt)))) - label formals is_gc blocks) = - Continuation (CmmInfo gc update_frame (CmmInfoTable prof tag (ContInfo format srt))) +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 @@ -405,7 +406,7 @@ applyContinuationFormat formats (Continuation -- CPS generated continuations applyContinuationFormat formats (Continuation (Left srt) label formals is_gc blocks) = - Continuation (CmmInfo gc Nothing (CmmInfoTable prof tag (ContInfo (continuation_stack $ format) srt))) + 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 diff --git a/compiler/cmm/CmmCPSZ.hs b/compiler/cmm/CmmCPSZ.hs index d8c9560..6dcc5c5 100644 --- a/compiler/cmm/CmmCPSZ.hs +++ b/compiler/cmm/CmmCPSZ.hs @@ -5,36 +5,59 @@ module CmmCPSZ ( 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 FiniteMap import HscTypes +import Maybe import Monad 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 - -> CmmZ -- Input C-- with Proceedures - -> IO CmmZ -- Output CPS transformed C-- -protoCmmCPSZ hsc_env (Cmm tops) + -> (TopSRT, [CmmZ]) -- SRT table and + -> CmmZ -- Input C-- with Procedures + -> IO (TopSRT, [CmmZ]) -- Output CPS transformed C-- +protoCmmCPSZ hsc_env (topSRT, rst) (Cmm tops) | not (dopt Opt_RunCPSZ (hsc_dflags hsc_env)) - = return (Cmm tops) -- Only if -frun-cps + = return (topSRT, Cmm tops : rst) -- Only if -frun-cps | otherwise = do let dflags = hsc_dflags hsc_env showPass dflags "CPSZ" - tops <- liftM concat $ mapM (cpsTop hsc_env) tops - dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "Post CPS Cmm" (ppr (Cmm tops)) - return $ Cmm tops + (cafEnvs, toTops) <- liftM unzip $ mapM (cpsTop hsc_env) tops + let topCAFEnv = mkTopCAFInfo (concat cafEnvs) + (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] ~~~~~~~~~~~~~~~~~~~~~ @@ -43,44 +66,75 @@ mutable reference cells in an 'HscEnv' and are global to one compiler session. -} -cpsTop :: HscEnv -> CmmTopZ -> IO [CmmTopZ] -cpsTop _ p@(CmmData {}) = return [p] +cpsTop :: HscEnv -> CmmTopZ -> + IO ([(CLabel, CAFSet)], + (FiniteMap CLabel CAFSet -> (TopSRT, [[CmmTopZ]]) -> IO (TopSRT, [[CmmTopZ]]))) +cpsTop _ p@(CmmData {}) = + return ([], (\ _ (topSRT, tops) -> return (topSRT, [p] : tops))) cpsTop hsc_env (CmmProc h l args g) = - do dump Opt_D_dump_cmmz "Pre Proc Points Added" g + do + dump Opt_D_dump_cmmz "Pre Proc Points Added" g let callPPs = callProcPoints g g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" (dualLivenessWithInsertion callPPs) g + 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 procPoints <- run $ minimalProcPointSet callPPs g - print $ "call procPoints: " ++ (showSDoc $ ppr procPoints) + -- print $ "call procPoints: " ++ (showSDoc $ ppr procPoints) g <- run $ addProcPointProtocols callPPs procPoints g dump Opt_D_dump_cmmz "Post Proc Points Added" g g <- dual_rewrite Opt_D_dump_cmmz "spills and reloads" (dualLivenessWithInsertion procPoints) g -- Insert spills at defns; reloads at return points - g <- run $ insertLateReloads' g -- Duplicate reloads just before uses + g <- run $ insertLateReloads g -- Duplicate reloads just before uses dump Opt_D_dump_cmmz "Post late reloads" g g <- dual_rewrite Opt_D_dump_cmmz "Dead Assignment Elimination" (removeDeadAssignmentsAndReloads procPoints) g -- Remove redundant reloads (and any other redundant asst) + -- Debugging: stubbing slots on death can cause crashes early + g <- if opt_StubDeadValues then run $ stubSlotsOnDeath g else return g + mbpprTrace "graph before procPointMap: " (ppr g) $ return () + procPointMap <- run $ procPointAnalysis procPoints g slotEnv <- run $ liveSlotAnal g - print $ "live slot analysis results: " ++ (showSDoc $ ppr slotEnv) + mbpprTrace "live slot analysis results: " (ppr slotEnv) $ return () cafEnv <- run $ cafAnal g - print $ "live CAF analysis results: " ++ (showSDoc $ ppr cafEnv) - slotIGraph <- return $ igraph areaBuilder slotEnv g - print $ "slot IGraph: " ++ (showSDoc $ ppr slotIGraph) - print $ "graph before procPointMap: " ++ (showSDoc $ ppr g) - procPointMap <- run $ procPointAnalysis procPoints g + (cafEnv, slotEnv) <- return $ extendEnvsForSafeForeignCalls cafEnv slotEnv g + mbpprTrace "slotEnv extended for safe foreign calls: " (ppr slotEnv) $ return () let areaMap = layout procPoints slotEnv g + mbpprTrace "areaMap" (ppr areaMap) $ return () g <- run $ manifestSP procPoints procPointMap areaMap g - procPointMap <- run $ procPointAnalysis procPoints g - gs <- run $ splitAtProcPoints l callPPs procPoints procPointMap slotEnv areaMap - (CmmProc h l args g) - return gs - --return $ [CmmProc h l args (runTx cmmCfgOptsZ 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... + procPointMap <- run $ procPointAnalysis procPoints g + gs <- pprTrace "procPointMap" (ppr procPointMap) $ + run $ splitAtProcPoints l callPPs procPoints procPointMap areaMap + (CmmProc h l args g) + mapM (dump Opt_D_dump_cmmz "after splitting") gs + let localCAFs = catMaybes $ map (localCAFInfo cafEnv) gs + mbpprTrace "localCAFs" (ppr localCAFs) $ return () + gs <- liftM concat $ run $ foldM (lowerSafeForeignCalls procPoints) [] 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' + -- Return: (a) CAFs used by this proc (b) a closure that will compute + -- a new SRT for the procedure. + let toTops topCAFEnv (topSRT, tops) = + do let setSRT (topSRT, rst) g = + do (topSRT, gs) <- setInfoTableSRT cafEnv topCAFEnv topSRT g + return (topSRT, gs : rst) + (topSRT, gs') <- run $ foldM setSRT (topSRT, []) gs' + gs' <- mapM finishInfoTables (concat gs') + pprTrace "localCAFs" (ppr localCAFs <+> ppr topSRT) $ + return (topSRT, concat gs' : tops) + return (localCAFs, toTops) 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 = diff --git a/compiler/cmm/CmmCallConv.hs b/compiler/cmm/CmmCallConv.hs index 5476eb8..fa619af 100644 --- a/compiler/cmm/CmmCallConv.hs +++ b/compiler/cmm/CmmCallConv.hs @@ -17,6 +17,7 @@ module CmmCallConv ( import Cmm import SMRep +import ZipCfgCmmRep (Convention(..)) import Constants import StaticFlags (opt_Unregisterised) @@ -30,36 +31,48 @@ data ParamLocation a = RegisterParam GlobalReg | StackParam a +instance (Outputable a) => Outputable (ParamLocation a) where + ppr (RegisterParam g) = ppr g + ppr (StackParam p) = ppr p + type ArgumentFormat a b = [(a, ParamLocation b)] -- Stack parameters are returned as word offsets. assignArguments :: (a -> CmmType) -> [a] -> ArgumentFormat a WordOff assignArguments f reps = assignments where + availRegs = getRegs False (sizes, assignments) = unzip $ assignArguments' reps (negate (sum sizes)) availRegs assignArguments' [] offset availRegs = [] assignArguments' (r:rs) offset availRegs = (size,(r,assignment)):assignArguments' rs new_offset remaining where (assignment, new_offset, size, remaining) = - assign_reg False assign_slot_up (f r) offset availRegs + assign_reg assign_slot_neg (f r) offset availRegs -- | JD: For the new stack story, I want arguments passed on the stack to manifest as -- positive offsets in a CallArea, not negative offsets from the stack pointer. -- Also, I want byte offsets, not word offsets. -- The first argument tells us whether we are assigning positions for call arguments --- or return results. The distinction matters because we reserve different --- global registers in each case. -assignArgumentsPos :: Bool -> (a -> CmmType) -> [a] -> ArgumentFormat a ByteOff -assignArgumentsPos isCall arg_ty reps = map cvt assignments +-- or return results. The distinction matters because some conventions use different +-- global registers in each case. In particular, the native calling convention +-- uses the `node' register to pass the closure environment. +assignArgumentsPos :: (Outputable a) => Convention -> Bool -> (a -> CmmType) -> [a] -> + ArgumentFormat a ByteOff +assignArgumentsPos conv isCall arg_ty reps = map cvt assignments where - (sizes, assignments) = unzip $ assignArguments' reps 0 availRegs + regs = case conv of Native -> getRegs isCall + GC -> getRegs False + PrimOp -> noStack + Slow -> noRegs + _ -> panic "unrecognized calling convention" + (sizes, assignments) = unzip $ assignArguments' reps (sum sizes) regs assignArguments' [] _ _ = [] assignArguments' (r:rs) offset avails = - (size,(r,assignment)):assignArguments' rs new_offset remaining + (size, (r,assignment)):assignArguments' rs new_offset remaining where (assignment, new_offset, size, remaining) = - assign_reg isCall assign_slot_down (arg_ty r) offset avails + assign_reg assign_slot_pos (arg_ty r) offset avails cvt (l, RegisterParam r) = (l, RegisterParam r) cvt (l, StackParam off) = (l, StackParam $ off * wORD_SIZE) @@ -94,12 +107,18 @@ useDoubleRegs | opt_Unregisterised = 0 useLongRegs | opt_Unregisterised = 0 | otherwise = mAX_Real_Long_REG -availRegs = (regList VanillaReg useVanillaRegs, - regList FloatReg useFloatRegs, - regList DoubleReg useDoubleRegs, - regList LongReg useLongRegs) +getRegs reserveNode = + (if reserveNode then filter (\r -> r VGcPtr /= node) intRegs else intRegs, + regList FloatReg useFloatRegs, + regList DoubleReg useDoubleRegs, + regList LongReg useLongRegs) where regList f max = map f [1 .. max] + intRegs = regList VanillaReg useVanillaRegs + +noStack = (map VanillaReg any, map FloatReg any, map DoubleReg any, map LongReg any) + where any = [1 .. ] +noRegs = ([], [], [], []) -- Round the size of a local register up to the nearest word. slot_size :: LocalReg -> Int @@ -111,37 +130,37 @@ slot_size' reg = ((widthInBytes reg - 1) `div` wORD_SIZE) + 1 type Assignment = (ParamLocation WordOff, WordOff, WordOff, AvailRegs) type SlotAssigner = Width -> Int -> AvailRegs -> Assignment -assign_reg :: Bool -> SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment -assign_reg isCall slot ty off avails - | isFloatType ty = assign_float_reg slot width off avails - | otherwise = assign_bits_reg isCall slot width off gcp avails +assign_reg :: SlotAssigner -> CmmType -> WordOff -> AvailRegs -> Assignment +assign_reg slot ty off avails + | isFloatType ty = assign_float_reg slot width off avails + | otherwise = assign_bits_reg slot width off gcp avails where width = typeWidth ty gcp | isGcPtrType ty = VGcPtr | otherwise = VNonGcPtr --- Assigning a slot on a stack that grows up: +-- Assigning a slot using negative offsets from the stack pointer. -- JD: I don't know why this convention stops using all the registers -- after running out of one class of registers. -assign_slot_up :: SlotAssigner -assign_slot_up width off regs = +assign_slot_neg :: SlotAssigner +assign_slot_neg width off regs = (StackParam $ off, off + size, size, ([], [], [], [])) where size = slot_size' width --- Assigning a slot on a stack that grows down: -assign_slot_down :: SlotAssigner -assign_slot_down width off regs = - (StackParam $ off + size, off + size, size, ([], [], [], [])) +-- Assigning a slot using positive offsets into a CallArea. +assign_slot_pos :: SlotAssigner +assign_slot_pos width off regs = + (StackParam $ off, off - size, size, ([], [], [], [])) where size = slot_size' width --- On calls, `node` is used to hold the closure that is entered, so we can't --- pass arguments in that register. -assign_bits_reg _ _ W128 _ _ _ = panic "I128 is not a supported register type" -assign_bits_reg isCall assign_slot w off gcp regs@(v:vs, fs, ds, ls) = - if isCall && v gcp == node then - assign_bits_reg isCall assign_slot w off gcp (vs, fs, ds, ls) - else if widthInBits w <= widthInBits wordWidth then +-- On calls in the native convention, `node` is used to hold the environment +-- for the closure, so we can't pass arguments in that register. +assign_bits_reg _ W128 _ _ _ = panic "W128 is not a supported register type" +assign_bits_reg assign_slot w off gcp regs@(v:vs, fs, ds, ls) = + if widthInBits w <= widthInBits wordWidth then (RegisterParam (v gcp), off, 0, (vs, fs, ds, ls)) else assign_slot w off regs +assign_bits_reg assign_slot w off gcp regs@([], _, _, _) = + assign_slot w off regs assign_float_reg _ W32 off (vs, f:fs, ds, ls) = (RegisterParam $ f, off, 0, (vs, fs, ds, ls)) assign_float_reg _ W64 off (vs, fs, d:ds, ls) = (RegisterParam $ d, off, 0, (vs, fs, ds, ls)) diff --git a/compiler/cmm/CmmCommonBlockElimZ.hs b/compiler/cmm/CmmCommonBlockElimZ.hs index 2cef222..df15845 100644 --- a/compiler/cmm/CmmCommonBlockElimZ.hs +++ b/compiler/cmm/CmmCommonBlockElimZ.hs @@ -10,8 +10,9 @@ import Prelude hiding (iterate, zip, unzip) import ZipCfg import ZipCfgCmmRep +import Data.Bits +import Data.Word import FastString -import FiniteMap import List hiding (iterate) import Monad import Outputable @@ -19,7 +20,7 @@ import UniqFM import Unique my_trace :: String -> SDoc -> a -> a -my_trace = if True then pprTrace else \_ _ a -> a +my_trace = if False then pprTrace else \_ _ a -> a -- Eliminate common blocks: -- If two blocks are identical except for the label on the first node, @@ -36,7 +37,8 @@ my_trace = if True then pprTrace else \_ _ a -> a -- TODO: Use optimization fuel elimCommonBlocks :: CmmGraph -> CmmGraph elimCommonBlocks g = - upd_graph g . snd $ iterate common_block reset hashed_blocks (emptyUFM, emptyFM) + 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)) reset (_, subst) = (emptyUFM, subst) @@ -49,83 +51,93 @@ iterate upd reset blocks state = where upd' (b, s) a = let (b', s') = upd s a in (b || b', s') -- lift to track changes -- Try to find a block that is equal (or ``common'') to b. -type BidMap = FiniteMap BlockId BlockId +type BidMap = BlockEnv BlockId type State = (UniqFM [CmmBlock], BidMap) common_block :: (Outputable h, Uniquable h) => State -> (h, CmmBlock) -> (Bool, State) common_block (bmap, subst) (hash, b) = - case lookupUFM bmap $ my_trace "common_block" (ppr bid <+> ppr subst <+> ppr hash) $ hash of - Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, lookupFM subst bid) of + case lookupUFM bmap hash of + Just bs -> case (find (eqBlockBodyWith (eqBid subst) b) bs, + lookupBlockEnv subst bid) of (Just b', Nothing) -> addSubst b' (Just b', Just b'') | blockId 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, addToFM subst bid (blockId b'))) + (True, (bmap, extendBlockEnv subst bid (blockId b'))) -- 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 m = m - last (LastBranch bid) = LastBranch $ sub bid - last (LastCondBranch p t f) = cond p (sub t) (sub f) - last (LastCall t bid s) = LastCall t (liftM sub bid) s - last (LastSwitch e bs) = LastSwitch e $ map (liftM sub) bs - last l = l + 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) s u) = LastCall t (Just $ sub bid) s 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 + exp (CmmStackSlot (CallArea (Young id)) off) = + CmmStackSlot (CallArea (Young (sub id))) off + exp (CmmLit (CmmBlock id)) = CmmLit (CmmBlock (sub id)) + exp e = e sub = lookupBid subst -- To speed up comparisons, we hash each basic block modulo labels. -- 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) = hash_tail t 0 - where hash_mid (MidComment (FastString u _ _ _ _)) = u +hash_block (Block _ _ t) = + fromIntegral (hash_tail t (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 (MidUnsafeCall t _ as) = hash_tgt t + hash_lst hash_e as - hash_mid (MidAddToContext e es) = hash_e e + hash_lst hash_e es + hash_mid (MidForeignCall _ t _ as) = hash_tgt t + hash_lst hash_e as + hash_reg :: CmmReg -> Word32 hash_reg (CmmLocal l) = hash_local l 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 (CmmRegOff r i) = hash_reg r + i + hash_e (CmmRegOff r i) = hash_reg r + cvt i hash_e (CmmStackSlot _ _) = 13 + hash_lit :: CmmLit -> Word32 hash_lit (CmmInt i _) = fromInteger i hash_lit (CmmFloat r _) = truncate r hash_lit (CmmLabel _) = 119 -- ugh - hash_lit (CmmLabelOff _ i) = 199 + i - hash_lit (CmmLabelDiffOff _ _ i) = 299 + i + hash_lit (CmmLabelOff _ i) = cvt $ 199 + i + hash_lit (CmmLabelDiffOff _ _ i) = cvt $ 299 + i + hash_lit (CmmBlock id) = 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::Int) + 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 (LastReturn _) = 17 -- better ideas? - hash_last (LastJump e _) = hash_e e - hash_last (LastCall e _ _) = hash_e e + hash_last (LastCall e _ _ _) = hash_e e hash_last (LastSwitch e _) = hash_e e - hash_tail (ZLast LastExit) v = 29 + v * 2 - hash_tail (ZLast (LastOther l)) v = hash_last l + (v * 2) - hash_tail (ZTail m t) v = hash_tail t (hash_mid m + (v * 2)) - + 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)) + cvt = fromInteger . toInteger -- Utilities: equality and substitution on the graph. -- Given a map ``subst'' from BlockID -> BlockID, we define equality. eqBid :: BidMap -> BlockId -> BlockId -> Bool eqBid subst bid bid' = lookupBid subst bid == lookupBid subst bid' lookupBid :: BidMap -> BlockId -> BlockId -lookupBid subst bid = case lookupFM subst bid of +lookupBid subst bid = case lookupBlockEnv subst bid 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 _ Nothing t) (Block _ Nothing t') = eqTailWith eqBid t t' -eqBlockBodyWith _ _ _ = False +eqBlockBodyWith eqBid (Block _ sinfo t) (Block _ sinfo' t') = + sinfo == sinfo' && eqTailWith eqBid t t' type CmmTail = ZTail Middle Last eqTailWith :: (BlockId -> BlockId -> Bool) -> CmmTail -> CmmTail -> Bool @@ -135,16 +147,13 @@ eqTailWith eqBid (ZLast (LastOther l)) (ZLast (LastOther l')) = eqLastWith eqBid eqTailWith _ _ _ = False eqLastWith :: (BlockId -> BlockId -> Bool) -> Last -> Last -> Bool -eqLastWith eqBid (LastBranch bid) (LastBranch bid') = eqBid bid bid' -eqLastWith eqBid c@(LastCondBranch _ _ _) c'@(LastCondBranch _ _ _) = - eqBid (cml_true c) (cml_true c') && eqBid (cml_false c) (cml_false c') -eqLastWith _ (LastReturn s) (LastReturn s') = s == s' -eqLastWith _ (LastJump e s) (LastJump e' s') = e == e' && s == s' -eqLastWith eqBid c@(LastCall _ _ s) c'@(LastCall _ _ s') = - cml_target c == cml_target c' && eqMaybeWith eqBid (cml_cont c) (cml_cont c') && - s == s' -eqLastWith eqBid (LastSwitch e bs) (LastSwitch e' bs') = - e == e' && eqLstWith (eqMaybeWith eqBid) bs bs' +eqLastWith eqBid (LastBranch bid1) (LastBranch bid2) = eqBid bid1 bid2 +eqLastWith eqBid (LastCondBranch c1 t1 f1) (LastCondBranch c2 t2 f2) = + c1 == c2 && eqBid t1 t2 && eqBid f1 f2 +eqLastWith eqBid (LastCall t1 c1 s1 u1) (LastCall t2 c2 s2 u2) = + t1 == t2 && eqMaybeWith eqBid c1 c2 && s1 == s2 && u1 == u2 +eqLastWith eqBid (LastSwitch e1 bs1) (LastSwitch e2 bs2) = + e1 == e2 && eqLstWith (eqMaybeWith eqBid) bs1 bs2 eqLastWith _ _ _ = False eqLstWith :: (a -> b -> Bool) -> [a] -> [b] -> Bool diff --git a/compiler/cmm/CmmContFlowOpt.hs b/compiler/cmm/CmmContFlowOpt.hs index 320b1e7..a3239b9 100644 --- a/compiler/cmm/CmmContFlowOpt.hs +++ b/compiler/cmm/CmmContFlowOpt.hs @@ -2,7 +2,7 @@ module CmmContFlowOpt ( runCmmOpts, cmmCfgOpts, cmmCfgOptsZ , branchChainElimZ, removeUnreachableBlocksZ, predMap - , replaceLabelsZ, runCmmContFlowOptsZs + , replaceLabelsZ, replaceBranches, runCmmContFlowOptsZs ) where @@ -19,7 +19,6 @@ import Outputable import Panic import Prelude hiding (unzip, zip) import Util -import UniqFM ------------------------------------ runCmmContFlowOptsZs :: [CmmZ] -> [CmmZ] @@ -31,7 +30,8 @@ cmmCfgOpts :: Tx (ListGraph CmmStmt) cmmCfgOptsZ :: Tx CmmGraph cmmCfgOpts = branchChainElim -- boring, but will get more exciting later -cmmCfgOptsZ = branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ +cmmCfgOptsZ g = + (branchChainElimZ `seqTx` blockConcatZ `seqTx` removeUnreachableBlocksZ) g -- Here branchChainElim can ultimately be replaced -- with a more exciting combination of optimisations @@ -89,16 +89,19 @@ branchChainElimZ g@(G.LGraph eid args _) (lone_branch_blocks, others) = partitionWith isLoneBranchZ (G.to_block_list g) env = mkClosureBlockEnvZ lone_branch_blocks self_branches = - let loop_to (id, _) = - if lookup id == id then - Just (G.Block id Nothing (G.ZLast (G.mkBranchNode id))) - else - Nothing - in mapMaybe loop_to lone_branch_blocks + let loop_to (id, _) = + if lookup id == id then + Just (G.Block id emptyStackInfo (G.ZLast (G.mkBranchNode id))) + else + Nothing + in mapMaybe loop_to lone_branch_blocks lookup id = lookupBlockEnv env id `orElse` id +-- Be careful not to mark a block as a lone branch if it carries +-- important information about incoming arguments or the update frame. isLoneBranchZ :: CmmBlock -> Either (BlockId, BlockId) CmmBlock -isLoneBranchZ (G.Block id Nothing (G.ZLast (G.LastOther (LastBranch target)))) +isLoneBranchZ (G.Block id (StackInfo {argBytes = Nothing, returnOff = Nothing}) + (G.ZLast (G.LastOther (LastBranch target)))) | id /= target = Left (id,target) isLoneBranchZ other = Right other -- An infinite loop is not a link in a branch chain! @@ -107,27 +110,25 @@ replaceLabelsZ :: BlockEnv BlockId -> CmmGraph -> CmmGraph replaceLabelsZ env = replace_eid . G.map_nodes id middle last where replace_eid (G.LGraph eid off blocks) = G.LGraph (lookup eid) off blocks - middle m@(MidComment _) = m - middle (MidAssign r e) = MidAssign r (exp e) - middle (MidStore addr e) = MidStore (exp addr) (exp e) - middle (MidUnsafeCall tgt fs as) = MidUnsafeCall (midcall tgt) fs (map exp as) - middle (MidAddToContext e es) = MidAddToContext (exp e) (map exp es) - last (LastBranch id) = LastBranch (lookup id) - last (LastCondBranch e ti fi) = LastCondBranch (exp e) (lookup ti) (lookup fi) - last (LastSwitch e tbl) = LastSwitch (exp e) (map (fmap lookup) tbl) - last (LastCall tgt mb_id s) = LastCall (exp tgt) (fmap lookup mb_id) s - last (LastJump e s) = LastJump (exp e) s - last (LastReturn s) = LastReturn s - midcall (ForeignTarget e c) = ForeignTarget (exp e) c - midcall m@(PrimTarget _) = m - exp e@(CmmLit _) = e - exp (CmmLoad addr ty) = CmmLoad (exp addr) ty - exp e@(CmmReg _) = e - exp (CmmMachOp op es) = CmmMachOp op $ map exp es - exp e@(CmmRegOff _ _) = e + middle = mapExpDeepMiddle exp + last l = mapExpDeepLast exp (last' 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 r) = LastCall t (liftM lookup k) a r + exp (CmmLit (CmmBlock bid)) = CmmLit (CmmBlock (lookup bid)) exp (CmmStackSlot (CallArea (Young id)) i) = CmmStackSlot (CallArea (Young (lookup id))) i - exp e@(CmmStackSlot _ _) = e + exp e = e + lookup id = fmap lookup (lookupBlockEnv env id) `orElse` id + +replaceBranches :: BlockEnv BlockId -> CmmGraph -> CmmGraph +replaceBranches env g = map_nodes 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 ---------------------------------------------------------------- @@ -146,35 +147,38 @@ predMap g = G.fold_blocks add_preds emptyBlockEnv g -- find the back edges -- Order matters, so we work bottom up (reverse postorder DFS). -- -- 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 --- (except an adjacent stack pointer adjustment, which we expect and also eliminate). --- For +-- 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 off blocks) = - tx $ pprTrace "concatMap" (ppr concatMap) $ replaceLabelsZ concatMap $ G.LGraph eid off blocks' + tx $ replaceLabelsZ concatMap $ G.LGraph eid off 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')) -> - if num_preds b' == 1 then + if canConcatWith b' then (True, extendBlockEnv blocks' bid $ splice blocks' h b', extendBlockEnv concatMap b' bid) else unchanged _ -> unchanged num_preds bid = liftM sizeBlockSet (lookupBlockEnv backEdges bid) `orElse` 0 + canConcatWith b' = + case lookupBlockEnv blocks b' of + Just (G.Block _ (StackInfo {returnOff = Nothing}) _) -> num_preds b' == 1 + _ -> False backEdges = predMap g splice blocks' h bid' = case lookupBlockEnv blocks' bid' of - Just (G.Block _ Nothing t) -> G.zip $ G.ZBlock h t - Just (G.Block _ (Just _) _) -> + Just (G.Block _ (StackInfo {returnOff = Nothing}) t) -> + G.zip $ G.ZBlock h t + Just (G.Block _ _ _) -> panic "trying to concatenate but successor block has incoming args" - Nothing -> panic "unknown successor block" + Nothing -> pprPanic "unknown successor block" (ppr bid' <+> ppr blocks' <+> ppr blocks) tx = if changed then aTx else noTx ---------------------------------------------------------------- mkClosureBlockEnv :: [(BlockId, BlockId)] -> BlockEnv BlockId @@ -194,6 +198,6 @@ mkClosureBlockEnvZ blocks = mkBlockEnv $ map follow blocks ---------------------------------------------------------------- removeUnreachableBlocksZ :: Tx CmmGraph removeUnreachableBlocksZ g@(G.LGraph id off blocks) = - if length blocks' < sizeUFM blocks then aTx $ G.of_block_list id off blocks' - else noTx g + if length blocks' < sizeBEnv blocks then aTx $ G.of_block_list id off blocks' + else noTx g where blocks' = G.postorder_dfs g diff --git a/compiler/cmm/CmmCvt.hs b/compiler/cmm/CmmCvt.hs index 0f0ccd2..3484ed6 100644 --- a/compiler/cmm/CmmCvt.hs +++ b/compiler/cmm/CmmCvt.hs @@ -5,13 +5,12 @@ module CmmCvt where import BlockId -import ClosureInfo (C_SRT(..)) import Cmm import CmmExpr import MkZipCfgCmm hiding (CmmGraph) +import ZipCfg -- imported for reverse conversion import ZipCfgCmmRep -- imported for reverse conversion import CmmZipUtil -import ForeignCall import PprCmm() import qualified ZipCfg as G @@ -19,7 +18,6 @@ import FastString import Monad import Outputable import Panic -import UniqSet import UniqSupply import Maybe @@ -39,18 +37,23 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = let (offset, entry) = mkEntry id Native args in labelAGraph id offset $ entry <*> mkStmts ss <*> foldr addBlock emptyAGraph other_blocks - where addBlock (BasicBlock id ss) g = mkLabel id Nothing <*> mkStmts ss <*> g + where addBlock (BasicBlock id ss) g = + mkLabel id emptyStackInfo <*> mkStmts ss <*> g + updfr_sz = 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 srt) CmmMayReturn : ss) = - mkCall f conv (map hintlessCmm res) (map hintlessCmm args) srt <*> mkStmts ss + mkCall f conv' (map hintlessCmm res) (map hintlessCmm args) updfr_sz + <*> mkStmts ss + where conv' = Foreign (ForeignConvention conv [] []) -- JD: DUBIOUS mkStmts (CmmCall (CmmPrim {}) _ _ (CmmSafe _) _ : _) = panic "safe call to a primitive CmmPrim CallishMachOp" mkStmts (CmmCall f res args CmmUnsafe CmmMayReturn : ss) = mkUnsafeCall (convert_target f res args) - (strip_hints res) (strip_hints args) <*> mkStmts ss + (strip_hints res) (strip_hints args) + <*> mkStmts ss mkStmts (CmmCondBranch e l : fbranch) = mkCmmIfThenElse e (mkBranch l) (mkStmts fbranch) mkStmts (last : []) = mkLast last @@ -58,14 +61,15 @@ toZgraph fun_name args g@(ListGraph (BasicBlock id ss : other_blocks)) = 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 + mkFinalCall f conv (map hintlessCmm args) updfr_sz mkLast (CmmCall (CmmPrim {}) _ _ _ CmmNeverReturns) = panic "Call to CmmPrim never returns?!" mkLast (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 - mkLast (CmmReturn ress) = mkReturn $ map hintlessCmm ress + 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) = panic "Call never returns but has results?!" @@ -104,7 +108,7 @@ ofZgraph g = ListGraph $ swallow blocks showblocks = "LGraph has " ++ show (length blocks) ++ " blocks:" ++ concat (map (\(G.Block id _ _) -> " " ++ show id) blocks) cscomm = "Call successors are" ++ - (concat $ map (\id -> " " ++ show id) $ uniqSetToList call_succs) + (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 @@ -113,15 +117,13 @@ ofZgraph g = ListGraph $ swallow blocks mid (MidComment s) = CmmComment s mid (MidAssign l r) = CmmAssign l r mid (MidStore l r) = CmmStore l r - mid (MidUnsafeCall target ress args) + 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 - mid m@(MidAddToContext {}) = pcomment (ppr m) - pcomment p = scomment $ showSDoc p block' id prev' | id == G.lg_entry g = BasicBlock id $ extend_entry (reverse prev') | otherwise = BasicBlock id $ extend_block id (reverse prev') @@ -130,7 +132,7 @@ ofZgraph g = ListGraph $ swallow blocks case l of LastBranch tgt -> case n of - -- THIS IS NOW WRONG -- LABELS CAN SHOW UP ELSEWHERE IN THE GRAPH + -- 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 @@ -138,6 +140,10 @@ ofZgraph g = ListGraph $ swallow blocks 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', @@ -145,16 +151,8 @@ ofZgraph g = ListGraph $ swallow blocks tail id (CmmCondBranch e' fid : prev') t bs _ -> let instrs' = CmmBranch fid : CmmCondBranch expr tid : prev' in block' id instrs' : swallow n - LastJump expr _ -> endblock $ CmmJump expr [] - LastReturn _ -> endblock $ CmmReturn [] LastSwitch arg ids -> endblock $ CmmSwitch arg $ ids - LastCall e cont _ -> - let tgt = CmmCallee e CCallConv in - case cont of - Nothing -> - endblock $ CmmCall tgt [] [] CmmUnsafe CmmNeverReturns - Just _ -> - endblock $ CmmCall tgt [] [] (CmmSafe NoC_SRT) CmmMayReturn + 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") @@ -169,7 +167,7 @@ ofZgraph g = ListGraph $ swallow blocks let id = G.blockId b in case lookupBlockEnv preds id of Nothing -> single - Just s -> if sizeUniqSet s == 1 then + Just s -> if sizeBlockSet s == 1 then extendBlockSet single id else single in G.fold_blocks add emptyBlockSet g @@ -177,7 +175,8 @@ ofZgraph g = ListGraph $ swallow blocks call_succs = let add b succs = case G.last (G.unzip b) of - G.LastOther (LastCall _ (Just id) _) -> extendBlockSet succs id + G.LastOther (LastCall _ (Just id) _ _) -> + extendBlockSet succs id _ -> succs in G.fold_blocks add emptyBlockSet g _is_call_succ id = elemBlockSet id call_succs diff --git a/compiler/cmm/CmmExpr.hs b/compiler/cmm/CmmExpr.hs index 5893843..6e09a6f 100644 --- a/compiler/cmm/CmmExpr.hs +++ b/compiler/cmm/CmmExpr.hs @@ -1,15 +1,15 @@ 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 + , 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 - , wordWidth, halfWordWidth, cIntWidth, cLongWidth + , widthInBits, widthInBytes, widthInLog, widthFromBytes + , wordWidth, halfWordWidth, cIntWidth, cLongWidth , CmmExpr(..), cmmExprType, cmmExprWidth, maybeInvertCmmExpr , CmmReg(..), cmmRegType @@ -21,7 +21,7 @@ module CmmExpr , DefinerOfSlots, UserOfSlots, foldSlotsDefd, foldSlotsUsed , RegSet, emptyRegSet, elemRegSet, extendRegSet, deleteFromRegSet, mkRegSet , plusRegSet, minusRegSet, timesRegSet - , Area(..), AreaId(..), SubArea, StackSlotMap, getSlot + , Area(..), AreaId(..), SubArea, SubAreaSet, AreaMap, StackSlotMap, getSlot -- MachOp , MachOp(..) @@ -98,7 +98,9 @@ data AreaId | Young BlockId deriving (Eq, Ord) -type SubArea = (Area, Int, Int) -- area, offset, width +type SubArea = (Area, Int, Int) -- area, offset, width +type SubAreaSet = FiniteMap Area [SubArea] +type AreaMap = FiniteMap Area Int data CmmLit = CmmInt Integer Width @@ -119,6 +121,8 @@ data CmmLit -- It is also used inside the NCG during when generating -- position-independent code. | CmmLabelDiffOff CLabel CLabel Int -- label1 - label2 + offset + | CmmBlock BlockId -- Code label + | CmmHighStackMark -- stands for the max stack space used during a procedure deriving Eq cmmExprType :: CmmExpr -> CmmType @@ -135,6 +139,8 @@ cmmLitType (CmmFloat _ width) = cmmFloat width cmmLitType (CmmLabel lbl) = cmmLabelType lbl cmmLitType (CmmLabelOff lbl _) = cmmLabelType lbl cmmLitType (CmmLabelDiffOff {}) = bWord +cmmLitType (CmmBlock _) = bWord +cmmLitType (CmmHighStackMark) = bWord cmmLabelType :: CLabel -> CmmType cmmLabelType lbl | isGcPtrLabel lbl = gcWord @@ -244,6 +250,10 @@ instance DefinerOfLocalRegs a => DefinerOfLocalRegs [a] where foldRegsDefd _ set [] = set foldRegsDefd f set (x:xs) = foldRegsDefd f (foldRegsDefd f set x) xs +instance DefinerOfLocalRegs a => DefinerOfLocalRegs (Maybe a) where + foldRegsDefd _ set Nothing = set + foldRegsDefd f set (Just x) = foldRegsDefd f set x + ----------------------------------------------------------------------------- -- Stack slots @@ -605,6 +615,15 @@ 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 diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index eb226da..438f122 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -6,8 +6,10 @@ -- for details module CmmInfo ( + emptyContInfoTable, cmmToRawCmm, - mkInfoTable + mkInfoTable, + mkBareInfoTable ) where #include "HsVersions.h" @@ -23,6 +25,7 @@ import CgInfoTbls import CgCallConv import CgUtils import SMRep +import ZipCfgCmmRep import Constants import Outputable @@ -33,6 +36,13 @@ import Panic import Data.Bits +-- When we split at proc points, we need an empty info table. +emptyContInfoTable :: CmmInfo +emptyContInfoTable = + CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL + (ContInfo [] NoC_SRT)) + where zero = CmmInt 0 wordWidth + cmmToRawCmm :: [Cmm] -> IO [RawCmm] cmmToRawCmm cmm = do info_tbl_uniques <- mkSplitUniqSupply 'i' @@ -81,7 +91,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = -- Code without an info table. Easy. CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks] - CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info -> + CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> let info_label = entryLblToInfoLbl entry_label ty_prof' = makeRelativeRefTo info_label ty_prof cl_prof' = makeRelativeRefTo info_label cl_prof @@ -144,6 +154,17 @@ 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 diff --git a/compiler/cmm/CmmLint.hs b/compiler/cmm/CmmLint.hs index 7c8f2b3..1b60ed7 100644 --- a/compiler/cmm/CmmLint.hs +++ b/compiler/cmm/CmmLint.hs @@ -22,7 +22,6 @@ import CLabel import Maybe import Outputable import PprCmm -import Unique import Constants import FastString @@ -59,7 +58,7 @@ lintCmmTop (CmmData {}) lintCmmBlock :: BlockSet -> GenBasicBlock CmmStmt -> CmmLint () lintCmmBlock labels (BasicBlock id stmts) - = addLintInfo (text "in basic block " <> ppr (getUnique id)) $ + = addLintInfo (text "in basic block " <> ppr id) $ mapM_ (lintCmmStmt labels) stmts -- ----------------------------------------------------------------------------- @@ -88,20 +87,11 @@ lintCmmExpr expr = -- Check for some common byte/word mismatches (eg. Sp + 1) cmmCheckMachOp :: MachOp -> [CmmExpr] -> [CmmType] -> CmmLint CmmType -cmmCheckMachOp op args@[CmmReg reg, CmmLit (CmmInt i _)] _ - | isWordOffsetReg reg && isOffsetOp op && i `rem` fromIntegral wORD_SIZE /= 0 - = cmmLintDubiousWordOffset (CmmMachOp op args) cmmCheckMachOp op [lit@(CmmLit (CmmInt { })), reg@(CmmReg _)] tys = cmmCheckMachOp op [reg, lit] tys cmmCheckMachOp op _ tys = return (machOpResultType op tys) -isWordOffsetReg :: CmmReg -> Bool -isWordOffsetReg (CmmGlobal Sp) = True --- No warnings for unaligned arithmetic, which is used to tag dynamic constructor closures. ---isWordOffsetReg (CmmGlobal Hp) = True -isWordOffsetReg _ = False - isOffsetOp :: MachOp -> Bool isOffsetOp (MO_Add _) = True isOffsetOp (MO_Sub _) = True diff --git a/compiler/cmm/CmmLive.hs b/compiler/cmm/CmmLive.hs index 93372fc..e53a606 100644 --- a/compiler/cmm/CmmLive.hs +++ b/compiler/cmm/CmmLive.hs @@ -47,13 +47,13 @@ cmmLiveness blocks = fixedpoint (cmmBlockDependants sources) (cmmBlockUpdate blocks') (map blockId blocks) - (listToUFM [(blockId b, emptyUniqSet) | b <- blocks]) + (mkBlockEnv [(blockId b, emptyUniqSet) | b <- blocks]) where sources :: BlockSources sources = cmmBlockSources blocks blocks' :: BlockStmts - blocks' = listToUFM $ map block_name blocks + blocks' = mkBlockEnv $ map block_name blocks block_name :: CmmBasicBlock -> (BlockId, [CmmStmt]) block_name b = (blockId b, blockStmts b) @@ -75,7 +75,7 @@ cmmLivenessComment live (BasicBlock ident stmts) = -- need updating after a given block is updated in the liveness analysis ----------------------------------------------------------------------------- cmmBlockSources :: [CmmBasicBlock] -> BlockSources -cmmBlockSources blocks = foldr aux emptyUFM blocks +cmmBlockSources blocks = foldr aux emptyBlockEnv blocks where aux :: CmmBasicBlock -> BlockSources @@ -89,7 +89,7 @@ cmmBlockSources blocks = foldr aux emptyUFM blocks -> BlockSources -> BlockSources add_source_edges source target ufm = - addToUFM_Acc (flip addOneToUniqSet) unitUniqSet ufm target source + addToBEnv_Acc (flip addOneToUniqSet) unitUniqSet ufm target source branch_targets :: [CmmStmt] -> UniqSet BlockId branch_targets stmts = @@ -107,7 +107,7 @@ cmmBlockSources blocks = foldr aux emptyUFM blocks ----------------------------------------------------------------------------- cmmBlockDependants :: BlockSources -> BlockId -> [BlockId] cmmBlockDependants sources ident = - uniqSetToList $ lookupWithDefaultUFM sources emptyUniqSet ident + uniqSetToList $ lookupWithDefaultBEnv sources emptyUniqSet ident ----------------------------------------------------------------------------- -- | Given the table of type 'BlockStmts' and a block that was updated, @@ -122,14 +122,14 @@ cmmBlockUpdate :: cmmBlockUpdate blocks node _ state = if (sizeUniqSet old_live) == (sizeUniqSet new_live) then Nothing - else Just $ addToUFM state node new_live + else Just $ extendBlockEnv state node new_live where new_live, old_live :: CmmLive new_live = cmmStmtListLive state block_stmts - old_live = lookupWithDefaultUFM state missing_live node + old_live = lookupWithDefaultBEnv state missing_live node block_stmts :: [CmmStmt] - block_stmts = lookupWithDefaultUFM blocks missing_block node + 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" @@ -187,14 +187,14 @@ cmmStmtLive _ (CmmCall target results arguments _ _) = (CmmCallee target _) -> cmmExprLive target (CmmPrim _) -> id cmmStmtLive other_live (CmmBranch target) = - addLive (lookupWithDefaultUFM other_live emptyUniqSet target) + addLive (lookupWithDefaultBEnv other_live emptyUniqSet target) cmmStmtLive other_live (CmmCondBranch expr target) = cmmExprLive expr . - addLive (lookupWithDefaultUFM other_live emptyUniqSet target) + addLive (lookupWithDefaultBEnv other_live emptyUniqSet target) cmmStmtLive other_live (CmmSwitch expr targets) = cmmExprLive expr . (foldr ((.) . (addLive . - lookupWithDefaultUFM other_live emptyUniqSet)) + lookupWithDefaultBEnv other_live emptyUniqSet)) id (mapCatMaybes id targets)) cmmStmtLive _ (CmmJump expr params) = diff --git a/compiler/cmm/CmmLiveZ.hs b/compiler/cmm/CmmLiveZ.hs index b239ae3..7bafc91 100644 --- a/compiler/cmm/CmmLiveZ.hs +++ b/compiler/cmm/CmmLiveZ.hs @@ -3,7 +3,7 @@ module CmmLiveZ ( CmmLive , cmmLivenessZ , liveLattice - , middleLiveness, lastLiveness + , middleLiveness, lastLiveness, noLiveOnEntry ) where @@ -19,6 +19,7 @@ import ZipDataflow import ZipCfgCmmRep import Maybes +import Outputable import UniqSet ----------------------------------------------------------------------------- @@ -30,7 +31,7 @@ type CmmLive = RegSet -- | The dataflow lattice liveLattice :: DataflowLattice CmmLive -liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add False +liveLattice = DataflowLattice "live LocalReg's" emptyUniqSet add True where add new old = let join = unionUniqSets new old in (if sizeUniqSet join > sizeUniqSet old then aTx else noTx) join @@ -42,13 +43,22 @@ type BlockEntryLiveness = BlockEnv CmmLive -- | Calculated liveness info for a CmmGraph ----------------------------------------------------------------------------- cmmLivenessZ :: CmmGraph -> FuelMonad BlockEntryLiveness -cmmLivenessZ g = liftM zdfFpFacts $ (res :: FuelMonad (CmmBackwardFixedPoint CmmLive)) +cmmLivenessZ g@(LGraph entry _ _) = + liftM (check . zdfFpFacts) (res :: FuelMonad (CmmBackwardFixedPoint CmmLive)) where res = zdfSolveFrom emptyBlockEnv "liveness analysis" liveLattice transfers emptyUniqSet (graphOfLGraph g) transfers = BackwardTransfers first middle last first live _ = live middle = flip middleLiveness last = flip lastLiveness + check facts = + noLiveOnEntry entry (expectJust "check" $ lookupBlockEnv facts entry) facts + +-- | 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. @@ -56,20 +66,18 @@ gen, kill :: UserOfLocalRegs a => a -> RegSet -> RegSet gen a live = foldRegsUsed extendRegSet live a kill a live = foldRegsUsed delOneFromUniqSet live a +-- Why aren't these function using the typeclasses on Middle and Last? middleLiveness :: Middle -> CmmLive -> CmmLive -middleLiveness m = middle m - where middle (MidComment {}) = id - middle (MidAssign lhs expr) = gen expr . kill lhs - middle (MidStore addr rval) = gen addr . gen rval - middle (MidUnsafeCall tgt ress args) = gen tgt . gen args . kill ress - middle (MidAddToContext ra args) = gen ra . gen args +middleLiveness (MidComment {}) live = live +middleLiveness (MidAssign lhs expr) live = gen expr $ kill lhs live +middleLiveness (MidStore addr rval) live = gen addr $ gen rval live +middleLiveness (MidForeignCall _ tgt _ args) _ = gen tgt $ gen args emptyUniqSet lastLiveness :: Last -> (BlockId -> CmmLive) -> CmmLive lastLiveness l env = last l - where last (LastReturn _) = emptyUniqSet - last (LastJump e _) = gen e $ emptyUniqSet - last (LastBranch id) = env id - last (LastCall tgt (Just k) _) = gen tgt $ env k - last (LastCall tgt Nothing _) = gen tgt $ emptyUniqSet - last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f) - last (LastSwitch e tbl) = gen e $ unionManyUniqSets $ map env (catMaybes tbl) + where last (LastBranch id) = env id + last (LastCall tgt Nothing _ _) = gen tgt $ emptyUniqSet + last (LastCall tgt (Just k) _ _) = gen tgt $ env k + last (LastCondBranch e t f) = gen e $ unionUniqSets (env t) (env f) + last (LastSwitch e tbl) = + gen e $ unionManyUniqSets $ map env (catMaybes tbl) diff --git a/compiler/cmm/CmmOpt.hs b/compiler/cmm/CmmOpt.hs index e459a75..148e3da 100644 --- a/compiler/cmm/CmmOpt.hs +++ b/compiler/cmm/CmmOpt.hs @@ -543,7 +543,8 @@ narrowS _ _ = panic "narrowTo" -} cmmLoopifyForC :: RawCmmTop -> RawCmmTop -cmmLoopifyForC p@(CmmProc info entry_lbl [] (ListGraph blocks@(BasicBlock top_id _ : _))) +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) $ diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index 9382994..180aad6 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -247,7 +247,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- ptrs, nptrs, closure type, description, type { do prof <- profilingInfo $11 $13 return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $9) + CmmInfoTable False prof (fromIntegral $9) (ThunkInfo (fromIntegral $5, fromIntegral $7) NoC_SRT), []) } @@ -255,7 +255,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- ptrs, nptrs, closure type, description, type, fun type { do prof <- profilingInfo $11 $13 return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $9) + CmmInfoTable False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT 0 -- Arity zero (ArgSpec (fromIntegral $15)) @@ -269,7 +269,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- ptrs, nptrs, closure type, description, type, fun type, arity { do prof <- profilingInfo $11 $13 return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $9) + CmmInfoTable False prof (fromIntegral $9) (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $17) (ArgSpec (fromIntegral $15)) zeroCLit), @@ -284,7 +284,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- but that's the way the old code did it we can fix it some other time. desc_lit <- code $ mkStringCLit $13 return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $11) + CmmInfoTable False prof (fromIntegral $11) (ConstrInfo (fromIntegral $5, fromIntegral $7) (fromIntegral $9) desc_lit), []) } @@ -292,7 +292,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- selector, closure type, description, type { do prof <- profilingInfo $9 $11 return (mkRtsEntryLabelFS $3, - CmmInfoTable prof (fromIntegral $7) + CmmInfoTable False prof (fromIntegral $7) (ThunkSelectorInfo (fromIntegral $5) NoC_SRT), []) } @@ -300,7 +300,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- closure type (no live regs) { do let infoLabel = mkRtsInfoLabelFS $3 return (mkRtsRetLabelFS $3, - CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo [] NoC_SRT), []) } @@ -308,7 +308,7 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) } -- closure type, live regs { do live <- sequence (map (liftM Just) $7) return (mkRtsRetLabelFS $3, - CmmInfoTable (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) + CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) (fromIntegral $5) (ContInfo live NoC_SRT), live) } diff --git a/compiler/cmm/CmmProcPoint.hs b/compiler/cmm/CmmProcPoint.hs index aa0ef01..a90af71 100644 --- a/compiler/cmm/CmmProcPoint.hs +++ b/compiler/cmm/CmmProcPoint.hs @@ -85,8 +85,8 @@ calculateNewProcPoints owners block = then unitUniqSet child_id else emptyUniqSet where - parent_owners = lookupWithDefaultUFM owners emptyUniqSet parent_id - child_owners = lookupWithDefaultUFM owners emptyUniqSet child_id + 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) && @@ -99,11 +99,11 @@ calculateOwnership :: BlockEnv BrokenBlock -> [BrokenBlock] -> BlockEnv (UniqSet BlockId) calculateOwnership blocks_ufm proc_points blocks = - fixedpoint dependants update (map brokenBlockId blocks) emptyUFM + fixedpoint dependants update (map brokenBlockId blocks) emptyBlockEnv where dependants :: BlockId -> [BlockId] dependants ident = - brokenBlockTargets $ lookupWithDefaultUFM + brokenBlockTargets $ lookupWithDefaultBEnv blocks_ufm unknown_block ident update :: BlockId @@ -113,16 +113,16 @@ calculateOwnership blocks_ufm proc_points blocks = update ident cause owners = case (cause, ident `elementOfUniqSet` proc_points) of (Nothing, True) -> - Just $ addToUFM owners ident (unitUniqSet ident) + Just $ extendBlockEnv owners ident (unitUniqSet ident) (Nothing, False) -> Nothing (Just cause', True) -> Nothing (Just cause', False) -> if (sizeUniqSet old) == (sizeUniqSet new) then Nothing - else Just $ addToUFM owners ident new + else Just $ extendBlockEnv owners ident new where - old = lookupWithDefaultUFM owners emptyUniqSet ident + old = lookupWithDefaultBEnv owners emptyUniqSet ident new = old `unionUniqSets` - lookupWithDefaultUFM owners emptyUniqSet cause' + lookupWithDefaultBEnv owners emptyUniqSet cause' unknown_block = panic "unknown BlockId in calculateOwnership" diff --git a/compiler/cmm/CmmProcPointZ.hs b/compiler/cmm/CmmProcPointZ.hs index cedb9ef..7cf477a 100644 --- a/compiler/cmm/CmmProcPointZ.hs +++ b/compiler/cmm/CmmProcPointZ.hs @@ -1,38 +1,30 @@ - module CmmProcPointZ - ( callProcPoints, minimalProcPointSet + ( ProcPointSet, Status(..) + , callProcPoints, minimalProcPointSet , addProcPointProtocols, splitAtProcPoints, procPointAnalysis - , liveSlotAnal, cafAnal, layout, manifestSP, igraph, areaBuilder ) where -import Constants import qualified Prelude as P import Prelude hiding (zip, unzip, last) -import Util (sortLe) import BlockId -import Bitmap import CLabel import Cmm hiding (blockId) -import CmmExpr import CmmContFlowOpt +import CmmExpr +import CmmInfo import CmmLiveZ import CmmTx import DFMonad import FiniteMap -import IdInfo import List (sortBy) import Maybes +import MkZipCfg import MkZipCfgCmm hiding (CmmBlock, CmmGraph, CmmTopZ) import Monad -import Name import Outputable import Panic -import SMRep (rET_SMALL) -import StgCmmClosure -import StgCmmUtils -import UniqFM import UniqSet import UniqSupply import ZipCfg @@ -105,9 +97,9 @@ data Status instance Outputable Status where ppr (ReachedBy ps) - | isEmptyUniqSet ps = text "" + | isEmptyBlockSet ps = text "" | otherwise = text "reached by" <+> - (hsep $ punctuate comma $ map ppr $ uniqSetToList ps) + (hsep $ punctuate comma $ map ppr $ blockSetToList ps) ppr ProcPoint = text "" @@ -117,8 +109,8 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals add_to _ ProcPoint = noTx ProcPoint add_to ProcPoint _ = aTx ProcPoint -- aTx because of previous case again add_to (ReachedBy p) (ReachedBy p') = - let union = unionUniqSets p p' - in if sizeUniqSet union > sizeUniqSet p' then + let union = unionBlockSets p p' + in if sizeBlockSet union > sizeBlockSet p' then aTx (ReachedBy union) else noTx (ReachedBy p') @@ -127,10 +119,10 @@ lattice = DataflowLattice "direct proc-point reachability" unreached add_to Fals forward :: ForwardTransfers Middle Last Status forward = ForwardTransfers first middle last exit - where first ProcPoint id = ReachedBy $ unitUniqSet id + where first ProcPoint id = ReachedBy $ unitBlockSet id first x _ = x middle x _ = x - last _ (LastCall _ (Just id) _) = LastOutFacts [(id, ProcPoint)] + last _ (LastCall _ (Just id) _ _) = LastOutFacts [(id, ProcPoint)] last x l = LastOutFacts $ map (\id -> (id, x)) (succs l) exit x = x @@ -140,10 +132,9 @@ forward = ForwardTransfers first middle last exit callProcPoints :: CmmGraph -> ProcPointSet minimalProcPointSet :: ProcPointSet -> CmmGraph -> FuelMonad ProcPointSet -callProcPoints g = fold_blocks add entryPoint g - where entryPoint = unitUniqSet (lg_entry g) - add b set = case last $ unzip b of - LastOther (LastCall _ (Just k) _) -> extendBlockSet set k +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 callProcPoints g = extendPPSet g (postorder_dfs g) callProcPoints @@ -153,7 +144,7 @@ type PPFix = FuelMonad (ForwardFixedPoint Middle Last Status ()) procPointAnalysis :: ProcPointSet -> CmmGraph -> FuelMonad (BlockEnv Status) procPointAnalysis procPoints g = let addPP env id = extendBlockEnv env id ProcPoint - initProcPoints = foldl addPP emptyBlockEnv (uniqSetToList procPoints) + initProcPoints = foldl addPP emptyBlockEnv (blockSetToList procPoints) in liftM zdfFpFacts $ (zdfSolveFrom initProcPoints "proc-point reachability" lattice forward (fact_bot lattice) $ graphOfLGraph g :: PPFix) @@ -166,18 +157,26 @@ extendPPSet g blocks procPoints = Just ProcPoint -> extendBlockSet pps id _ -> pps procPoints' = fold_blocks add emptyBlockSet g - newPoint = listToMaybe (mapMaybe ppSuccessor blocks) - ppSuccessor b@(Block id _ _) = - let nreached id = case lookupBlockEnv env id `orElse` panic "no ppt" of + 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 -> sizeUniqSet ps - my_nreached = nreached id + 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 > my_nreached + 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) @@ -245,16 +244,18 @@ instance Outputable Protocol where addProcPointProtocols :: ProcPointSet -> ProcPointSet -> CmmGraph -> FuelMonad CmmGraph addProcPointProtocols callPPs procPoints g = do liveness <- cmmLivenessZ g - (protos, g') <- return $ optimize_calls liveness g + (protos, g') <- optimize_calls liveness g blocks'' <- add_CopyOuts protos procPoints g' return $ LGraph (lg_entry g) (lg_argoffset g) blocks'' where optimize_calls liveness g = -- see Note [Separate Adams optimization] - let (protos, blocks') = - fold_blocks maybe_add_call (init_protocols, emptyBlockEnv) g - protos' = add_unassigned liveness procPoints protos - g' = LGraph (lg_entry g) (lg_argoffset g) $ - add_CopyIns callPPs protos' blocks' - in (protos', runTx removeUnreachableBlocksZ g') + 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) (lg_argoffset 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 @@ -262,10 +263,10 @@ addProcPointProtocols callPPs procPoints g = -- 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) s)) + (h, LastOther (LastCall tgt (Just k) u s)) | Just proto <- lookupBlockEnv protos k, Just pee <- branchesToProcPoint k - -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) s)) + -> let newblock = zipht h (tailOfLast (LastCall tgt (Just pee) u s)) changed_blocks = insertBlock newblock blocks unchanged_blocks = insertBlock block blocks in case lookupBlockEnv protos pee of @@ -279,7 +280,7 @@ addProcPointProtocols callPPs procPoints g = -- ^ 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" + panic "branch out of graph" in case t of ZLast (LastOther (LastBranch pee)) | elemBlockSet pee procPoints -> Just pee @@ -301,12 +302,12 @@ 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' = foldUniqSet addLiveVars protos procPoints + 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 = emptyBlockEnv + Nothing -> let live = emptyRegSet --lookupBlockEnv _liveness id `orElse` --panic ("no liveness at block " ++ show id) formals = uniqSetToList live @@ -317,16 +318,23 @@ pass_live_vars_as_args _liveness procPoints protos = 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 = mapUFM maybe_insert_CopyIns blocks - where maybe_insert_CopyIns :: CmmBlock -> CmmBlock - maybe_insert_CopyIns b@(Block id off t) | not $ elementOfUniqSet id callPPs = - case (off, lookupBlockEnv protos id) of - (Just _, _) -> panic "shouldn't copy arguments twice into a block" - (_, Just (Protocol c fs area)) -> Block id (Just off) $ foldr ZTail t copies - where (off, copies) = copyIn c False area fs - (_, Nothing) -> b - maybe_insert_CopyIns b = b +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 stackInfo t)) + | not $ elemBlockSet id callPPs + = case (argBytes stackInfo, lookupBlockEnv protos id) of + (Just _, _) -> panic "shouldn't copy arguments twice into a block" + (_, Just (Protocol c fs area)) -> + do let (off, copies) = copyIn c False area fs + stackInfo' = stackInfo {argBytes = Just off} + LGraph _ _ blocks <- + lgraphOfAGraph 0 (mkLabel id stackInfo' <*> + copies <*> 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. @@ -342,7 +350,7 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv 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 + LastOther (LastCall _ _ _ _) -> skip b z -- copy out done by callee _ -> mb_copy_out' b z mb_copy_out' b z = fold_succs trySucc b init >>= finish where init = z >>= (\bmap -> return (b, bmap)) @@ -351,7 +359,8 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv case lookupBlockEnv protos succId of Nothing -> z Just (Protocol c fs area) -> - let (_, copies) = copyOut c Jump area $ map (CmmReg . CmmLocal) fs + let (_, copies) = + copyOut c Jump area (map (CmmReg . CmmLocal) fs) 0 in insert z succId copies else z insert z succId m = @@ -375,540 +384,86 @@ add_CopyOuts protos procPoints g = fold_blocks mb_copy_out (return emptyBlockEnv -- 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 -> - BlockEnv SubAreaSet -> AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ] -splitAtProcPoints entry_label callPPs procPoints procMap slotEnv areaMap - (CmmProc top_info top_l top_args g@(LGraph entry e_off blocks)) = + AreaMap -> CmmTopZ -> FuelMonad [CmmTopZ] +splitAtProcPoints entry_label callPPs procPoints procMap areaMap + (CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args + g@(LGraph entry e_off 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 uniqSetToList set of + case blockSetToList set of [] -> graphEnv [id] -> add graphEnv id bid b - _ -> panic "Each block should be reachable from only one ProcPoint" + _ -> 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 + graphEnv_pre <- return $ fold_blocks addBlock emptyBlockEnv g + graphEnv <- return $ pprTrace "graphEnv" (ppr graphEnv_pre) graphEnv_pre -- Build a map from proc point BlockId to labels for their new procedures let add_label map pp = return $ addToFM map pp lbl where lbl = if pp == entry then entry_label else blockLbl pp - procLabels <- foldM add_label emptyFM (uniqSetToList procPoints) - -- Convert call and return instructions to jumps. - let last (LastCall e _ n) = LastJump e n - last l = l - graphEnv <- return $ mapUFM (mapUFM (map_one_block id id last)) graphEnv + -- Due to common blockification, we may overestimate the set of procpoints. + procLabels <- foldM add_label emptyFM + (filter (elemBlockEnv blocks) (blockSetToList procPoints)) -- 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 Nothing (ZLast (LastOther jump)) - argSpace = case lookupBlockEnv blocks pp of - Just (Block _ (Just s) _) -> s - Just (Block _ Nothing _) -> panic "no args at procpoint" - _ -> panic "can't find procpoint block" - jump = LastJump (CmmLit (CmmLabel l)) argSpace - return $ (extendBlockEnv env pp bid, b : bs) - add_jumps newGraphEnv (guniq, blockEnv) = - do (jumpEnv, jumpBlocks) <- foldM add_jump_block (emptyBlockEnv, []) - $ fmToList procLabels - let ppId = mkBlockId guniq - (b_off, b) = - case lookupBlockEnv blockEnv ppId of - Just (Block id (Just b_off) t) -> (b_off, Block id Nothing t) - Just b@(Block _ Nothing _) -> (0, b) + let b = Block bid emptyStackInfo (ZLast (LastOther jump)) + argSpace = + case lookupBlockEnv blocks pp of + Just (Block _ (StackInfo {argBytes = Just s}) _) -> s + Just (Block _ _ _) -> panic "no args at procpoint" + _ -> panic "can't find procpoint block" + jump = LastCall (CmmLit (CmmLabel l')) Nothing argSpace Nothing + l' = if elemBlockSet pp callPPs then entryLblToInfoLbl l else l + return (extendBlockEnv env pp bid, b : bs) + add_jumps (newGraphEnv) (ppId, blockEnv) = + do (jumpEnv, jumpBlocks) <- + foldM add_jump_block (emptyBlockEnv, []) (fmToList procLabels) + let (b_off, b) = -- get the stack offset on entry into the block and + -- remove the offset from the block (it goes in new graph) + case lookupBlockEnv blockEnv ppId of -- get the procpoint block + Just (Block id sinfo@(StackInfo {argBytes = Just b_off}) t) -> + (b_off, Block id (sinfo {argBytes = Nothing}) t) + Just b@(Block _ _ _) -> (0, b) Nothing -> panic "couldn't find entry block while splitting" + blockEnv' = extendBlockEnv blockEnv ppId b off = if ppId == entry then e_off else b_off - LGraph _ _ blockEnv' = pprTrace "jumpEnv" (ppr jumpEnv) $ - replaceLabelsZ jumpEnv $ LGraph ppId off blockEnv - blockEnv'' = foldl (flip insertBlock) (extendBlockEnv blockEnv' ppId b) - jumpBlocks - return $ extendBlockEnv newGraphEnv ppId $ - runTx cmmCfgOptsZ $ LGraph ppId off blockEnv'' - upd_info_tbl srt' (CmmInfoTable p t typeinfo) = CmmInfoTable p t typeinfo' - where typeinfo' = case typeinfo of - t@(ConstrInfo _ _ _) -> t - (FunInfo c _ a d e) -> FunInfo c srt' a d e - (ThunkInfo c _) -> ThunkInfo c srt' - (ThunkSelectorInfo s _) -> ThunkSelectorInfo s srt' - (ContInfo vars _) -> ContInfo vars srt' - upd_info_tbl _ CmmNonInfoTable = CmmNonInfoTable - to_proc cafMap (ppUniq, g) | elementOfUniqSet bid callPPs = + LGraph _ _ blockEnv'' = + replaceBranches jumpEnv $ LGraph ppId off blockEnv' + blockEnv''' = foldl (flip insertBlock) blockEnv'' jumpBlocks + let g' = LGraph ppId off blockEnv''' + pprTrace "g' pre jumps" (ppr g') $ + return (extendBlockEnv newGraphEnv ppId g') + graphEnv_pre <- foldM add_jumps emptyBlockEnv $ blockEnvToList graphEnv + graphEnv <- return $ pprTrace "graphEnv with jump blocks" (ppr graphEnv_pre) + graphEnv_pre + let to_proc (bid, g@(LGraph g_entry _ blocks)) | elemBlockSet bid callPPs = if bid == entry then - CmmProc (CmmInfo gc upd_fr (upd_info_tbl srt' info_tbl)) top_l top_args g + CmmProc (CmmInfo gc upd_fr info_tbl) top_l top_args g else - pprTrace "adding infotable for" (ppr bid) $ - CmmProc (CmmInfo Nothing Nothing $ infoTbl) lbl [] g - where bid = mkBlockId ppUniq - lbl = expectJust "pp label" $ lookupFM procLabels bid - infoTbl = CmmInfoTable (ProfilingInfo zero zero) rET_SMALL - (ContInfo stack_vars srt') - stack_vars = pprTrace "slotEnv" (ppr slotEnv) $ - live_vars slotEnv areaMap bid - zero = CmmInt 0 wordWidth - srt' = expectJust "procpoint.infoTbl" $ lookupBlockEnv cafMap bid - CmmInfo gc upd_fr info_tbl = top_info - to_proc _ (ppUniq, g) = - pprTrace "not adding infotable for" (ppr bid) $ + CmmProc emptyContInfoTable lbl [] g + where lbl = expectJust "pp label" $ lookupFM procLabels bid + to_proc (bid, g) = CmmProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] g - where bid = mkBlockId ppUniq - lbl = expectJust "pp label" $ lookupFM procLabels bid - graphEnv <- foldM add_jumps emptyBlockEnv $ ufmToList graphEnv - cafEnv <- cafAnal g - (cafTable, blockCafs) <- buildCafs cafEnv - procs <- return $ map (to_proc blockCafs) $ ufmToList graphEnv - return $ pprTrace "procLabels" (ppr procLabels) $ - pprTrace "splitting graphs" (ppr graphEnv) $ cafTable ++ procs -splitAtProcPoints _ _ _ _ _ _ t@(CmmData _ _) = return [t] - ------------------------------------------------------------------------- --- Stack Layout -- ------------------------------------------------------------------------- - --- | Before we lay out the stack, we need to know something about the --- liveness of the stack slots. In particular, to decide whether we can --- reuse a stack location to hold multiple stack slots, we need to know --- when each of the stack slots is used. --- Although tempted to use something simpler, we really need a full interference --- graph. Consider the following case: --- case <...> of --- 1 -> ; // y is dead out --- 2 -> ; // x is dead out --- 3 -> --- If we consider the arms in order and we use just the deadness information given by a --- dataflow analysis, we might decide to allocate the stack slots for x and y --- to the same stack location, which will lead to incorrect code in the third arm. --- We won't make this mistake with an interference graph. - --- First, the liveness analysis. --- We represent a slot with an area, an offset into the area, and a width. --- Tracking the live slots is a bit tricky because there may be loads and stores --- into only a part of a stack slot (e.g. loading the low word of a 2-word long), --- e.g. Slot A 0 8 overlaps with Slot A 4 4. --- --- The definition of a slot set is intended to reduce the number of overlap --- checks we have to make. There's no reason to check for overlap between --- slots in different areas, so we segregate the map by Area's. --- We expect few slots in each Area, so we collect them in an unordered list. --- To keep these lists short, any contiguous live slots are coalesced into --- a single slot, on insertion. - -type SubAreaSet = FiniteMap Area [SubArea] -fold_subareas :: (SubArea -> z -> z) -> SubAreaSet -> z -> z -fold_subareas f m z = foldFM (\_ s z -> foldr (\a z -> f a z) z s) z m - -liveGen :: SubArea -> [SubArea] -> (Bool, [SubArea]) -liveGen s set = liveGen' s set [] - where liveGen' s [] z = (True, s : z) - liveGen' s@(a, hi, w) (s'@(a', hi', w') : rst) z = - if a /= a' || hi < lo' || lo > hi' then -- no overlap - liveGen' s rst (s' : z) - else if s' `contains` s then -- old contains new - (False, set) - else -- overlap: coalesce the slots - let new_hi = max hi hi' - new_lo = min lo lo' - in liveGen' (a, new_hi, new_hi - new_lo) rst z - where lo = hi - w -- remember: areas grow down - lo' = hi' - w' - contains (a, hi, w) (a', hi', w') = - a == a' && hi >= hi' && hi - w <= hi' - w' - -liveKill :: SubArea -> [SubArea] -> [SubArea] -liveKill (a, hi, w) set = pprTrace "killing slots in area" (ppr a) $ liveKill' set [] - where liveKill' [] z = z - liveKill' (s'@(a', hi', w') : rst) z = - if a /= a' || hi < lo' || lo > hi' then -- no overlap - liveKill' rst (s' : z) - else -- overlap: split the old slot - let z' = if hi' > hi then (a, hi', hi' - hi) : z else z - z'' = if lo > lo' then (a, lo, lo - lo') : z' else z' - in liveKill' rst z'' - where lo = hi - w -- remember: areas grow down - lo' = hi' - w' - -slotLattice :: DataflowLattice SubAreaSet -slotLattice = DataflowLattice "live slots" emptyFM add True - where add new old = case foldFM addArea (False, old) new of - (True, x) -> aTx x - (False, x) -> noTx x - addArea a newSlots z = foldr (addSlot a) z newSlots - addSlot a slot (changed, map) = - let (c, live) = liveGen slot $ lookupWithDefaultFM map [] a - in (c || changed, addToFM map a live) - -liveInSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet -liveInSlots live x = foldSlotsUsed add (foldSlotsDefd remove live x) x - where add live (a, i, w) = liftToArea a (snd . liveGen (a, i, w)) live - remove live (a, i, w) = liftToArea a (liveKill (a, i, w)) live - liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a) - --- Unlike the liveness transfer functions @gen@ and @kill@, this function collects --- _any_ slot that is named. ---addNamedSlots :: (DefinerOfSlots s, UserOfSlots s) => SubAreaSet -> s -> SubAreaSet ---addNamedSlots live x = foldSlotsUsed add (foldSlotsDefd add live x) x --- where add live (a, i, w) = liftToArea a (snd . liveGen (a, i, w)) live --- liftToArea a f map = addToFM map a $ f (lookupWithDefaultFM map [] a) - --- Note: the stack slots that hold variables returned on the stack are not --- considered live in to the block -- we treat the first node as a definition site. --- BEWARE: I'm being a little careless here in failing to check for the --- entry Id (which would use the CallArea Old). -liveTransfers :: BackwardTransfers Middle Last SubAreaSet -liveTransfers = BackwardTransfers first liveInSlots liveLastIn - where first live id = delFromFM live (CallArea (Young id)) - -liveLastIn :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet -liveLastIn env l = liveInSlots (liveLastOut env l) l - --- Don't forget to keep the outgoing parameters in the CallArea live. -liveLastOut :: (BlockId -> SubAreaSet) -> Last -> SubAreaSet -liveLastOut env l = - case l of - LastReturn n -> add_area (CallArea Old) n out - LastJump _ n -> add_area (CallArea Old) n out - LastCall _ Nothing n -> add_area (CallArea Old) n out - LastCall _ (Just k) n -> add_area (CallArea (Young k)) n out - _ -> out - where out = joinOuts slotLattice env l -add_area :: Area -> Int -> SubAreaSet -> SubAreaSet -add_area a n live = - addToFM live a $ snd $ liveGen (a, n, n) $ lookupWithDefaultFM live [] a - -type SlotFix a = FuelMonad (BackwardFixedPoint Middle Last SubAreaSet a) -liveSlotAnal :: LGraph Middle Last -> FuelMonad (BlockEnv SubAreaSet) -liveSlotAnal g = liftM zdfFpFacts (res :: SlotFix ()) - where res = zdfSolveFromL emptyBlockEnv "live slot analysis" slotLattice - liveTransfers (fact_bot slotLattice) g - --- The liveness analysis must be precise: otherwise, we won't know if a definition --- should really kill a live-out stack slot. --- But the interference graph does not have to be precise -- it might decide that --- any live areas interfere. To maintain both a precise analysis and an imprecise --- interference graph, we need to convert the live-out stack slots to graph nodes --- at each and every instruction; rather than reconstruct a new list of nodes --- every time, I provide a function to fold over the nodes, which should be a --- reasonably efficient approach for the implementations we envision. --- Of course, it will probably be much easier to program if we just return a list... -type Set x = FiniteMap x () -type AreaMap = FiniteMap Area Int -data IGraphBuilder n = - Builder { foldNodes :: forall z. SubArea -> (n -> z -> z) -> z -> z - , _wordsOccupied :: AreaMap -> AreaMap -> n -> [Int] - } - -areaBuilder :: IGraphBuilder Area -areaBuilder = Builder fold words - where fold (a, _, _) f z = f a z - words areaSize areaMap a = - case lookupFM areaMap a of - Just addr -> [addr .. addr + (lookupFM areaSize a `orElse` - pprPanic "wordsOccupied: unknown area" (ppr a))] - Nothing -> [] - ---slotBuilder :: IGraphBuilder (Area, Int) ---slotBuilder = undefined - --- Now, we can build the interference graph. --- The usual story: a definition interferes with all live outs and all other --- definitions. -type IGraph x = FiniteMap x (Set x) -type IGPair x = (IGraph x, IGraphBuilder x) -igraph :: (Ord x) => IGraphBuilder x -> BlockEnv SubAreaSet -> LGraph Middle Last -> IGraph x -igraph builder env g = foldr interfere emptyFM (postorder_dfs 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 liveOut m) - -- 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, - addToFM out a (snd $ liveGen def (lookupWithDefaultFM out [] a))) - 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 = addToFM igraph n (addToFM set n' ()) - where set = lookupWithDefaultFM igraph emptyFM n - in foldFM (\ _ 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, emptyFM) - LastOther l -> (addEdges igraph l $ liveLastOut env' l, - liveLastIn env' l) - --- 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 :: LGraph Middle Last -> AreaMap -getAreaSize g@(LGraph _ off _) = - fold_blocks (fold_fwd_block first add add) (unitFM (CallArea Old) off) g - where first _ z = z - add x z = foldSlotsUsed addSlot (foldSlotsDefd addSlot z x) x - addSlot z (a, off, _) = addToFM z a $ max off $ lookupWithDefaultFM z 0 a - - --- Find the Stack slots occupied by the subarea's conflicts -conflictSlots :: Ord x => IGPair x -> AreaMap -> AreaMap -> SubArea -> Set Int -conflictSlots (ig, Builder foldNodes wordsOccupied) areaSize areaMap subarea = - foldNodes subarea foldNode emptyFM - where foldNode n set = foldFM conflict set $ lookupWithDefaultFM ig emptyFM n - conflict n' () set = liveInSlots areaMap n' set - -- Add stack slots occupied by igraph node n - liveInSlots areaMap n set = foldr setAdd set (wordsOccupied areaSize areaMap n) - setAdd w s = addToFM s w () - --- Find any open space on the stack, starting from the offset. -freeSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> Int -freeSlotFrom ig areaSize offset areaMap area = - let size = lookupFM areaSize area `orElse` 0 - conflicts = conflictSlots ig areaSize areaMap (area, size, size) - -- Find a space big enough to hold the area - findSpace curr 0 = curr - findSpace curr cnt = -- target slot, considerand, # left to check - if elemFM curr conflicts then - findSpace (curr + size) size - else findSpace (curr - 1) (cnt - 1) - in findSpace (offset + size) size - --- Find an open space on the stack, and assign it to the area. -allocSlotFrom :: Ord x => IGPair x -> AreaMap -> Int -> AreaMap -> Area -> AreaMap -allocSlotFrom ig areaSize from areaMap area = - if elemFM area areaMap then areaMap - else addToFM areaMap area $ freeSlotFrom ig areaSize from areaMap area - --- | Greedy stack layout. --- Compute liveness, build the interference graph, and allocate slots for the areas. --- We visit each basic block in a (generally) forward order. --- At each instruction that names a register subarea r, we immediately allocate --- any available slot on the stack by the following procedure: --- 1. Find the nodes N' that conflict with r --- 2. Find the stack slots used for N' --- 3. Choose a contiguous stack space s not in N' (s must be large enough to hold r) --- For a CallArea, we allocate the stack space only when we reach a function --- call that returns to the CallArea's blockId. --- We use a similar procedure, with one exception: the stack space --- must be allocated below the youngest stack slot that is live out. - --- 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 -> BlockEnv SubAreaSet -> LGraph Middle Last -> AreaMap -layout procPoints env g@(LGraph _ entrySp _) = - let builder = areaBuilder - ig = (igraph builder env g, builder) - env' bid = lookupBlockEnv env bid `orElse` panic "unknown blockId in igraph" - areaSize = getAreaSize g - -- Find the slots that are live-in to the block - live_in (ZTail m l) = liveInSlots (live_in l) m - live_in (ZLast (LastOther l)) = liveLastIn env' l - live_in (ZLast LastExit) = emptyFM - -- Find the youngest live stack slot - youngest_live areaMap live = fold_subareas young_slot live 0 - where young_slot (a, o, _) z = case lookupFM areaMap a of - Just top -> max z $ top + o - Nothing -> z - -- Allocate space for spill slots and call areas - allocVarSlot = allocSlotFrom ig areaSize 0 - allocCallSlot areaMap (Block id _ t) | elemBlockSet id procPoints = - allocSlotFrom ig areaSize (youngest_live areaMap $ live_in t) - areaMap (CallArea (Young id)) - allocCallSlot areaMap _ = areaMap - alloc i areaMap = foldSlotsDefd alloc' (foldSlotsUsed alloc' areaMap i) i - 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 areaMap) t - layout areaMap (ZLast _) = allocCallSlot areaMap b - areaMap = foldl layoutAreas (addToFM emptyFM (CallArea Old) 0) $ postorder_dfs g - in pprTrace "ProcPoints" (ppr procPoints) $ - pprTrace "Area SizeMap" (ppr areaSize) $ - pprTrace "Entry SP" (ppr entrySp) $ - pprTrace "Area Map" (ppr areaMap) $ areaMap - --- After determining the stack layout, we can: --- 1. Replace references to stack Areas with addresses relative to the stack --- pointer. --- 2. Insert adjustments to the stack pointer to ensure that it is at a --- conventional location at each proc point. --- Because we don't take interrupts on the execution stack, we only need the --- stack pointer to be younger than the live values on the stack at proc points. --- 3. At some point, we should check for stack overflow, but not just yet. -manifestSP :: ProcPointSet -> BlockEnv Status -> AreaMap -> - LGraph Middle Last -> FuelMonad (LGraph Middle Last) -manifestSP procPoints procMap areaMap g@(LGraph entry args blocks) = - liftM (LGraph entry args) blocks' - where blocks' = foldl replB (return emptyBlockEnv) (postorder_dfs g) - slot a = pprTrace "slot" (ppr a) $ lookupFM areaMap a `orElse` panic "unallocated Area" - slot' id = pprTrace "slot'" (ppr id)$ slot $ CallArea (Young id) - sp_on_entry id | id == entry = slot (CallArea Old) + args - sp_on_entry id | elemBlockSet id procPoints = - case lookupBlockEnv blocks id of - Just (Block _ (Just o) _) -> slot' id + o - Just (Block _ Nothing _) -> slot' id - Nothing -> panic "procpoint dropped from block env" - sp_on_entry id = - case lookupBlockEnv procMap id of - Just (ReachedBy pp) -> case uniqSetToList pp of - [id] -> sp_on_entry id - _ -> panic "block not reached by single proc point" - Just ProcPoint -> panic "procpoint not in procpoint set" - Nothing -> panic "block not found in procmap" - -- 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 o t) = - do bs <- replTail (Block id o) spIn t - pprTrace "spIn" (ppr id <+> ppr spIn)$ 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 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 _ 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@(LastReturn n) = updSp h spOff (slot (CallArea Old) + n) l - fixSp h spOff l@(LastJump _ n) = updSp h spOff (slot (CallArea Old) + n) l - fixSp h spOff l@(LastCall _ (Just k) n) = updSp h spOff (slot' k + n) l - fixSp h spOff l@(LastCall _ Nothing n) = updSp h spOff (slot (CallArea Old) + n) l - fixSp h spOff l@(LastBranch k) | elemBlockSet k procPoints = - pprTrace "updSp" (ppr k <> ppr spOff <> ppr (sp_on_entry k)) $ updSp h spOff (sp_on_entry k) 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 elemBlockSet succId procPoints && 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 - ----------------------------------------------------------------- --- Building InfoTables - -type CAFSet = FiniteMap CLabel () - --- First, an analysis to find live CAFs. -cafLattice :: DataflowLattice CAFSet -cafLattice = DataflowLattice "live cafs" emptyFM add True - where add new old = if sizeFM new' > sizeFM old then aTx new' else noTx new' - where new' = new `plusFM` old - -cafTransfers :: BackwardTransfers Middle Last CAFSet -cafTransfers = BackwardTransfers first middle last - where first live _ = live - middle live m = pprTrace "cafmiddle" (ppr m) $ foldExpDeepMiddle addCaf m live - last env l = foldExpDeepLast addCaf l (joinOuts cafLattice env l) - addCaf e set = case e of - CmmLit (CmmLabel c) -> add c set - CmmLit (CmmLabelOff c _) -> add c set - CmmLit (CmmLabelDiffOff c1 c2 _) -> add c1 $ add c2 set - _ -> set - add c s = pprTrace "CAF analysis saw label" (ppr c) $ - if hasCAF c then (pprTrace "has caf" (ppr c) $ addToFM s c ()) else (pprTrace "no cafs" (ppr c) $ s) - -type CafFix a = FuelMonad (BackwardFixedPoint Middle Last CAFSet a) -cafAnal :: LGraph Middle Last -> FuelMonad (BlockEnv CAFSet) -cafAnal g = liftM zdfFpFacts (res :: CafFix ()) - where res = zdfSolveFromL emptyBlockEnv "live CAF analysis" cafLattice - cafTransfers (fact_bot cafLattice) g - --- Once we have found the CAFs, we need to do two things: --- 1. Build a table of all the CAFs used in the procedure. --- 2. Compute the C_SRT describing the subset of CAFs live at each procpoint. -buildCafs :: (BlockEnv CAFSet) -> FuelMonad ([CmmTopZ], BlockEnv C_SRT) -buildCafs blockCafs = - -- This is surely the wrong way to get names, as in BlockId - do top_lbl <- getUniqueM >>= \ u -> return $ mkSRTLabel (mkFCallName u "srt") MayHaveCafRefs - let allCafs = foldBlockEnv (\_ x y -> plusFM x y) emptyFM blockCafs - caf_entry (ix, map, tbl') caf = (ix + 1, addToFM map caf ix, entry : tbl') - where entry = CmmStaticLit $ CmmLabel caf - (_::Int, cafMap, tbl') = foldl caf_entry (0, emptyFM, []) $ keysFM allCafs - top_tbl = CmmData RelocatableReadOnlyData $ CmmDataLabel top_lbl : reverse tbl' - sub_srt id cafs z = - do (tbls, blocks) <- z - (top, srt) <- procpointSRT top_lbl cafMap cafs - let blocks' = extendBlockEnv blocks id srt - case top of Just t -> return (t:tbls, blocks') - Nothing -> return (tbls, blocks') - (sub_tbls, blockSRTs) <- foldBlockEnv sub_srt (return ([], emptyBlockEnv)) blockCafs - return (top_tbl : sub_tbls, blockSRTs) - --- Construct an SRT bitmap. --- Adapted from simpleStg/SRT.lhs, which expects Id's. -procpointSRT :: CLabel -> FiniteMap CLabel Int -> FiniteMap CLabel () -> - FuelMonad (Maybe CmmTopZ, C_SRT) -procpointSRT top_srt top_table entries - | isEmptyFM entries = pprTrace "nil SRT" (ppr top_srt) $ return (Nothing, NoC_SRT) - | otherwise = pprTrace "non-nil SRT" (ppr top_srt) $ bitmap `seq` to_SRT top_srt offset len bitmap - where - ints = map (expectJust "constructSRT" . lookupFM top_table) (keysFM entries) - sorted_ints = sortLe (<=) ints - offset = head sorted_ints - bitmap_entries = map (subtract offset) sorted_ints - len = P.last bitmap_entries + 1 - bitmap = intsToBitmap len bitmap_entries - --- Adapted from codeGen/StgCmmUtils, which converts from SRT to C_SRT. -to_SRT :: CLabel -> Int -> Int -> Bitmap -> FuelMonad (Maybe CmmTopZ, C_SRT) -to_SRT top_srt off len bmp - | len > widthInBits wordWidth `div` 2 || bmp == [fromIntegral srt_escape] - = do id <- getUniqueM - let srt_desc_lbl = mkLargeSRTLabel id - tbl = CmmData RelocatableReadOnlyData $ - CmmDataLabel srt_desc_lbl : map CmmStaticLit - ( cmmLabelOffW top_srt off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) - return (Just tbl, C_SRT srt_desc_lbl 0 srt_escape) - | otherwise - = return (Nothing, C_SRT top_srt off (fromIntegral (head bmp))) - -- The fromIntegral converts to StgHalfWord - --- Given a block ID, we return a representation of the layout of the stack. --- If the element is `Nothing`, then it represents an empty or dead --- word on the stack. --- If the element is `Just` a register, then it represents a live spill slot --- for the register; note that a register may occupy multiple words. --- The head of the list represents the young end of the stack where the infotable --- pointer for the block `Bid` is stored. --- The infotable pointer itself is not included in the list. -live_vars :: BlockEnv SubAreaSet -> AreaMap -> BlockId -> [Maybe LocalReg] -live_vars slotEnv areaMap bid = slotsToList youngByte liveSlots - where slotsToList 0 [] = [] - slotsToList 0 ((_, r, _) : _) = pprPanic "slot left off live_vars" (ppr r) - slotsToList n _ | n < 0 = panic "stack slots not allocated on word boundaries?" - slotsToList n ((n', r, w) : rst) = - if n == n' then Just r : slotsToList (n - w) rst - else Nothing : slotsToList (n - wORD_SIZE) rst - slotsToList n [] = Nothing : slotsToList (n - wORD_SIZE) [] - liveSlots = sortBy (\ (_,off,_) (_,off',_) -> compare off' off) - (foldFM (\_ -> flip $ foldr add_slot) [] slots) - add_slot (a@(RegSlot r@(LocalReg _ ty)), off, w) rst = - if off == w && widthInBytes (typeWidth ty) == w then - (expectJust "add_slot" (lookupFM areaMap a), r, w) : rst - else panic "live_vars: only part of a variable live at a proc point" - add_slot (CallArea Old, off, w) rst = - if off == wORD_SIZE && w == wORD_SIZE then - rst -- the return infotable should be live - else pprPanic "CallAreas must not be live across function calls" (ppr bid) - add_slot (CallArea (Young _), _, _) _ = - pprPanic "CallAreas must not be live across function calls" (ppr bid) - slots = expectJust "live_vars slots" $ lookupBlockEnv slotEnv bid - youngByte = expectJust "live_vars bid_pos" $ lookupFM areaMap (CallArea (Young bid)) + where lbl = expectJust "pp label" $ lookupFM procLabels bid + -- 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] ---------------------------------------------------------------- diff --git a/compiler/cmm/CmmSpillReload.hs b/compiler/cmm/CmmSpillReload.hs index 67cf8d3..be043fe 100644 --- a/compiler/cmm/CmmSpillReload.hs +++ b/compiler/cmm/CmmSpillReload.hs @@ -8,7 +8,6 @@ module CmmSpillReload , availRegsLattice , cmmAvailableReloads , insertLateReloads - , insertLateReloads' , removeDeadAssignmentsAndReloads ) where @@ -25,7 +24,6 @@ import ZipCfg import ZipCfgCmmRep import ZipDataflow -import Maybes import Monad import Outputable hiding (empty) import qualified Outputable as PP @@ -63,7 +61,7 @@ dualUnionList ls = DualLive ss rs changeStack, changeRegs :: (RegSet -> RegSet) -> DualLive -> DualLive changeStack f live = live { on_stack = f (on_stack live) } -changeRegs f live = live { in_regs = f (in_regs live) } +changeRegs f live = live { in_regs = f (in_regs live) } dualLiveLattice :: DataflowLattice DualLive @@ -79,33 +77,37 @@ dualLiveLattice = type LiveReloadFix a = FuelMonad (BackwardFixedPoint Middle Last DualLive a) dualLivenessWithInsertion :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -dualLivenessWithInsertion procPoints g = +dualLivenessWithInsertion procPoints g@(LGraph entry _ _) = liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last)) where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dual liveness with insertion" - dualLiveLattice (dualLiveTransfers procPoints) - (insertSpillAndReloadRewrites procPoints) empty g + dualLiveLattice (dualLiveTransfers entry procPoints) + (insertSpillAndReloadRewrites entry procPoints) empty g empty = fact_bot dualLiveLattice dualLiveness :: BlockSet -> LGraph Middle Last -> FuelMonad (BlockEnv DualLive) -dualLiveness procPoints g = liftM zdfFpFacts $ (res :: LiveReloadFix ()) +dualLiveness procPoints g@(LGraph entry _ _) = + liftM zdfFpFacts $ (res :: LiveReloadFix ()) where res = zdfSolveFromL emptyBlockEnv "dual liveness" dualLiveLattice - (dualLiveTransfers procPoints) empty g + (dualLiveTransfers entry procPoints) empty g empty = fact_bot dualLiveLattice -dualLiveTransfers :: BlockSet -> BackwardTransfers Middle Last DualLive -dualLiveTransfers procPoints = BackwardTransfers first middle last +dualLiveTransfers :: BlockId -> BlockSet -> BackwardTransfers Middle Last DualLive +dualLiveTransfers entry procPoints = BackwardTransfers first middle last where last = lastDualLiveness middle = middleDualLiveness - first live _id = - if elemBlockSet _id procPoints then -- live at procPoint => spill + first live id = 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 :: DualLive -> Middle -> DualLive middleDualLiveness live m = - changeStack updSlots $ changeRegs (middleLiveness m) live - where updSlots live = foldSlotsUsed reload (foldSlotsDefd spill live m) m + 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 @@ -116,37 +118,39 @@ middleDualLiveness live m = lastDualLiveness :: (BlockId -> DualLive) -> Last -> DualLive lastDualLiveness env l = last l - where last (LastReturn _) = empty - last (LastJump e _) = changeRegs (gen e) empty - last (LastBranch id) = env id - last (LastCall tgt Nothing _) = changeRegs (gen tgt) empty - last (LastCall tgt (Just k) _) = - -- nothing can be live in registers at this point - let live = env k in - if isEmptyUniqSet (in_regs live) then - DualLive (on_stack live) (gen tgt emptyRegSet) - else - pprTrace "Offending party:" (ppr k <+> ppr live) $ - panic "live values in registers at call continuation" - last (LastCondBranch e t f) = changeRegs (gen e) $ dualUnion (env t) (env f) - last (LastSwitch e tbl) = changeRegs (gen e) $ dualUnionList $ + where last (LastBranch id) = env id + last l@(LastCall tgt Nothing _ _) = changeRegs (gen l . kill l) empty + last l@(LastCall tgt (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 e t f) = + changeRegs (gen l . kill l) $ dualUnion (env t) (env f) + last l@(LastSwitch e tbl) = changeRegs (gen l . kill l) $ dualUnionList $ map env (catMaybes tbl) empty = fact_bot dualLiveLattice -gen :: UserOfLocalRegs a => a -> RegSet -> RegSet -gen a live = foldRegsUsed extendRegSet live a - -insertSpillAndReloadRewrites :: BlockSet -> BackwardRewrites Middle Last DualLive -insertSpillAndReloadRewrites procPoints = BackwardRewrites first middle last exit +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 + last _ _ = Nothing + exit = Nothing first live id = - if elemBlockSet id procPoints && not (isEmptyUniqSet reloads) then - Just $ mkMiddles $ map reload $ uniqSetToList reloads + if id /= entry && elemBlockSet id procPoints then + case map reload (uniqSetToList (in_regs live)) of + [] -> Nothing + is -> Just (mkMiddles is) else Nothing - where reloads = in_regs live - middleInsertSpillsAndReloads :: DualLive -> Middle -> Maybe (AGraph Middle Last) middleInsertSpillsAndReloads live m = middle m @@ -158,6 +162,11 @@ middleInsertSpillsAndReloads live m = middle m 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 @@ -168,10 +177,7 @@ spill, reload :: LocalReg -> Middle spill r = MidStore (regSlot r) (CmmReg $ CmmLocal r) reload r = MidAssign (CmmLocal r) (CmmLoad (regSlot r) $ localRegType r) -spillHead :: ZHead Middle -> RegSet -> ZHead Middle reloadTail :: RegSet -> ZTail Middle Last -> ZTail Middle Last -spillHead h regset = foldl spl h $ uniqSetToList regset - where spl h r = ZHead h $ spill r reloadTail regset t = foldl rel t $ uniqSetToList regset where rel t r = ZTail (reload r) t @@ -189,7 +195,7 @@ data AvailRegs = UniverseMinus RegSet availRegsLattice :: DataflowLattice AvailRegs -availRegsLattice = DataflowLattice "register gotten from reloads" empty add False +availRegsLattice = DataflowLattice "register gotten from reloads" empty add True -- last True <==> debugging on where empty = UniverseMinus emptyRegSet -- | compute in the Tx monad to track whether anything has changed @@ -229,7 +235,7 @@ cmmAvailableReloads :: LGraph Middle Last -> FuelMonad CmmAvail cmmAvailableReloads g = liftM zdfFpFacts $ (res :: AvailFix) where res = zdfSolveFromL emptyBlockEnv "available reloads" availRegsLattice avail_reloads_transfer empty g - empty = (fact_bot availRegsLattice) + empty = fact_bot availRegsLattice avail_reloads_transfer :: ForwardTransfers Middle Last AvailRegs avail_reloads_transfer = ForwardTransfers first middle last id @@ -248,40 +254,19 @@ akill a live = foldRegsUsed deleteFromAvail live a middleAvail :: Middle -> AvailRegs -> AvailRegs middleAvail m = middle m where middle m live = middle' m $ foldRegsUsed deleteFromAvail live m - middle' (MidComment {}) = id - middle' (MidAssign lhs _expr) = akill lhs - middle' (MidStore {}) = id - middle' (MidUnsafeCall _tgt ress _args) = akill ress - middle' (MidAddToContext {}) = id + middle' (MidComment {}) live = live + middle' (MidAssign lhs _expr) live = akill lhs live + middle' (MidStore {}) live = live + middle' (MidForeignCall _ _tgt ress _args) _ = AvailRegs emptyRegSet lastAvail :: AvailRegs -> Last -> LastOutFacts AvailRegs -lastAvail _ (LastCall _ (Just k) _) = LastOutFacts [(k, AvailRegs emptyRegSet)] +lastAvail _ (LastCall _ (Just k) _ _) = LastOutFacts [(k, AvailRegs emptyRegSet)] lastAvail avail l = LastOutFacts $ map (\id -> (id, avail)) $ succs l -insertLateReloads :: LGraph Middle Last -> FuelMonad (LGraph Middle Last) -insertLateReloads g = - do env <- cmmAvailableReloads g - mapM_blocks (insertM env) g - where insertM env b = fuelConsumingPass "late reloads" (insert b) - where avail id = lookupBlockEnv env id `orElse` AvailRegs emptyRegSet - insert (Block id off tail) fuel = - propagate (ZFirst id off) (avail id) tail fuel - propagate h avail (ZTail m t) fuel = - let (h', fuel') = maybe_add_reload h avail m fuel in - propagate (ZHead h' m) (middleAvail m avail) t fuel' - propagate h avail (ZLast l) fuel = - let (h', fuel') = maybe_add_reload h avail l fuel in - (zipht h' (ZLast l), fuel') - maybe_add_reload h avail node fuel = - let used = filterRegsUsed (elemAvail avail) node - in if not (canRewriteWithFuel fuel) || isEmptyUniqSet used - then (h,fuel) - else (spillHead h used, oneLessFuel fuel) - -type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs (LGraph Middle Last)) - -insertLateReloads' :: (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix) +type LateReloadFix = FuelMonad (ForwardFixedPoint Middle Last AvailRegs CmmGraph) + +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 rewrites bot g bot = fact_bot availRegsLattice @@ -290,7 +275,7 @@ insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix) middle :: AvailRegs -> Middle -> Maybe (AGraph Middle Last) last :: AvailRegs -> Last -> Maybe (AGraph Middle Last) middle avail m = maybe_reload_before avail m (ZTail m (ZLast LastExit)) - last avail l = maybe_reload_before avail l (ZLast (LastOther l)) + last avail l = maybe_reload_before avail l (ZLast (LastOther l)) exit _ = Nothing maybe_reload_before avail node tail = let used = filterRegsUsed (elemAvail avail) node @@ -298,10 +283,10 @@ insertLateReloads' g = liftM zdfFpContents $ (res :: LateReloadFix) else Just $ mkZTail $ reloadTail used tail removeDeadAssignmentsAndReloads :: BlockSet -> (LGraph Middle Last) -> FuelMonad (LGraph Middle Last) -removeDeadAssignmentsAndReloads procPoints g = +removeDeadAssignmentsAndReloads procPoints g@(LGraph entry _ _) = liftM zdfFpContents $ (res :: LiveReloadFix (LGraph Middle Last)) where res = zdfBRewriteFromL RewriteDeep emptyBlockEnv "dead-assignment & -reload elim" - dualLiveLattice (dualLiveTransfers procPoints) + dualLiveLattice (dualLiveTransfers entry procPoints) rewrites (fact_bot dualLiveLattice) g rewrites = BackwardRewrites first middle last exit exit = Nothing diff --git a/compiler/cmm/CmmZipUtil.hs b/compiler/cmm/CmmZipUtil.hs index 9f0993d..5171218 100644 --- a/compiler/cmm/CmmZipUtil.hs +++ b/compiler/cmm/CmmZipUtil.hs @@ -9,7 +9,6 @@ import Prelude hiding (last, unzip) import ZipCfg import Maybes -import UniqSet -- | Compute the predecessors of each /reachable/ block zipPreds :: LastNode l => LGraph m l -> BlockEnv BlockSet @@ -32,7 +31,7 @@ givesUniquePredecessorTo g = \id -> elemBlockSet id singlePreds add_pred pair@(single, multi) id = if elemBlockSet id multi then pair else if elemBlockSet id single then - (delOneFromUniqSet single id, extendBlockSet multi id) + (removeBlockSet single id, extendBlockSet multi id) else (extendBlockSet single id, multi) diff --git a/compiler/cmm/DFMonad.hs b/compiler/cmm/DFMonad.hs index cce112b..0bce264 100644 --- a/compiler/cmm/DFMonad.hs +++ b/compiler/cmm/DFMonad.hs @@ -19,7 +19,6 @@ import OptimizationFuel import Control.Monad import Maybes import Outputable -import UniqFM import UniqSupply {- @@ -74,7 +73,7 @@ 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) + (f lattice $ DFState NoChange emptyBlockEnv (fact_bot lattice) [] NoChange) >>= return . fst class DataflowAnalysis m where @@ -153,7 +152,7 @@ instance Monad m => DataflowAnalysis (DFM' m) where botFact = DFM' f where f lattice s = return (fact_bot lattice, s) forgetFact id = DFM' f - where f _ s = return ((), s { df_facts = delFromUFM (df_facts s) id }) + 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 @@ -175,7 +174,7 @@ instance Monad m => DataflowAnalysis (DFM' m) where text "env is", pprFacts facts]) ; setFact id a } } - where pprFacts env = vcat (map pprFact (ufmToList env)) + where pprFacts env = vcat (map pprFact (blockEnvToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) lattice = DFM' f diff --git a/compiler/cmm/MkZipCfg.hs b/compiler/cmm/MkZipCfg.hs index 0b549fa..332b464 100644 --- a/compiler/cmm/MkZipCfg.hs +++ b/compiler/cmm/MkZipCfg.hs @@ -6,16 +6,15 @@ module MkZipCfg , mkMiddle, mkMiddles, mkLast, mkZTail, mkBranch, mkLabel, mkIfThenElse, mkWhileDo , outOfLine , emptyGraph, graphOfMiddles, graphOfZTail - , lgraphOfAGraph, graphOfAGraph, labelAGraph + , lgraphOfAGraph, graphOfAGraph, labelAGraph, pprAGraph ) where -import BlockId (BlockId(..), emptyBlockEnv) +import BlockId (BlockId(..), emptyBlockEnv, plusBlockEnv) import ZipCfg import Outputable import Unique -import UniqFM import UniqSupply import Util @@ -167,7 +166,7 @@ catAGraphs :: [AGraph m l] -> AGraph m l emptyAGraph :: AGraph m l mkLabel :: (LastNode l) => - BlockId -> Maybe Int -> AGraph m l -- graph contains the label + BlockId -> StackInfo -> 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 @@ -264,7 +263,8 @@ emptyGraph = Graph (ZLast LastExit) emptyBlockEnv labelAGraph id args g = do Graph tail blocks <- graphOfAGraph g - return $ LGraph id args $ insertBlock (Block id Nothing tail) blocks + return $ LGraph id args $ insertBlock (Block id stackInfo tail) blocks + where stackInfo = StackInfo Nothing Nothing lgraphOfAGraph args g = do id <- freshBlockId "graph entry" labelAGraph id args g @@ -291,12 +291,12 @@ graphOfZTail t = Graph t emptyBlockEnv mkLast l = AGraph f where f (Graph tail blocks) = - do note_this_code_becomes_unreachable tail + 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 utail + do note_this_code_becomes_unreachable "mkZTail" (ppr tail) utail return $ Graph tail blocks withFreshLabel name ofId = AGraph f @@ -310,36 +310,54 @@ withUnique ofU = AGraph f f' g outOfLine (AGraph f) = AGraph f' - where f' (Graph tail' blocks') = + where f' g@(Graph tail' blocks') = do Graph emptyEntrance blocks <- f emptyGraph - note_this_code_becomes_unreachable emptyEntrance - return $ Graph tail' (blocks `plusUFM` blocks') - + 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 Nothing <*> tbranch <*> mkBranch endif <*> - mkLabel fid Nothing <*> fbranch <*> mkLabel endif Nothing + mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*> + mkLabel fid emptyStackInfo <*> fbranch <*> + mkLabel endif emptyStackInfo 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 Nothing <*> body <*> mkLabel test Nothing - <*> cbranch head endwhile <*> mkLabel endwhile Nothing + mkBranch test <*> mkLabel head emptyStackInfo <*> body + <*> mkLabel test emptyStackInfo <*> cbranch head endwhile + <*> mkLabel endwhile emptyStackInfo -- | 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) => ZTail middle l -> m () + (Monad m, LastNode l, Outputable middle, Outputable l) => + String -> SDoc -> ZTail middle l -> m () -note_this_code_becomes_unreachable = if debugIsOn then u else \_ -> return () +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: " ++ showSDoc (ppr tail)) + 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] @@ -353,11 +371,3 @@ Emitting a Branch at this point is fine: -} --- | 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 - diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs index 1d80650..4b073e2 100644 --- a/compiler/cmm/MkZipCfgCmm.hs +++ b/compiler/cmm/MkZipCfgCmm.hs @@ -6,15 +6,16 @@ -- complain to Norman Ramsey. module MkZipCfgCmm - ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkUnsafeCall, mkFinalCall - , mkJump, mkCbranch, mkSwitch, mkReturn, mkComment, copyIn, copyOut, mkEntry - , mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo - , mkAddToContext + ( mkNop, mkAssign, mkStore, mkCall, mkCmmCall, mkSafeCall, mkUnsafeCall, mkFinalCall + , mkJump, mkForeignJump, mkJumpGC, mkCbranch, mkSwitch, mkReturn + , mkReturnSimple, mkComment, copyIn, copyOut + , mkEntry, mkCmmIfThenElse, mkCmmIfThen, mkCmmWhileDo , (<*>), catAGraphs, mkLabel, mkBranch , emptyAGraph, withFreshLabel, withUnique, outOfLine , lgraphOfAGraph, graphOfAGraph, labelAGraph , CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph , Middle, Last, Convention(..), ForeignConvention(..), MidCallTarget(..), Transfer(..) + , emptyStackInfo, stackStubExpr, pprAGraph ) where @@ -31,11 +32,11 @@ import ZipCfgCmmRep hiding (CmmGraph, CmmAGraph, CmmBlock, CmmZ, CmmTopZ) -- duplicated below import PprCmm() -import ClosureInfo import FastString import ForeignCall import MkZipCfg import Panic +import StaticFlags import ZipCfg type CmmGraph = LGraph Middle Last @@ -55,21 +56,24 @@ mkAssign :: CmmReg -> CmmExpr -> CmmAGraph mkStore :: CmmExpr -> CmmExpr -> CmmAGraph ---------- Calls -mkCall :: CmmExpr -> CCallConv -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph -mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> C_SRT -> CmmAGraph +mkCall :: CmmExpr -> Convention -> CmmFormals -> CmmActuals -> + UpdFrameOffset -> CmmAGraph +mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> + UpdFrameOffset -> CmmAGraph -- Native C-- calling convention -mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph -mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> CmmAGraph +mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph +mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph +mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph -- Never returns; like exit() or barf() ----------- Context manipulation ("return via") -mkAddToContext :: CmmExpr -> [CmmExpr] -> CmmAGraph - ---------- Control transfer -mkJump :: CmmExpr -> CmmActuals -> CmmAGraph +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 :: CmmActuals -> CmmAGraph +mkReturn :: CmmExpr -> CmmActuals -> UpdFrameOffset -> CmmAGraph +mkReturnSimple :: CmmActuals -> UpdFrameOffset -> CmmAGraph mkCmmIfThenElse :: CmmExpr -> CmmAGraph -> CmmAGraph -> CmmAGraph mkCmmIfThen :: CmmExpr -> CmmAGraph -> CmmAGraph @@ -91,8 +95,8 @@ mkCmmIfThen e tbranch = withFreshLabel "end of if" $ \endif -> withFreshLabel "start of then" $ \tid -> mkCbranch e tid endif <*> - mkLabel tid Nothing <*> tbranch <*> mkBranch endif <*> - mkLabel endif Nothing + mkLabel tid emptyStackInfo <*> tbranch <*> mkBranch endif <*> + mkLabel endif emptyStackInfo @@ -100,52 +104,68 @@ mkCmmIfThen e tbranch mkNop = emptyAGraph mkComment fs = mkMiddle $ MidComment fs -mkAssign l r = mkMiddle $ MidAssign l r 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 +mkSwitch e tbl = mkLast $ LastSwitch e tbl -mkUnsafeCall tgt results actuals = mkMiddle $ MidUnsafeCall tgt results actuals -mkAddToContext ra actuals = mkMiddle $ MidAddToContext ra actuals +mkSafeCall t fs as upd = + withFreshLabel "safe call" $ \k -> + mkMiddle $ MidForeignCall (Safe k upd) t fs as +mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as -cmmResConv :: Convention -cmmResConv = Native +-- For debugging purposes, we can stub out dead stack slots: +stackStubExpr :: Width -> CmmExpr +stackStubExpr w = CmmLit (CmmInt 0 w) -- Return the number of bytes used for copying arguments, as well as the -- instructions to copy the arguments. -copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, [Middle]) -copyIn _ isCall area formals = - foldr ci (init_offset, []) $ assignArgumentsPos isCall localRegType formals +copyIn :: Convention -> Bool -> Area -> CmmFormals -> (Int, AGraph Middle Last) +copyIn conv isCall area formals = + foldr ci (init_offset, mkNop) $ assignArgumentsPos conv isCall localRegType formals where ci (reg, RegisterParam r) (n, ms) = - (n, MidAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) : ms) + (n, mkAssign (CmmLocal reg) (CmmReg $ CmmGlobal r) <*> ms) ci (reg, StackParam off) (n, ms) = let ty = localRegType reg off' = off + init_offset in (max n off', - MidAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) : ms) + mkAssign (CmmLocal reg) (CmmLoad (CmmStackSlot area off') ty) <*> ms) init_offset = widthInBytes wordWidth -- 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. -copyOut :: Convention -> Transfer -> Area -> CmmActuals -> (Int, [Middle]) -copyOut _ transfer area@(CallArea a) actuals = +copyOut :: Convention -> Transfer -> Area -> CmmActuals -> UpdFrameOffset -> (Int, [Middle]) +copyOut conv transfer area@(CallArea a) actuals updfr_off = foldr co (init_offset, []) args' - where args = assignArgumentsPos skip_node cmmExprType actuals + where args = assignArgumentsPos conv skip_node cmmExprType actuals skip_node = transfer /= Ret (setRA, init_offset) = - case a of Young id -> -- set RA if making a call + case a of Young id@(BlockId _) -> -- set RA if making a call if transfer == Call then - ([(CmmLit (CmmLabel (infoTblLbl id)), - StackParam init_offset)], ra_width) + ([(CmmLit (CmmBlock id), StackParam init_offset)], ra_width) else ([], 0) - Old -> ([], ra_width) + Old -> ([], updfr_off) ra_width = widthInBytes wordWidth args' = foldl adjust setRA args where adjust rst (v, StackParam off) = (v, StackParam (off + init_offset)) : rst @@ -153,39 +173,47 @@ copyOut _ transfer area@(CallArea a) actuals = 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) -copyOut _ _ (RegSlot _) _ = panic "cannot copy arguments into a register slot" +copyOut _ _ (RegSlot _) _ _ = panic "cannot copy arguments into a register slot" mkEntry :: BlockId -> Convention -> CmmFormals -> (Int, CmmAGraph) -mkEntry _ conv formals = - let (off, copies) = copyIn conv False (CallArea Old) formals in - (off, mkMiddles copies) - --- I'm not sure how to get the calling conventions right yet, --- and I suspect this should not be resolved until sometime after --- Simon's patch is applied. --- For now, I apply a bogus calling convention: all arguments go on the --- stack, using the same amount of stack space. - -lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> (Int -> Last) -> CmmAGraph -lastWithArgs transfer area conv actuals last = - let (outArgs, copies) = copyOut conv transfer area actuals in +mkEntry _ conv formals = copyIn conv False (CallArea Old) formals + +lastWithArgs :: Transfer -> Area -> Convention -> CmmActuals -> UpdFrameOffset -> + (Int -> Last) -> CmmAGraph +lastWithArgs transfer area conv actuals updfr_off last = + let (outArgs, copies) = copyOut 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. -mkJump e actuals = lastWithArgs Jump (CallArea Old) cmmResConv actuals $ LastJump e -mkReturn actuals = lastWithArgs Ret (CallArea Old) cmmResConv actuals $ LastJump e - where e = CmmStackSlot (CallArea Old) (widthInBytes wordWidth) - -mkFinalCall f _ actuals = - lastWithArgs Call (CallArea Old) Native actuals $ LastCall f Nothing - -mkCmmCall f results actuals srt = mkCall f CmmCallConv results actuals srt +old :: Area +old = CallArea Old +toCall :: CmmExpr -> Maybe BlockId -> UpdFrameOffset -> Int -> Last +toCall e cont updfr_off arg_space = LastCall e cont arg_space (Just updfr_off) +mkJump e actuals updfr_off = + lastWithArgs Jump old Native actuals updfr_off $ toCall e Nothing updfr_off +mkJumpGC e actuals updfr_off = + lastWithArgs Jump old GC actuals updfr_off $ toCall e Nothing updfr_off +mkForeignJump conv e actuals updfr_off = + lastWithArgs Jump old conv actuals updfr_off $ toCall e Nothing updfr_off +mkReturn e actuals updfr_off = + lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off + -- where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord +mkReturnSimple actuals updfr_off = + lastWithArgs Ret old Native actuals updfr_off $ toCall e Nothing updfr_off + where e = CmmLoad (CmmStackSlot (CallArea Old) updfr_off) gcWord + +mkFinalCall f _ actuals updfr_off = + lastWithArgs Call old Native actuals updfr_off $ toCall f Nothing updfr_off + +mkCmmCall f results actuals = mkCall f Native results actuals -- I'm dropping the SRT, but that should be okay: we plan to reconstruct it later. -mkCall f _ results actuals _ = +mkCall f conv results actuals updfr_off = withFreshLabel "call successor" $ \k -> - let area = CallArea $ Young k - (off, copyin) = copyIn Native False area results - copyout = lastWithArgs Call area Native actuals $ LastCall f (Just k) - in copyout <*> mkLabel k (Just off) <*> (mkMiddles copyin) + let area = CallArea $ Young k + (off, copyin) = copyIn conv False area results + copyout = lastWithArgs Call area conv actuals updfr_off + (toCall f (Just k) updfr_off) + in (copyout <*> mkLabel k (StackInfo (Just off) (Just updfr_off)) + <*> copyin) diff --git a/compiler/cmm/OptimizationFuel.hs b/compiler/cmm/OptimizationFuel.hs index d9e8365..7de398a 100644 --- a/compiler/cmm/OptimizationFuel.hs +++ b/compiler/cmm/OptimizationFuel.hs @@ -59,7 +59,7 @@ diffFuel (OptimizationFuel f) (OptimizationFuel f') = f - f' -- type OptimizationFuel = State# () -- would like this, but it won't work data OptimizationFuel = OptimizationFuel deriving Show -tankFilledTo _ = undefined -- should be impossible to evaluate +tankFilledTo _ = panic "tankFilledTo" -- should be impossible to evaluate -- realWorld# might come in handy, too... canRewriteWithFuel OptimizationFuel = True maybeRewriteWithFuel _ ma = ma @@ -131,4 +131,5 @@ fuelDecrementState new_optimizer old new s = lGraphOfGraph :: Graph m l -> Int -> FuelMonad (LGraph m l) lGraphOfGraph (Graph tail blocks) args = do entry <- liftM BlockId $ getUniqueM - return $ LGraph entry args (insertBlock (Block entry Nothing tail) blocks) + return $ LGraph entry args + (insertBlock (Block entry emptyStackInfo tail) blocks) diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs index fea2374..374058f 100644 --- a/compiler/cmm/PprC.hs +++ b/compiler/cmm/PprC.hs @@ -140,6 +140,12 @@ pprTop top@(CmmData _section (CmmDataLabel lbl : lits)) = pprDataExterns lits $$ pprWordArray lbl lits +-- Floating info table for safe a foreign call. +pprTop top@(CmmData _section d@(_ : _)) + | CmmDataLabel lbl : lits <- reverse d = + pprDataExterns lits $$ + pprWordArray lbl lits + -- these shouldn't appear? pprTop (CmmData _ _) = panic "PprC.pprTop: can't handle this data" @@ -432,6 +438,8 @@ pprLit lit = case lit of -- these constants come from -- see #1861 + CmmBlock bid -> mkW_ <> pprCLabelAddr (infoTblLbl bid) + CmmHighStackMark -> panic "PprC printing high stack mark" CmmLabel clbl -> mkW_ <> pprCLabelAddr clbl CmmLabelOff clbl i -> mkW_ <> pprCLabelAddr clbl <> char '+' <> int i CmmLabelDiffOff clbl1 clbl2 i diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs index 4478dfd..a9e00fc 100644 --- a/compiler/cmm/PprCmm.hs +++ b/compiler/cmm/PprCmm.hs @@ -45,7 +45,6 @@ import CLabel import ForeignCall -import Unique import Outputable import FastString @@ -125,7 +124,7 @@ pprTop :: (Outputable d, Outputable info, Outputable i) pprTop (CmmProc info lbl params graph ) - = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace + = vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) , nest 8 $ lbrace <+> ppr info $$ rbrace , nest 4 $ ppr graph , rbrace ] @@ -154,13 +153,14 @@ instance Outputable CmmSafety where pprInfo :: CmmInfo -> SDoc pprInfo (CmmInfo _gc_target update_frame CmmNonInfoTable) = vcat [{-ptext (sLit "gc_target: ") <> - maybe (ptext (sLit "")) pprBlockId gc_target,-} + maybe (ptext (sLit "")) ppr gc_target,-} ptext (sLit "update_frame: ") <> maybe (ptext (sLit "")) pprUpdateFrame update_frame] pprInfo (CmmInfo _gc_target update_frame - (CmmInfoTable (ProfilingInfo closure_type closure_desc) tag info)) = + (CmmInfoTable stat_clos (ProfilingInfo closure_type closure_desc) tag info)) = vcat [{-ptext (sLit "gc_target: ") <> - maybe (ptext (sLit "")) pprBlockId gc_target,-} + maybe (ptext (sLit "")) ppr gc_target,-} + ptext (sLit "has static closure: ") <> ppr stat_clos <+> ptext (sLit "update_frame: ") <> maybe (ptext (sLit "")) pprUpdateFrame update_frame, ptext (sLit "type: ") <> pprLit closure_type, @@ -228,7 +228,7 @@ pprUpdateFrame (UpdateFrame expr args) = -- lbl: stmt ; stmt ; .. pprBBlock :: Outputable stmt => GenBasicBlock stmt -> SDoc pprBBlock (BasicBlock ident stmts) = - hang (pprBlockId ident <> colon) 4 (vcat (map ppr stmts)) + hang (ppr ident <> colon) 4 (vcat (map ppr stmts)) -- -------------------------------------------------------------------------- -- Statements. C-- usually, exceptions to this should be obvious. @@ -302,7 +302,7 @@ instance (Outputable a) => Outputable (CmmHinted a) where -- genBranch :: BlockId -> SDoc genBranch ident = - ptext (sLit "goto") <+> pprBlockId ident <> semi + ptext (sLit "goto") <+> ppr ident <> semi -- -------------------------------------------------------------------------- -- Conditional. [1], section 6.4 @@ -314,7 +314,7 @@ genCondBranch expr ident = hsep [ ptext (sLit "if") , parens(ppr expr) , ptext (sLit "goto") - , pprBlockId ident <> semi ] + , ppr ident <> semi ] -- -------------------------------------------------------------------------- -- A tail call. [1], Section 6.9 @@ -381,7 +381,7 @@ genSwitch expr maybe_ids in hsep [ ptext (sLit "case") , hcat (punctuate comma (map int is)) , ptext (sLit ": goto") - , pprBlockId (head [ id | Just id <- ids]) <> semi ] + , ppr (head [ id | Just id <- ids]) <> semi ] -- -------------------------------------------------------------------------- -- Expressions @@ -514,6 +514,8 @@ pprLit lit = case lit of 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 "" pprLit1 :: CmmLit -> SDoc pprLit1 lit@(CmmLabelOff {}) = parens (pprLit lit) @@ -614,12 +616,6 @@ pprSection s = case s of where section = ptext (sLit "section") --- -------------------------------------------------------------------------- --- Basic block ids --- -pprBlockId :: BlockId -> SDoc -pprBlockId b = ppr $ getUnique b - ----------------------------------------------------------------------------- commafy :: [SDoc] -> SDoc diff --git a/compiler/cmm/PprCmmZ.hs b/compiler/cmm/PprCmmZ.hs index c588466..30eb492 100644 --- a/compiler/cmm/PprCmmZ.hs +++ b/compiler/cmm/PprCmmZ.hs @@ -14,7 +14,6 @@ import qualified ZipCfg as Z import CmmZipUtil import Maybe -import UniqSet import FastString ---------------------------------------------------------------- @@ -54,23 +53,21 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) | 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.LastJump {}) -> endblock $ with_out out l - l@(G.LastReturn {}) -> endblock $ with_out out l - l@(G.LastSwitch {}) -> endblock $ with_out out l - l@(G.LastCall _ _ _)-> 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 "// ") preds = zipPreds g entry_has_no_pred = case lookupBlockEnv preds (Z.lg_entry g) of Nothing -> True - Just s -> isEmptyUniqSet s + 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 sizeUniqSet s == 1 then + Just s -> if sizeBlockSet s == 1 then extendBlockSet single id else single in Z.fold_blocks add emptyBlockSet g @@ -79,21 +76,14 @@ pprCmmGraphLikeCmm g = vcat (swallow blocks) 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 _) = + 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\""), - case k of Nothing -> ptext (sLit " never returns") - Just _ -> empty, + text " returns to " <+> ppr k, semi ] - last (G.LastReturn _) = ppr (CmmReturn $ noHints args) - last (G.LastJump e _) = ppr (CmmJump e $ noHints args) last l = ppr l ppr_target (CmmLit lit) = pprLit lit ppr_target fn' = parens (ppr fn') commafy xs = hsep $ punctuate comma xs - --- Anything that uses this is bogus! -noHints :: [a] -> [CmmHinted a] -noHints = map (\v -> CmmHinted v NoHint) diff --git a/compiler/cmm/StackColor.hs b/compiler/cmm/StackColor.hs index f3c1c32..03af181 100644 --- a/compiler/cmm/StackColor.hs +++ b/compiler/cmm/StackColor.hs @@ -33,11 +33,11 @@ fold_edge_facts_b f comp graph env z = head_fold (ZFirst id _) out z = f (bt_first_in comp out id) (f out z) foldConflicts :: (RegSet -> a -> a) -> a -> LGraph Middle Last -> FuelMonad a -foldConflicts f z g = +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 emptyBlockSet) g lookup 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 diff --git a/compiler/cmm/ZipCfg.hs b/compiler/cmm/ZipCfg.hs index 634bc8c..c1bd956 100644 --- a/compiler/cmm/ZipCfg.hs +++ b/compiler/cmm/ZipCfg.hs @@ -2,6 +2,7 @@ module ZipCfg ( -- These data types and names are carefully thought out Graph(..), LGraph(..), FGraph(..) , Block(..), ZBlock(..), ZHead(..), ZTail(..), ZLast(..) + , StackInfo(..), emptyStackInfo , insertBlock , HavingSuccessors, succs, fold_succs , LastNode, mkBranchNode, isBranchNode, branchNodeTarget @@ -37,14 +38,14 @@ where #include "HsVersions.h" import BlockId ( BlockId, BlockEnv, emptyBlockEnv, lookupBlockEnv, extendBlockEnv - , BlockSet, emptyBlockSet, elemBlockSet, extendBlockSet) + , BlockSet, emptyBlockSet, unitBlockSet, elemBlockSet, extendBlockSet + , delFromBlockEnv, foldBlockEnv', mapBlockEnv + , eltsBlockEnv, isNullBEnv, plusBlockEnv) import CmmExpr ( UserOfLocalRegs(..) ) import PprCmm() import Outputable hiding (empty) import Panic -import UniqFM -import UniqSet import Maybe import Prelude hiding (zip, unzip, last) @@ -78,7 +79,7 @@ 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 'ZipDataflow0'). +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 @@ -151,16 +152,29 @@ instance UserOfLocalRegs a => UserOfLocalRegs (ZLast a) where foldRegsUsed _f z LastExit = z -data ZHead m = ZFirst BlockId (Maybe Int) +data ZHead m = ZFirst BlockId StackInfo | 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] --- In addition to its id, the block carries the number of bytes of stack space --- used for incoming parameters on entry to the block. -data Block m l = Block BlockId (Maybe Int) (ZTail m l) + +-- For each block, we may need two pieces of information about the stack: +-- 1. If the block is a procpoint, how many bytes are used to pass +-- arguments on the stack? +-- 2. If the block succeeds a call, we need to generate an infotable +-- that describes the stack layout... but only up to the update frame! +-- Note that a block can be a proc point without requiring an infotable. +data StackInfo = StackInfo { argBytes :: Maybe Int + , returnOff :: Maybe Int } + deriving ( Eq ) +emptyStackInfo :: StackInfo +emptyStackInfo = StackInfo Nothing Nothing + +data Block m l = Block { bid :: BlockId + , stackInfo :: StackInfo + , tail :: ZTail m l } data Graph m l = Graph { g_entry :: (ZTail m l), g_blocks :: (BlockEnv (Block m l)) } @@ -284,8 +298,8 @@ fold_layout :: 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 +fold_fwd_block :: (BlockId -> StackInfo -> 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' @@ -378,7 +392,7 @@ unzip (Block id off t) = ZBlock (ZFirst id off) t head_id :: ZHead m -> BlockId head_id (ZFirst id _) = id -head_id (ZHead h _) = head_id h +head_id (ZHead h _) = head_id h last (ZBlock _ t) = lastTail t @@ -394,7 +408,7 @@ tailOfLast l = ZLast (LastOther l) -- tedious to write in every client 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) (delFromUFM blocks id) + 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 @@ -403,7 +417,7 @@ 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 $ foldUFM scan (Nothing, emptyBlockEnv) blocks +splitp_blocks p blocks = lift $ foldBlockEnv' scan (Nothing, emptyBlockEnv) blocks where scan b (yes, no) = case yes of Nothing | p b -> (Just b, no) @@ -422,14 +436,14 @@ insertBlock b bs = -- | Used in assertions; tells if a graph has exactly one exit single_exit :: LGraph l m -> Bool -single_exit g = foldUFM check 0 (lg_blocks g) == 1 +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) = foldUFM add (exit_count (lastTail tail)) blocks == 1 +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 @@ -456,12 +470,12 @@ single_exitg (Graph tail blocks) = foldUFM add (exit_count (lastTail tail)) bloc -- C -> D -- @ -- Then ordinary dfs would give [A,B,D,C] which has a back ref from C to D. --- Better to geot [A,B,C,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 (unitUniqSet id) + zip eblock : postorder_dfs_from_except blockenv eblock (unitBlockSet id) postorder_dfs_from_except :: (HavingSuccessors b, LastNode l) => BlockEnv (Block m l) -> b -> BlockSet -> [Block m l] @@ -507,10 +521,10 @@ fold_layout f z g@(LGraph eid _ _) = fold (postorder_dfs g) z -- | The rest of the traversals are straightforward -map_blocks f (LGraph eid off blocks) = LGraph eid off (mapUFM f blocks) +map_blocks f (LGraph eid off blocks) = LGraph eid off (mapBlockEnv f blocks) map_nodes idm middle last (LGraph eid off blocks) = - LGraph (idm eid) off (mapUFM (map_one_block idm middle last) blocks) + LGraph (idm eid) off (mapBlockEnv (map_one_block idm middle last) blocks) map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t) where tail (ZTail m t) = ZTail (middle m) (tail t) @@ -520,18 +534,18 @@ map_one_block idm middle last (Block id off t) = Block (idm id) off (tail t) mapM_blocks f (LGraph eid off blocks) = blocks' >>= return . LGraph eid off where blocks' = - foldUFM (\b mblocks -> do { blocks <- mblocks + foldBlockEnv' (\b mblocks -> do { blocks <- mblocks ; b <- f b ; return $ insertBlock b blocks }) (return emptyBlockEnv) blocks -fold_blocks f z (LGraph _ _ blocks) = foldUFM f z blocks -fold_fwd_block first middle last (Block id _ t) z = tail t (first id z) +fold_blocks f z (LGraph _ _ blocks) = foldBlockEnv' f z blocks +fold_fwd_block first middle last (Block id off t) z = tail t (first id off z) where tail (ZTail m t) z = tail t (middle m z) tail (ZLast l) z = last l z of_block_list e off blocks = LGraph e off $ foldr insertBlock emptyBlockEnv blocks -to_block_list (LGraph _ _ blocks) = eltsUFM blocks +to_block_list (LGraph _ _ blocks) = eltsBlockEnv blocks -- We want to be able to scrutinize a single-entry, single-exit 'LGraph' for @@ -544,7 +558,7 @@ prepare_for_splicing :: prepare_for_splicing g single multi = let FGraph _ gentry gblocks = entry g ZBlock _ etail = gentry - in if isNullUFM gblocks then + in if isNullBEnv gblocks then case last gentry of LastExit -> single etail _ -> panic "bad single block" @@ -560,7 +574,7 @@ 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 isNullUFM gblocks then + if isNullBEnv gblocks then case lastTail etail of LastExit -> single etail _ -> panic "bad single block" @@ -634,7 +648,7 @@ splice_head_only' head (Graph tail gblocks) = --- Translation translate txm txl (LGraph eid off blocks) = - do blocks' <- foldUFM txblock (return emptyBlockEnv) blocks + do blocks' <- foldBlockEnv' txblock (return emptyBlockEnv) blocks return $ LGraph eid off blocks' where -- txblock :: @@ -647,10 +661,10 @@ translate txm txl (LGraph eid off blocks) = txtail h (ZTail m t) blocks' = do m' <- txm m let (g, h') = splice_head h m' - txtail h' t (plusUFM (lg_blocks g) blocks') + txtail h' t (plusBlockEnv (lg_blocks g) blocks') txtail h (ZLast (LastOther l)) blocks' = do l' <- txl l - return $ plusUFM (lg_blocks (splice_head_only h l')) blocks' + return $ plusBlockEnv (lg_blocks (splice_head_only h l')) blocks' txtail h (ZLast LastExit) blocks' = return $ insertBlock (zipht h (ZLast LastExit)) blocks' @@ -672,6 +686,9 @@ instance (Outputable m, Outputable l, LastNode l) => Outputable (LGraph m l) whe instance (Outputable m, Outputable l, LastNode l) => Outputable (Block m l) where ppr = pprBlock +instance Outputable StackInfo where + ppr = pprStackInfo + instance (Outputable l) => Outputable (ZLast l) where ppr = pprLast @@ -683,8 +700,15 @@ pprLast :: (Outputable l) => ZLast l -> SDoc pprLast LastExit = text "" pprLast (LastOther l) = ppr l +pprStackInfo :: StackInfo -> SDoc +pprStackInfo cs = + text " ppr (argBytes cs) <+> + text "ret offset:" <+> ppr (returnOff cs) <> text ">" + pprBlock :: (Outputable m, Outputable l, LastNode l) => Block m l -> SDoc -pprBlock (Block id args tail) = ppr id <> parens (ppr args) <> colon $$ ppr tail +pprBlock (Block id stackInfo tail) = + ppr id <> parens (ppr stackInfo) <> colon + $$ (nest 3 (ppr tail)) pprLgraph :: (Outputable m, Outputable l, LastNode l) => LGraph m l -> SDoc pprLgraph g = text "{" <> text "offset" <> parens (ppr $ lg_argoffset g) $$ diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs index e030f4b..05203e5 100644 --- a/compiler/cmm/ZipCfgCmmRep.hs +++ b/compiler/cmm/ZipCfgCmmRep.hs @@ -1,5 +1,3 @@ - - -- 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 @@ -7,13 +5,12 @@ module ZipCfgCmmRep ( CmmZ, CmmTopZ, CmmGraph, CmmBlock, CmmAGraph - , Middle(..), Last(..), MidCallTarget(..) - , Convention(..), ForeignConvention(..) + , Middle(..), Last(..), MidCallTarget(..), UpdFrameOffset + , Convention(..), ForeignConvention(..), ForeignSafety(..) , ValueDirection(..), ForeignHint(..) , CmmBackwardFixedPoint, CmmForwardFixedPoint, pprHinted , insertBetween, mapExpMiddle, mapExpLast, mapExpDeepMiddle, mapExpDeepLast - , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast - , joinOuts + , foldExpMiddle, foldExpLast, foldExpDeepMiddle, foldExpDeepLast, joinOuts ) where @@ -43,6 +40,7 @@ import Monad import Outputable import Prelude hiding (zip, unzip, last) import qualified Data.List as L +import SMRep (ByteOff) import UniqSupply ---------------------------------------------------------------------- @@ -56,6 +54,8 @@ type CmmTopZ = GenCmmTop CmmStatic CmmInfo CmmGraph type CmmBackwardFixedPoint a = DF.BackwardFixedPoint Middle Last a () type CmmForwardFixedPoint a = DF.ForwardFixedPoint Middle Last a () +type UpdFrameOffset = ByteOff + data Middle = MidComment FastString @@ -64,18 +64,11 @@ data Middle | MidStore CmmExpr CmmExpr -- Assign to memory location. Size is -- given by cmmExprType of the rhs. - | MidUnsafeCall -- An "unsafe" foreign call; - MidCallTarget -- just a fat machine instructoin + | MidForeignCall -- A foreign call; + ForeignSafety -- Is it a safe or unsafe call? + MidCallTarget -- call target and convention CmmFormals -- zero or more results CmmActuals -- zero or more arguments - - | MidAddToContext -- Push a frame on the stack; - -- I will return to this frame - CmmExpr -- The frame's return address; it must be - -- preceded by an info table that describes the - -- live variables. - [CmmExpr] -- The frame's live variables, to go on the - -- stack with the first one at the young end deriving Eq data Last @@ -90,13 +83,17 @@ data Last -- zero -> first block -- one -> second block etc -- Undefined outside range, and when there's a Nothing - | LastReturn Int -- Return from a function; values in previous copy middles - | LastJump CmmExpr Int -- Tail call to another procedure; args in a copy middles - | LastCall { -- A call (native or safe foreign); args in copy middles - cml_target :: CmmExpr, -- never a CmmPrim to a CallishMachOp! - cml_cont :: Maybe BlockId,-- BlockId of continuation, if call returns - cml_args :: Int } -- liveness info for outgoing args - -- All the last nodes that pass arguments carry the size of the outgoing CallArea + | 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, -- bytes offset for youngest outgoing arg + cml_ret_off :: Maybe UpdFrameOffset} + -- stack offset for return (update frames); + -- The return offset should be Nothing only if we have to create + -- a new call, e.g. for a procpoint, in which case it's an invariant + -- that the call does not stand for a return or a tail call, + -- and the successor does not need an info table. data MidCallTarget -- The target of a MidUnsafeCall = ForeignTarget -- A foreign procedure @@ -110,6 +107,12 @@ data MidCallTarget -- The target of a MidUnsafeCall data Convention = Native -- Native C-- call/return + | Slow -- Slow entry points: all args pushed on the stack + + | GC -- Entry to the garbage collector: uses the node reg! + + | PrimOp -- Calling prim ops + | Foreign -- Foreign call/return ForeignConvention @@ -128,6 +131,12 @@ data ForeignConvention [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 + 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. @@ -161,13 +170,11 @@ insertBetween b ms succId = insert $ goto_end $ unzip b 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 _ _ _)) = + insert (_, LastOther (LastCall {})) = panic "unimp: insertBetween after a call -- probably not a good idea" - insert (_, LastOther (LastReturn _)) = panic "cannot insert after return" - insert (_, LastOther (LastJump _ _)) = panic "cannot insert after jump" insert (_, LastExit) = panic "cannot insert after exit" newBlocks = do id <- liftM BlockId $ getUniqueM - return $ (id, [Block id Nothing $ + return $ (id, [Block id emptyStackInfo $ foldr ZTail (ZLast (LastOther (LastBranch succId))) ms]) mbNewBlocks (Just k) = if k == succId then liftM lift newBlocks else return (Just k, []) @@ -189,33 +196,28 @@ instance LastNode Last where branchNodeTarget _ = panic "asked for target of non-branch" cmmSuccs :: Last -> [BlockId] -cmmSuccs (LastReturn _) = [] -cmmSuccs (LastJump {}) = [] -cmmSuccs (LastBranch id) = [id] -cmmSuccs (LastCall _ (Just id) _) = [id] -cmmSuccs (LastCall _ Nothing _) = [] -cmmSuccs (LastCondBranch _ t f) = [f, t] -- meets layout constraint -cmmSuccs (LastSwitch _ edges) = catMaybes edges +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 (LastReturn _) z = z -fold_cmm_succs _f (LastJump {}) z = z -fold_cmm_succs f (LastBranch id) z = f id z -fold_cmm_succs f (LastCall _ (Just id) _) z = f id z -fold_cmm_succs _f (LastCall _ Nothing _) z = 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 +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 (MidUnsafeCall tgt _ args) = fold f (fold f z tgt) args - middle (MidAddToContext ra args) = fold f (fold f z ra) args + 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 @@ -226,22 +228,27 @@ instance UserOfSlots MidCallTarget where foldSlotsUsed _f z (PrimTarget _) = z foldSlotsUsed f z (ForeignTarget e _) = foldSlotsUsed f z e +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 (LastReturn _) = z - last (LastJump e _) = foldRegsUsed f z e - last (LastBranch _id) = z - last (LastCall tgt _ _) = foldRegsUsed f z tgt + 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 (MidUnsafeCall _ _ _) = z - middle (MidAddToContext _ _) = z + 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 @@ -253,19 +260,16 @@ instance DefinerOfLocalRegs Last where 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 (MidUnsafeCall tgt _ress args) = fold f (fold f z tgt) args - middle (MidAddToContext ra args) = fold f (fold f z ra) args + 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 (LastReturn _) = z - last (LastJump e _) = foldSlotsUsed f z e - last (LastBranch _id) = z - last (LastCall tgt _ _) = foldSlotsUsed f z tgt + 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 @@ -275,13 +279,12 @@ instance UserOfSlots l => UserOfSlots (ZLast l) where instance DefinerOfSlots Middle where foldSlotsDefd f z m = middle m - where middle (MidComment {}) = z - middle (MidAssign _ _) = z + 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 - middle (MidUnsafeCall _ _ _) = z - middle (MidAddToContext _ _) = z + middle (MidStore _ _) = z instance DefinerOfSlots Last where foldSlotsDefd _ z _ = z @@ -297,32 +300,26 @@ 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 (MidUnsafeCall tgt fs as) = - MidUnsafeCall (mapExpMidcall exp tgt) fs (map exp as) -mapExpMiddle exp (MidAddToContext e es) = MidAddToContext (exp e) (map exp es) +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 (MidUnsafeCall tgt _ as) z = foldExpMidcall exp tgt $ foldr exp z as -foldExpMiddle exp (MidAddToContext e es) z = exp e $ foldr exp z es +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 s) = LastCall (exp tgt) mb_id s -mapExpLast exp (LastJump e s) = LastJump (exp e) s -mapExpLast _ (LastReturn s) = LastReturn s +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 u s) = LastCall (exp tgt) mb_id u 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 -foldExpLast exp (LastJump e _) z = exp e z -foldExpLast _ (LastReturn _) z = z +foldExpLast exp (LastCall tgt _ _ _) z = exp tgt z mapExpMidcall :: (CmmExpr -> CmmExpr) -> MidCallTarget -> MidCallTarget mapExpMidcall exp (ForeignTarget e c) = ForeignTarget (exp e) c @@ -334,8 +331,8 @@ 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 f es) -wrapRecExp f (CmmLoad addr ty) = f (CmmLoad (f addr) ty) +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 @@ -345,8 +342,8 @@ 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 f (f e z) es -wrapRecExpf f e@(CmmLoad addr _) z = f addr (f e 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 @@ -362,13 +359,11 @@ joinOuts lattice env l = let bot = fact_bot lattice join x y = txVal $ fact_add_to lattice x y in case l of - (LastReturn _) -> bot - (LastJump _ _) -> bot - (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) + (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) @@ -411,30 +406,30 @@ pprMiddle stmt = pp_stmt <+> pp_debug -- call "ccall" foo(x, y)[r1, r2]; -- ToDo ppr volatile - MidUnsafeCall target results args -> + MidForeignCall safety target results args -> hsep [ if null results then empty else parens (commafy $ map ppr results) <+> equals, + ppr_safety safety, ptext $ sLit "call", ppr_call_target target <> parens (commafy $ map ppr args) <> semi] - MidAddToContext ra args -> - hcat [ ptext $ sLit "return via " - , ppr_target ra, 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" - MidUnsafeCall {} -> text "MidUnsafeCall" - MidAddToContext {} -> text "MidAddToContext" + MidComment {} -> text "MidComment" + MidAssign {} -> text "MidAssign" + MidStore {} -> text "MidStore" + MidForeignCall {} -> text "MidForeignCall" ppr_fc :: ForeignConvention -> SDoc ppr_fc (ForeignConvention c _ _) = doubleQuotes (ppr c) +ppr_safety :: ForeignSafety -> SDoc +ppr_safety (Safe bid upd) = text "safe<" <> 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) = ppr (CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)) @@ -452,31 +447,24 @@ 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 - LastJump expr _ -> hcat [ ptext (sLit "jump"), space, pprFun expr - , ptext (sLit "(...)"), semi] - LastReturn _ -> hcat [ ptext (sLit "return"), space - , ptext (sLit "(...)"), semi] - LastSwitch arg ids -> ppr $ CmmSwitch arg ids - LastCall tgt k _ -> genBareCall tgt k + 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 off updfr_off -> genBareCall tgt k off updfr_off pp_debug = text " //" <+> case stmt of LastBranch {} -> text "LastBranch" LastCondBranch {} -> text "LastCondBranch" - LastJump {} -> text "LastJump" - LastReturn {} -> text "LastReturn" LastSwitch {} -> text "LastSwitch" LastCall {} -> text "LastCall" -genBareCall :: CmmExpr -> Maybe BlockId -> SDoc -genBareCall fn k = +genBareCall :: CmmExpr -> Maybe BlockId -> Int -> Maybe UpdFrameOffset -> SDoc +genBareCall fn k off updfr_off = hcat [ ptext (sLit "call"), space , pprFun fn, ptext (sLit "(...)"), space - , case k of Nothing -> ptext (sLit "never returns") - Just k -> ptext (sLit "returns to") <+> ppr k + , ptext (sLit "returns to") <+> ppr k <+> parens (ppr off) + , ptext (sLit " with update frame") <+> ppr updfr_off , semi ] - where pprFun :: CmmExpr -> SDoc pprFun f@(CmmLit _) = ppr f @@ -493,7 +481,10 @@ genFullCondBranch expr t f = ] pprConvention :: Convention -> SDoc -pprConvention (Native {}) = empty +pprConvention (Native {}) = text "" +pprConvention Slow = text "" +pprConvention GC = text "" +pprConvention PrimOp = text "" pprConvention (Foreign c) = ppr c pprConvention (Private {}) = text "" diff --git a/compiler/cmm/ZipCfgExtras.hs b/compiler/cmm/ZipCfgExtras.hs index acddbae..660f8e5 100644 --- a/compiler/cmm/ZipCfgExtras.hs +++ b/compiler/cmm/ZipCfgExtras.hs @@ -71,6 +71,6 @@ foldM_fwd_block first middle last (Block id _ t) z = do { z <- first id z; tail splitp_blocks :: (Block m l -> Bool) -> BlockEnv (Block m l) -> Maybe (Block m l, BlockEnv (Block m l)) -splitp_blocks = undefined -- implemented in ZipCfg but not exported +splitp_blocks = panic "splitp_blocks" -- implemented in ZipCfg but not exported is_exit :: Block m l -> Bool -is_exit = undefined -- implemented in ZipCfg but not exported +is_exit = panic "is_exit" -- implemented in ZipCfg but not exported diff --git a/compiler/cmm/ZipDataflow.hs b/compiler/cmm/ZipDataflow.hs index de2f53d..2d50165 100644 --- a/compiler/cmm/ZipDataflow.hs +++ b/compiler/cmm/ZipDataflow.hs @@ -30,7 +30,6 @@ import qualified ZipCfg as G import Maybes import Outputable import Panic -import UniqFM import Control.Monad import Maybe @@ -148,10 +147,6 @@ newtype LastOutFacts a = LastOutFacts [(BlockId, a)] -- | A backward rewrite takes the same inputs as a backward transfer, -- but instead of producing a fact, it produces a replacement graph or Nothing. --- The type of the replacement graph is given as a type parameter 'g' --- of kind * -> * -> *. This design offers great flexibility to clients, --- but it might be worth simplifying this module by replacing this type --- parameter with AGraph everywhere (SLPJ 19 May 2008). data BackwardRewrites middle last a = BackwardRewrites { br_first :: a -> BlockId -> Maybe (AGraph middle last) @@ -433,11 +428,11 @@ areturn g = liftToDFM $ liftUniq $ graphOfAGraph g -- 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 (eltsUFM blocks) $ \block -> any (== eid) (succs block) then + 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 (delFromUFM blocks eid) + in Graph entry (delFromBlockEnv blocks eid) class (Outputable m, Outputable l, LastNode l, Outputable (LGraph m l)) => DebugNodes m l @@ -453,7 +448,7 @@ fwd_pure_anal :: (DebugNodes m l, LastNode l, Outputable 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 -- definitiely a case of "I love lazy evaluation" + 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" @@ -643,7 +638,8 @@ forward_rew check_maybe = forw in do { solve depth name start transfers rewrites in_fact g fuel ; eid <- freshBlockId "temporary entry id" ; (rewritten, fuel) <- - rew_tail (ZFirst eid Nothing) in_fact entry emptyBlockEnv fuel + rew_tail (ZFirst eid emptyStackInfo) + in_fact entry emptyBlockEnv fuel ; (rewritten, fuel) <- rewrite_blocks blocks rewritten fuel ; a <- finish ; return (a, lgraphToGraph (LGraph eid 0 rewritten), fuel) @@ -682,7 +678,7 @@ forward_rew check_maybe = forw ; (outfact, g, fuel) <- inner_rew getExitFact a g fuel ; let (blocks, h) = splice_head' h g ; (rewritten, fuel) <- - rew_tail h outfact t (blocks `plusUFM` 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 = @@ -694,7 +690,7 @@ forward_rew check_maybe = forw ; 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 `plusUFM` rewritten) fuel + ; rew_tail h a t (blocks `plusBlockEnv` rewritten) fuel } rew_tail h in' (G.ZLast l) rewritten fuel = my_trace "Rewriting last node" (ppr l) $ @@ -705,7 +701,7 @@ forward_rew check_maybe = forw ; g <- areturn g ; ((), g, fuel) <- inner_rew (return ()) in' g fuel ; let g' = G.splice_head_only' h g - ; return (G.lg_blocks g' `plusUFM` rewritten, fuel) + ; 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 in' l @@ -805,13 +801,16 @@ backward_sol check_maybe = back ; (a, fuel) <- case check_maybe fuel $ last_rew env l of Nothing -> return (last_in env l, fuel) - Just g -> subsolve g exit_fact 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 Nothing entry) fuel + ; fuel <- set_block_fact (Block eid emptyStackInfo entry) fuel ; a <- getFact eid ; forgetFact eid ; return (a, fuel) @@ -823,14 +822,20 @@ backward_sol check_maybe = back ppr (bt_first_in transfers a id)) $ setFact id $ bt_first_in transfers a id ; return fuel } - Just g -> do { (a, fuel) <- subsolve g a fuel - ; setFact id a + 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 a id ; return fuel } set_head_fact (G.ZHead h m) a fuel = case check_maybe fuel $ br_middle rewrites a m of Nothing -> set_head_fact h (bt_middle_in transfers a m) fuel - Just g -> do { (a, fuel) <- subsolve g 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 = @@ -898,11 +903,13 @@ backward_rew check_maybe = back in do { (FP env 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 () + -- ; 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 Nothing entry] rewritten fuel + ; (rewritten, fuel) <- + rewrite_blocks False [Block eid emptyStackInfo 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 () @@ -940,7 +947,7 @@ backward_rew check_maybe = back ; g <- areturn g ; (a, g, fuel) <- inner_rew g exit_fact fuel ; let G.Graph t new_blocks = g - ; let rewritten' = new_blocks `plusUFM` rewritten + ; 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 @@ -961,10 +968,11 @@ backward_rew check_maybe = back ; (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 `plusUFM` rewritten) } + propagate check fuel h a t (newblocks `plusBlockEnv` rewritten) } propagate check fuel (ZFirst id off) a tail rewritten = case maybeRewriteWithFuel fuel $ br_first rewrites a id of - Nothing -> do { if check then checkFactMatch id $ bt_first_in transfers a id + Nothing -> do { if check then + checkFactMatch id $ bt_first_in transfers a id else return () ; return (insertBlock (Block id off tail) rewritten, fuel) } Just g -> @@ -973,9 +981,10 @@ backward_rew check_maybe = back ; 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 a else return () + ; if check then checkFactMatch id (bt_first_in transfers a id) + else return () ; let Graph t newblocks = G.splice_tail g tail - ; let r = insertBlock (Block id off t) (newblocks `plusUFM` rewritten) + ; let r = insertBlock (Block id off t) (newblocks `plusBlockEnv` rewritten) ; return (r, fuel) } in fixed_pt_and_fuel @@ -1013,12 +1022,16 @@ run dir name do_block blocks b = where -- N.B. Each iteration starts with the same transaction limit; -- only the rewrites in the final iteration actually count - trace_block b block = - my_trace "about to do" (text name <+> text "on" <+> ppr (blockId block)) $ - do_block block b + 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 { markFactsUnchanged - ; b <- foldM trace_block b blocks + ; (b, _) <- + my_trace "block count:" (ppr (length blocks)) $ + foldM trace_block (b, 0 :: Int) blocks ; changed <- factsStatus ; facts <- getAllFacts ; let depth = 0 -- was nesting depth @@ -1043,7 +1056,7 @@ run dir name do_block blocks b = pprBlock (Block id off t) = nest 2 (pprFact' (id, off, t)) pprFacts depth n env = my_nest depth (text "facts for iteration" <+> pp_i n <+> text "are:" $$ - (nest 2 $ vcat $ map pprFact $ ufmToList env)) + (nest 2 $ vcat $ map pprFact $ blockEnvToList env)) pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) pprFact' (id, off, a) = hang (ppr id <> parens (ppr off) <> colon) 4 (ppr a) @@ -1058,10 +1071,10 @@ subAnalysis' :: (Monad (m f), DataflowAnalysis m, Outputable f) => subAnalysis' m = do { a <- subAnalysis $ do { a <- m; facts <- getAllFacts - ; my_trace "after sub-analysis facts are" (pprFacts facts) $ + ; -- my_trace "after sub-analysis facts are" (pprFacts facts) $ return a } ; facts <- getAllFacts - ; my_trace "in parent analysis facts are" (pprFacts facts) $ + ; -- my_trace "in parent analysis facts are" (pprFacts facts) $ return a } - where pprFacts env = nest 2 $ vcat $ map pprFact $ ufmToList env + where pprFacts env = nest 2 $ vcat $ map pprFact $ blockEnvToList env pprFact (id, a) = hang (ppr id <> colon) 4 (ppr a) diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index 9fbe4fb..9719d71 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -94,12 +94,12 @@ mkCmmInfo cl_info = do info = ConstrInfo (ptrs, nptrs) (fromIntegral (dataConTagZ con)) conName - return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) ClosureInfo { closureName = name, closureLFInfo = lf_info, closureSRT = srt } -> - return $ CmmInfo gc_target Nothing (CmmInfoTable prof cl_type info) + return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info) where info = case lf_info of @@ -152,7 +152,7 @@ emitReturnTarget name stmts ; let info = CmmInfo gc_target Nothing - (CmmInfoTable + (CmmInfoTable False (ProfilingInfo zeroCLit zeroCLit) rET_SMALL -- cmmToRawCmm may convert it to rET_BIG (ContInfo frame srt_info)) diff --git a/compiler/codeGen/StgCmm.hs b/compiler/codeGen/StgCmm.hs index 56cd1d5..0fc6c4c 100644 --- a/compiler/codeGen/StgCmm.hs +++ b/compiler/codeGen/StgCmm.hs @@ -104,43 +104,25 @@ variable. -} cgTopBinding :: DynFlags -> (StgBinding,[(Id,[Id])]) -> FCode () cgTopBinding dflags (StgNonRec id rhs, _srts) = do { id' <- maybeExternaliseId dflags id - --; mapM_ (mkSRT [id']) srts - ; (id,info) <- cgTopRhs id' rhs - ; addBindC id info -- Add the *un-externalised* Id to the envt, - -- so we find it when we look up occurrences + ; info <- cgTopRhs id' rhs + ; addBindC (cg_id info) info -- Add the *un-externalised* Id to the envt, + -- so we find it when we look up occurrences } cgTopBinding dflags (StgRec pairs, _srts) = do { let (bndrs, rhss) = unzip pairs ; bndrs' <- mapFCs (maybeExternaliseId dflags) bndrs ; let pairs' = zip bndrs' rhss - --; mapM_ (mkSRT bndrs') srts ; fixC (\ new_binds -> do { addBindsC new_binds ; mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs' }) ; return () } ---mkSRT :: [Id] -> (Id,[Id]) -> FCode () ---mkSRT these (id,ids) --- | null ids = nopC --- | otherwise --- = do { ids <- mapFCs remap ids --- ; id <- remap id --- ; emitRODataLits (mkSRTLabel (idName id) (idCafInfo id)) --- (map (\id -> CmmLabel $ mkClosureLabel (idName id) (idCafInfo id)) ids) --- } --- where --- -- Sigh, better map all the ids against the environment in --- -- case they've been externalised (see maybeExternaliseId below). --- remap id = case filter (==id) these of --- (id':_) -> returnFC id' --- [] -> do { info <- getCgIdInfo id; return (cgIdInfoId info) } - -- Urgh! I tried moving the forkStatics call from the rhss of cgTopRhs -- to enclose the listFCs in cgTopBinding, but that tickled the -- statics "error" call in initC. I DON'T UNDERSTAND WHY! -cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) +cgTopRhs :: Id -> StgRhs -> FCode CgIdInfo -- The Id is passed along for setting up a binding... -- It's already been externalised if necessary @@ -153,7 +135,6 @@ cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag srt args body) forkStatics (cgTopRhsClosure bndr cc bi upd_flag srt args body) - --------------------------------------------------------------- -- Module initialisation code --------------------------------------------------------------- @@ -213,14 +194,17 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info -- In this way, Hpc enabled modules can interact seamlessly with -- not Hpc enabled moduled, provided Main is compiled with Hpc. - ; emitSimpleProc real_init_lbl $ withFreshLabel "ret_block" $ \retId -> catAGraphs - [ check_already_done retId + ; updfr_sz <- getUpdFrameOff + ; tail <- getCode (pushUpdateFrame imports + (do updfr_sz' <- getUpdFrameOff + emit $ mkReturn (ret_e updfr_sz') [] (pop_ret_loc updfr_sz'))) + ; emitSimpleProc real_init_lbl $ (withFreshLabel "ret_block" $ \retId -> catAGraphs + [ check_already_done retId updfr_sz , init_prof , init_hpc - , catAGraphs $ map (registerImport way) all_imported_mods - , mkBranch retId ] + , tail]) -- Make the "plain" procedure jump to the "real" init procedure - ; emitSimpleProc plain_init_lbl jump_to_init + ; emitSimpleProc plain_init_lbl (jump_to_init updfr_sz) -- When compiling the module in which the 'main' function lives, -- (that is, this_mod == main_mod) @@ -233,14 +217,14 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info ; whenC (this_mod == main_mod) - (emitSimpleProc plain_main_init_lbl rec_descent_init) + (emitSimpleProc plain_main_init_lbl (rec_descent_init updfr_sz)) } where plain_init_lbl = mkPlainModuleInitLabel this_mod real_init_lbl = mkModuleInitLabel this_mod way plain_main_init_lbl = mkPlainModuleInitLabel rOOT_MAIN - jump_to_init = mkJump (mkLblExpr real_init_lbl) [] + jump_to_init updfr_sz = mkJump (mkLblExpr real_init_lbl) [] updfr_sz -- Main refers to GHC.TopHandler.runIO, so make sure we call the @@ -249,34 +233,30 @@ mkModuleInit way cost_centre_info this_mod main_mod imported_mods hpc_info | this_mod == main_mod = [gHC_TOP_HANDLER] | otherwise = [] all_imported_mods = imported_mods ++ extra_imported_mods + imports = map (\mod -> mkLblExpr (mkModuleInitLabel mod way)) + (filter (gHC_PRIM /=) all_imported_mods) mod_reg_val = CmmLoad (mkLblExpr moduleRegdLabel) bWord - check_already_done retId + check_already_done retId updfr_sz = mkCmmIfThenElse (cmmNeWord (CmmLit zeroCLit) mod_reg_val) - (mkLabel retId Nothing <*> mkReturn []) mkNop + (mkLabel retId emptyStackInfo + <*> mkReturn (ret_e updfr_sz) [] (pop_ret_loc updfr_sz)) mkNop <*> -- Set mod_reg to 1 to record that we've been here mkStore (mkLblExpr moduleRegdLabel) (CmmLit (mkIntCLit 1)) -- The return-code pops the work stack by - -- incrementing Sp, and then jumpd to the popped item - ret_code = mkAssign spReg (cmmRegOffW spReg 1) - <*> mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] - - rec_descent_init = if opt_SccProfilingOn || isHpcUsed hpc_info - then jump_to_init - else ret_code - ------------------------ -registerImport :: String -> Module -> CmmAGraph -registerImport way mod - | mod == gHC_PRIM - = mkNop - | otherwise -- Push the init procedure onto the work stack - = mkCmmCall init_lbl [] [] NoC_SRT - where - init_lbl = mkLblExpr $ mkModuleInitLabel mod way + -- incrementing Sp, and then jumps to the popped item + ret_e updfr_sz = CmmLoad (CmmStackSlot (CallArea Old) updfr_sz) gcWord + ret_code updfr_sz = mkJump (ret_e updfr_sz) [] (pop_ret_loc updfr_sz) + -- mkAssign spReg (cmmRegOffW spReg 1) <*> + -- mkJump (CmmLoad (cmmRegOffW spReg (-1)) bWord) [] updfr_sz + pop_ret_loc updfr_sz = updfr_sz - widthInBytes (typeWidth bWord) + rec_descent_init updfr_sz = + if opt_SccProfilingOn || isHpcUsed hpc_info + then jump_to_init updfr_sz + else ret_code updfr_sz --------------------------------------------------------------- -- Generating static stuff for algebraic data types @@ -351,8 +331,7 @@ cgDataCon data_con (dyn_cl_info, arg_things) = layOutDynConstr data_con arg_reps emit_info cl_info ticky_code - = do { code_blks <- getCode (mk_code ticky_code) - ; emitClosureCodeAndInfoTable cl_info [] code_blks } + = emitClosureAndInfoTable cl_info [] $ mk_code ticky_code mk_code ticky_code = -- NB: We don't set CC when entering data (WDP 94/06) diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs index 0e8d853..0467678 100644 --- a/compiler/codeGen/StgCmmBind.hs +++ b/compiler/codeGen/StgCmmBind.hs @@ -9,11 +9,13 @@ module StgCmmBind ( cgTopRhsClosure, cgBind, - emitBlackHoleCode + emitBlackHoleCode, + pushUpdateFrame ) where #include "HsVersions.h" +import StgCmmExpr import StgCmmMonad import StgCmmExpr import StgCmmEnv @@ -35,6 +37,7 @@ import CLabel import StgSyn import CostCentre import Id +import Monad (foldM, liftM) import Name import Module import ListSetOps @@ -59,11 +62,11 @@ cgTopRhsClosure :: Id -> StgBinderInfo -> UpdateFlag -> SRT - -> [Id] -- Args + -> [Id] -- Args -> StgExpr - -> FCode (Id, CgIdInfo) + -> FCode CgIdInfo -cgTopRhsClosure id ccs binder_info upd_flag srt args body = do +cgTopRhsClosure id ccs _ upd_flag srt args body = do { -- LAY OUT THE OBJECT let name = idName id ; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args @@ -77,12 +80,15 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do -- BUILD THE OBJECT, AND GENERATE INFO TABLE (IF NECESSARY) ; emitDataLits closure_label closure_rep - ; forkClosureBody $ do - { node <- bindToReg id lf_info - ; closureCodeBody binder_info closure_info - ccs srt_info node args body } + ; let fv_details :: [(NonVoid Id, VirtualHpOffset)] + (_, _, 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 srt_info + (nonVoidIds args) (length args) body fv_details) - ; returnFC (id, cg_id_info) } + ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $ + returnFC cg_id_info } ------------------------------------------------------------------------ -- Non-top-level bindings @@ -90,36 +96,77 @@ cgTopRhsClosure id ccs binder_info upd_flag srt args body = do cgBind :: StgBinding -> FCode () cgBind (StgNonRec name rhs) - = do { (name, info) <- cgRhs name rhs - ; addBindC name info } + = do { ((info, init), body) <- getCodeR $ cgRhs name rhs + ; addBindC (cg_id info) info + ; emit (init <*> body) } cgBind (StgRec pairs) - = do { new_binds <- fixC (\ new_binds -> - do { addBindsC new_binds - ; listFCs [ cgRhs b e | (b,e) <- pairs ] }) - ; addBindsC new_binds } + = 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 + ; emit (catAGraphs inits <*> body) } + +{- Recursive let-bindings are tricky. + Consider the following pseudocode: + let x = \_ -> ... y ... + y = \_ -> ... z ... + z = \_ -> ... x ... + in ... + For each binding, we need to allocate a closure, and each closure must + capture the address of the other closures. + We want to generate the following C-- code: + // Initialization Code + x = hp - 24; // heap address of x's closure + y = hp - 40; // heap address of x's closure + z = hp - 64; // heap address of x's closure + // allocate and initialize x + m[hp-8] = ... + m[hp-16] = y // the closure for x captures y + m[hp-24] = x_info; + // allocate and initialize y + m[hp-32] = z; // the closure for y captures z + 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. + The complication here is that we don't know the heap offsets a priori, + which has two consequences: + 1. we need a fixpoint + 2. we can't trivially separate the Initialization Code from the + code that compiles the right-hand-sides + + Note: We don't need this complication with let-no-escapes, because + in that case, the names are bound to labels in the environment, + and we don't need to emit any code to witness that binding. +-} -------------------- -cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo) +cgRhs :: Id -> StgRhs -> FCode (CgIdInfo, CmmAGraph) -- The Id is passed along so a binding can be set up + -- The returned values are the binding for the environment + -- and the Initialization Code that witnesses the binding cgRhs name (StgRhsCon maybe_cc con args) - = do { idinfo <- buildDynCon name maybe_cc con args - ; return (name, idinfo) } + = buildDynCon name maybe_cc con args cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body) - = mkRhsClosure name cc bi fvs upd_flag srt args body + = pprTrace "cgRhs closure" (ppr name <+> ppr args) $ + mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body ------------------------------------------------------------------------ -- Non-constructor right hand sides ------------------------------------------------------------------------ mkRhsClosure :: Id -> CostCentreStack -> StgBinderInfo - -> [Id] -- Free vars + -> [NonVoid Id] -- Free vars -> UpdateFlag -> SRT - -> [Id] -- Args + -> [Id] -- Args -> StgExpr - -> FCode (Id, CgIdInfo) + -> FCode (CgIdInfo, CmmAGraph) {- mkRhsClosure looks for two special forms of the right-hand side: a) selector thunks @@ -158,7 +205,7 @@ for semi-obvious reasons. ---------- Note [Selectors] ------------------ mkRhsClosure bndr cc bi - [the_fv] -- Just one free var + [NonVoid the_fv] -- Just one free var upd_flag -- Updatable thunk _srt [] -- A thunk @@ -184,7 +231,7 @@ mkRhsClosure bndr cc bi (isUpdatable upd_flag) (_, params_w_offsets) = layOutDynConstr con (addIdReps params) -- Just want the layout - maybe_offset = assocMaybe params_w_offsets selectee + maybe_offset = assocMaybe params_w_offsets (NonVoid selectee) Just the_offset = maybe_offset offset_into_int = the_offset - fixedHdrSize @@ -197,7 +244,7 @@ mkRhsClosure bndr cc bi body@(StgApp fun_id args) | args `lengthIs` (arity-1) - && all isFollowableArg (map idCgRep fvs) + && all isFollowableArg (map (idCgRep . stripNV) fvs) && isUpdatable upd_flag && arity <= mAX_SPEC_AP_SIZE @@ -211,19 +258,19 @@ mkRhsClosure bndr cc bi arity = length fvs ---------- Default case ------------------ -mkRhsClosure bndr cc bi fvs upd_flag srt args body +mkRhsClosure bndr cc _ fvs upd_flag srt args body = do { -- LAY OUT THE OBJECT -- If the binder is itself a free variable, then don't store -- it in the closure. Instead, just bind it to Node on entry. -- NB we can be sure that Node will point to it, because we - -- havn't told mkClosureLFInfo about this; so if the binder + -- haven't told mkClosureLFInfo about this; so if the binder -- _was_ a free var of its RHS, mkClosureLFInfo thinks it *is* -- stored in the closure itself, so it will make sure that -- Node points to it... ; let is_elem = isIn "cgRhsClosure" - bndr_is_a_fv = bndr `is_elem` fvs - reduced_fvs | bndr_is_a_fv = fvs `minusList` [bndr] + bndr_is_a_fv = (NonVoid bndr) `is_elem` fvs + reduced_fvs | bndr_is_a_fv = fvs `minusList` [NonVoid bndr] | otherwise = fvs @@ -233,43 +280,35 @@ mkRhsClosure bndr cc bi fvs upd_flag srt args body ; c_srt <- getSRTInfo srt ; let name = idName bndr descr = closureDescription mod_name name - fv_details :: [(Id, VirtualHpOffset)] + fv_details :: [(NonVoid Id, VirtualHpOffset)] (tot_wds, ptr_wds, fv_details) = mkVirtHeapOffsets (isLFThunk lf_info) - (addIdReps reduced_fvs) + (addIdReps (map stripNV reduced_fvs)) closure_info = mkClosureInfo False -- Not static bndr lf_info tot_wds ptr_wds c_srt descr -- BUILD ITS INFO TABLE AND CODE - ; forkClosureBody $ do - { -- Bind the binder itself - -- It does no harm to have it in the envt even if - -- it's not a free variable; and we need a reg for it - node <- bindToReg bndr lf_info - - -- Bind the free variables - ; mapCs (bind_fv node) fv_details - - -- And compile the body - ; closureCodeBody bi closure_info cc c_srt node args body } + ; forkClosureBody $ + -- forkClosureBody: (a) ensure that bindings in here are not seen elsewhere + -- (b) ignore Sequel from context; use empty Sequel + -- And compile the body + closureCodeBody False bndr closure_info cc c_srt (nonVoidIds args) + (length args) body fv_details -- BUILD THE OBJECT ; (use_cc, blame_cc) <- chooseDynCostCentres cc args body ; emit (mkComment $ mkFastString "calling allocDynClosure") - ; tmp <- allocDynClosure closure_info use_cc blame_cc - (mapFst StgVarArg fv_details) + ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off) + ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc + (map toVarArg fv_details) -- RETURN - ; return (bndr, regIdInfo bndr lf_info tmp) } - where - -- A function closure pointer may be tagged, so we - -- must take it into account when accessing the free variables. - tag = tagForArity (length args) + ; return $ (regIdInfo bndr lf_info tmp, init) } - bind_fv node (id, off) - = do { reg <- rebindToReg id - ; emit $ mkTaggedObjectLoad reg node off tag } +-- Use with care; if used inappropriately, it could break invariants. +stripNV :: NonVoid a -> a +stripNV (NonVoid a) = a ------------------------- cgStdThunk @@ -279,7 +318,7 @@ cgStdThunk -> StgExpr -> LambdaFormInfo -> [StgArg] -- payload - -> FCode (Id, CgIdInfo) + -> FCode (CgIdInfo, CmmAGraph) cgStdThunk bndr cc _bndr_info body lf_info payload = do -- AHA! A STANDARD-FORM THUNK @@ -297,35 +336,36 @@ cgStdThunk bndr cc _bndr_info body lf_info payload ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body -- BUILD THE OBJECT - ; tmp <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets + ; (tmp, init) <- allocDynClosure closure_info use_cc blame_cc payload_w_offsets -- RETURN - ; returnFC (bndr, regIdInfo bndr lf_info tmp) } + ; returnFC $ (regIdInfo bndr lf_info tmp, init) } mkClosureLFInfo :: Id -- The binder -> TopLevelFlag -- True of top level - -> [Id] -- Free vars + -> [NonVoid Id] -- Free vars -> UpdateFlag -- Update flag - -> [Id] -- Args + -> [Id] -- Args -> FCode LambdaFormInfo mkClosureLFInfo bndr top fvs upd_flag args - | null args = return (mkLFThunk (idType bndr) top fvs upd_flag) + | null args = return (mkLFThunk (idType bndr) top (map stripNV fvs) upd_flag) | otherwise = do { arg_descr <- mkArgDescr (idName bndr) args - ; return (mkLFReEntrant top fvs args arg_descr) } + ; return (mkLFReEntrant top (map stripNV fvs) args arg_descr) } ------------------------------------------------------------------------ -- The code for closures} ------------------------------------------------------------------------ -closureCodeBody :: StgBinderInfo -- XXX: unused? +closureCodeBody :: Bool -- whether this is a top-level binding + -> Id -- the closure's name -> ClosureInfo -- Lots of information about this closure -> CostCentreStack -- Optional cost centre attached to closure -> C_SRT - -> LocalReg -- The closure itself; first argument - -- The Id is in scope already, bound to this reg - -> [Id] + -> [NonVoid Id] -- incoming args to the closure + -> Int -- arity, including void args -> StgExpr + -> [(NonVoid Id, VirtualHpOffset)] -- the closure's free variables -> FCode () {- There are two main cases for the code for closures. @@ -341,41 +381,50 @@ closureCodeBody :: StgBinderInfo -- XXX: unused? argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL -} -closureCodeBody _binder_info cl_info cc srt node args body - | null args -- No args i.e. thunk - = do { code <- getCode $ thunkCode cl_info cc srt node body - ; emitClosureCodeAndInfoTable cl_info [node] code } +closureCodeBody top_lvl bndr cl_info cc srt 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 srt node arity body) -closureCodeBody _binder_info cl_info cc srt node args body +closureCodeBody top_lvl bndr cl_info cc srt 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 args + ; emitTickyCounter cl_info (map stripNV args) ; setTickyCtrLabel ticky_ctr_lbl $ do --- -- XXX: no slow-entry code for now --- -- Emit the slow-entry code --- { reg_save_code <- mkSlowEntryCode cl_info reg_args - -- Emit the main entry code - ; let node_points = nodeMustPointToIt (closureLFInfo cl_info) - ; arg_regs <- bindArgsToRegs args - ; blks <- forkProc $ getCode $ do - { enterCostCentre cl_info cc body + ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do + -- Emit the 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 ; tickyEnterFun cl_info ; whenC node_points (ldvEnterClosure cl_info) ; granYield arg_regs node_points -- Main payload - ; entryHeapCheck node arg_regs srt $ - cgExpr body } + ; entryHeapCheck node arity arg_regs srt $ do + { enterCostCentre cl_info cc body + ; fv_bindings <- mapM bind_fv fv_details + ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after* + ; cgExpr body }} -- heap check, to reduce live vars over check - ; emitClosureCodeAndInfoTable cl_info (node:arg_regs) blks } -{- +-- A function closure pointer may be tagged, so we +-- must take it into account when accessing the free variables. +bind_fv :: (NonVoid Id, VirtualHpOffset) -> FCode (LocalReg, WordOff) +bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) } + +load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode () +load_fvs node lf_info = mapCs (\ (reg, off) -> + pprTrace "get tag for" (ppr reg <+> ppr tag) $ emit $ mkTaggedObjectLoad reg node off tag) + where tag = lfDynTag lf_info + ----------------------------------------- -- The "slow entry" code for a function. This entry point takes its -- arguments on the stack. It loads the arguments into registers @@ -383,76 +432,53 @@ closureCodeBody _binder_info cl_info cc srt node args body -- normal entry point. The function's closure is assumed to be in -- R1/node. -- --- The slow entry point is used in two places: --- --- (a) unknown calls: eg. stg_PAP_entry --- (b) returning from a heap-check failure +-- The slow entry point is used for unknown calls: eg. stg_PAP_entry -mkSlowEntryCode :: ClosureInfo -> [(Id,GlobalReg)] -> FCode CmmStmts +mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode () -- If this function doesn't have a specialised ArgDescr, we need --- to generate the function's arg bitmap, slow-entry code, and --- register-save code for the heap-check failure --- Here, we emit the slow-entry code, and --- return the register-save assignments -mkSlowEntryCode cl_info reg_args +-- 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' | Just (_, ArgGen _) <- closureFunInfo cl_info - = do { emitSimpleProc slow_lbl (emitStmts load_stmts) - ; return save_stmts } - | otherwise = return noStmts + = emitProcWithConvention Slow (CmmInfo Nothing Nothing CmmNonInfoTable) slow_lbl + arg_regs jump + | otherwise = return () where - name = closureName cl_info - slow_lbl = mkSlowEntryLabel name - - load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry] - save_stmts = oneStmt stk_adj_push `plusStmts` mkStmts save_assts - - reps_w_regs :: [(CgRep,GlobalReg)] - reps_w_regs = [(idCgRep id, reg) | (id,reg) <- reverse reg_args] - (final_stk_offset, stk_offsets) - = mapAccumL (\off (rep,_) -> (off + cgRepSizeW rep, off)) - 0 reps_w_regs - - load_assts = zipWithEqual "mk_load" mk_load reps_w_regs stk_offsets - mk_load (rep,reg) offset = CmmAssign (CmmGlobal reg) - (CmmLoad (cmmRegOffW spReg offset) - (argMachRep rep)) - - save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets - mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegType reg ) - CmmStore (cmmRegOffW spReg offset) - (CmmReg (CmmGlobal reg)) - - stk_adj_pop = CmmAssign spReg (cmmRegOffW spReg final_stk_offset) - stk_adj_push = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset)) - jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) [] --} + 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?" ----------------------------------------- -thunkCode :: ClosureInfo -> CostCentreStack -> C_SRT -> LocalReg -> StgExpr -> FCode () -thunkCode cl_info cc srt node body +thunkCode :: ClosureInfo -> [(NonVoid Id, VirtualHpOffset)] -> CostCentreStack -> + C_SRT -> LocalReg -> Int -> StgExpr -> FCode () +thunkCode cl_info fv_details cc srt 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 -- Heap overflow check - ; entryHeapCheck node [] srt $ do + ; entryHeapCheck node arity [] srt $ do { -- Overwrite with black hole if necessary -- but *after* the heap-overflow check whenC (blackHoleOnEntry cl_info && node_points) (blackHoleIt cl_info) -- Push update frame - ; setupUpdate cl_info node - + ; 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 - ; enterCostCentre cl_info cc body - - ; cgExpr body } } + 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 }}} ------------------------------------------------------------------------ @@ -491,18 +517,20 @@ emitBlackHoleCode is_single_entry eager_blackholing = False -setupUpdate :: ClosureInfo -> LocalReg -> FCode () +setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode () -- Nota Bene: this function does not change Node (even if it's a CAF), -- so that the cost centre in the original closure can still be -- extracted by a subsequent enterCostCentre -setupUpdate closure_info node +setupUpdate closure_info node body | closureReEntrant closure_info - = return () + = body | not (isStaticClosure closure_info) = if closureUpdReqd closure_info - then do { tickyPushUpdateFrame; pushUpdateFrame node } - else tickyUpdateFrameOmitted + then do { tickyPushUpdateFrame; + ; pushUpdateFrame [CmmReg (CmmLocal node), + mkLblExpr mkUpdInfoLabel] body } + else do { tickyUpdateFrameOmitted; body} | otherwise -- A static closure = do { tickyUpdateBhCaf closure_info @@ -510,14 +538,23 @@ setupUpdate closure_info node ; if closureUpdReqd closure_info then do -- Blackhole the (updatable) CAF: { upd_closure <- link_caf closure_info True - ; pushUpdateFrame upd_closure } - else tickyUpdateFrameOmitted + ; pushUpdateFrame [CmmReg (CmmLocal upd_closure), + mkLblExpr mkUpdInfoLabel] body } + else do {tickyUpdateFrameOmitted; body} } -pushUpdateFrame :: LocalReg -> FCode () -pushUpdateFrame cl_reg - = emit (mkAddToContext (mkLblExpr mkUpdInfoLabel) - [CmmReg (CmmLocal cl_reg)]) +-- 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 + offset <- foldM push updfr es + withUpdFrameOff offset body + where push off e = + do emit (mkStore (CmmStackSlot (CallArea Old) base) e) + return base + where base = off + widthInBytes (cmmExprWidth e) ----------------------------------------------------------------------------- -- Entering a CAF @@ -565,7 +602,8 @@ 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 <- allocDynClosure bh_cl_info use_cc blame_cc [] + ; (hp_rel, init) <- allocDynClosure bh_cl_info use_cc blame_cc [] + ; emit init -- Call the RTS function newCAF to add the CAF to the CafList -- so that the garbage collector can find them diff --git a/compiler/codeGen/StgCmmClosure.hs b/compiler/codeGen/StgCmmClosure.hs index c32d7cd..b425163 100644 --- a/compiler/codeGen/StgCmmClosure.hs +++ b/compiler/codeGen/StgCmmClosure.hs @@ -73,7 +73,7 @@ import ClosureInfo (ArgDescr(..), C_SRT(..), Liveness(..)) import StgSyn import SMRep -import Cmm ( ClosureTypeInfo(..) ) +import Cmm ( ClosureTypeInfo(..), ConstrDescription ) import CmmExpr import CLabel @@ -236,7 +236,7 @@ mkLFLetNoEscape = LFLetNoEscape ------------- mkLFReEntrant :: TopLevelFlag -- True of top level - -> [Id] -- Free vars + -> [Id] -- Free vars -> [Id] -- Args -> ArgDescr -- Argument descriptor -> LambdaFormInfo @@ -335,8 +335,10 @@ tagForArity arity | isSmallFamily arity = arity | otherwise = 0 lfDynTag :: LambdaFormInfo -> DynTag -lfDynTag (LFCon con) = tagForCon con -lfDynTag (LFReEntrant _ arity _ _) = tagForArity arity +-- Return the tag in the low order bits of a variable bound +-- to this LambdaForm +lfDynTag (LFCon con) = pprTrace "tagForCon" (ppr con <+> ppr (tagForCon con)) $ tagForCon con +lfDynTag (LFReEntrant _ arity _ _) = pprTrace "reentrant" (ppr arity) $ tagForArity arity lfDynTag _other = 0 @@ -506,7 +508,8 @@ getCallMethod name caf (LFReEntrant _ arity _ _) n_args | n_args == 0 = ASSERT( arity /= 0 ) ReturnIt -- No args at all | n_args < arity = SlowCall -- Not enough args - | otherwise = DirectEntry (enterIdLabel name caf) arity + | otherwise = pprTrace "getCallMethod" (ppr name <+> ppr arity) $ + DirectEntry (enterIdLabel name caf) arity getCallMethod _name _ LFUnLifted n_args = ASSERT( n_args == 0 ) ReturnIt @@ -675,7 +678,8 @@ data ClosureInfo closureSMRep :: !SMRep, -- representation used by storage mgr closureSRT :: !C_SRT, -- What SRT applies to this closure closureType :: !Type, -- Type of closure (ToDo: remove) - closureDescr :: !String -- closure description (for profiling) + closureDescr :: !String, -- closure description (for profiling) + closureCafs :: !CafInfo -- whether the closure may have CAFs } -- Constructor closures don't have a unique info table label (they use @@ -720,7 +724,8 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr closureSMRep = sm_rep, closureSRT = srt_info, closureType = idType id, - closureDescr = descr } + closureDescr = descr, + closureCafs = idCafInfo id } where name = idName id sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds @@ -743,39 +748,49 @@ mkConInfo is_static data_con tot_wds ptr_wds cafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo cafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) + closureType = ty, + closureCafs = cafs }) = ClosureInfo { closureName = nm, closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureCafs = cafs } cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo" seCafBlackHoleClosureInfo :: ClosureInfo -> ClosureInfo seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm, - closureType = ty }) + closureType = ty, + closureCafs = cafs }) = ClosureInfo { closureName = nm, closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel, closureSMRep = BlackHoleRep, closureSRT = NoC_SRT, closureType = ty, - closureDescr = "" } + closureDescr = "", + closureCafs = cafs } seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo" -------------------------------------- -- Extracting ClosureTypeInfo -------------------------------------- -closureTypeInfo :: ClosureInfo -> ClosureTypeInfo -closureTypeInfo cl_info +-- JD: I've added the continuation arguments not for fun but because +-- I don't want to pipe the monad in here (circular module dependencies), +-- and I don't want to pull this code out of this module, which would +-- require us to expose a bunch of abstract types. + +closureTypeInfo :: + ClosureInfo -> ((ConstrDescription -> ClosureTypeInfo) -> DataCon -> CLabel -> a) -> + (ClosureTypeInfo -> a) -> a +closureTypeInfo cl_info k_with_con_name k_simple = case cl_info of ConInfo { closureCon = con } - -> ConstrInfo (ptrs, nptrs) - (fromIntegral (dataConTagZ con)) - con_name + -> k_with_con_name (ConstrInfo (ptrs, nptrs) + (fromIntegral (dataConTagZ con))) con info_lbl where - con_name = panic "closureTypeInfo" + --con_name = panic "closureTypeInfo" -- Was: -- cstr <- mkByteStringCLit $ dataConIdentity con -- con_name = makeRelativeRefTo info_lbl cstr @@ -783,23 +798,23 @@ closureTypeInfo cl_info ClosureInfo { closureName = name, closureLFInfo = LFReEntrant _ arity _ arg_descr, closureSRT = srt } - -> FunInfo (ptrs, nptrs) - srt - (fromIntegral arity) - arg_descr - (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info))) + -> k_simple $ FunInfo (ptrs, nptrs) + srt + (fromIntegral arity) + arg_descr + (CmmLabel (mkSlowEntryLabel name (clHasCafRefs cl_info))) ClosureInfo { closureLFInfo = LFThunk _ _ _ (SelectorThunk offset) _, closureSRT = srt } - -> ThunkSelectorInfo (fromIntegral offset) srt + -> k_simple $ ThunkSelectorInfo (fromIntegral offset) srt ClosureInfo { closureLFInfo = LFThunk {}, closureSRT = srt } - -> ThunkInfo (ptrs, nptrs) srt + -> k_simple $ ThunkInfo (ptrs, nptrs) srt _ -> panic "unexpected lambda form in mkCmmInfo" where --- info_lbl = infoTableLabelFromCI cl_info + info_lbl = infoTableLabelFromCI cl_info ptrs = fromIntegral $ closurePtrsSize cl_info size = fromIntegral $ closureNonHdrSize cl_info nptrs = size - ptrs @@ -1092,9 +1107,7 @@ getPredTyDescription (EqPred ty1 _ty2) = getTyDescription ty1 -- Urk? -- SRTs/CAFs -------------------------------------- --- This is horrible, but we need to know whether a closure may have CAFs. +-- We need to know whether a closure may have CAFs. clHasCafRefs :: ClosureInfo -> CafInfo -clHasCafRefs (ClosureInfo {closureSRT = srt}) = - case srt of NoC_SRT -> NoCafRefs - _ -> MayHaveCafRefs +clHasCafRefs (ClosureInfo {closureCafs = cafs}) = cafs clHasCafRefs (ConInfo {}) = NoCafRefs diff --git a/compiler/codeGen/StgCmmCon.hs b/compiler/codeGen/StgCmmCon.hs index de1d77a..e818bd7 100644 --- a/compiler/codeGen/StgCmmCon.hs +++ b/compiler/codeGen/StgCmmCon.hs @@ -27,6 +27,7 @@ import StgCmmProf import Cmm import CLabel +import MkZipCfgCmm (CmmAGraph, mkNop) import SMRep import CostCentre import Constants @@ -47,7 +48,7 @@ import Char ( ord ) cgTopRhsCon :: Id -- Name of thing bound to this RHS -> DataCon -- Id -> [StgArg] -- Args - -> FCode (Id, CgIdInfo) + -> FCode CgIdInfo cgTopRhsCon id con args = do { #if mingw32_TARGET_OS @@ -67,7 +68,7 @@ cgTopRhsCon id con args = layOutStaticConstr con (addArgReps args) get_lit (arg, _offset) = do { CmmLit lit <- getArgAmode arg - ; return lit } + ; return lit } ; payload <- mapM get_lit nv_args_w_offsets -- NB1: nv_args_w_offsets is sorted into ptrs then non-ptrs @@ -83,7 +84,7 @@ cgTopRhsCon id con args ; emitDataLits closure_label closure_rep -- RETURN - ; return (id, litIdInfo id lf_info (CmmLabel closure_label)) } + ; return $ litIdInfo id lf_info (CmmLabel closure_label) } --------------------------------------------------------------- @@ -96,7 +97,8 @@ buildDynCon :: Id -- Name of the thing to which this constr will -- current CCS if currentOrSubsumedCCS -> DataCon -- The data constructor -> [StgArg] -- Its args - -> FCode CgIdInfo -- Return details about how to find it + -> FCode (CgIdInfo, CmmAGraph) + -- Return details about how to find it and initialization code {- We used to pass a boolean indicating whether all the args were of size zero, so we could use a static @@ -121,7 +123,8 @@ premature looking at the args will cause the compiler to black-hole! buildDynCon binder _cc con [] = return (litIdInfo binder (mkConLFInfo con) - (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder)))) + (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))), + mkNop) -------- buildDynCon: Charlike and Intlike constructors ----------- {- The following three paragraphs about @Char@-like and @Int@-like @@ -155,7 +158,7 @@ buildDynCon binder _cc con [arg] offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1) -- INTLIKE closures consist of a header and one word payload intlike_amode = cmmLabelOffW intlike_lbl offsetW - ; return (litIdInfo binder (mkConLFInfo con) intlike_amode) } + ; return (litIdInfo binder (mkConLFInfo con) intlike_amode, mkNop) } buildDynCon binder _cc con [arg] | maybeCharLikeCon con @@ -167,14 +170,14 @@ buildDynCon binder _cc con [arg] offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1) -- CHARLIKE closures consist of a header and one word payload charlike_amode = cmmLabelOffW charlike_lbl offsetW - ; return (litIdInfo binder (mkConLFInfo con) charlike_amode) } + ; return (litIdInfo binder (mkConLFInfo con) charlike_amode, mkNop) } -------- buildDynCon: the general case ----------- buildDynCon binder ccs con args = do { let (cl_info, args_w_offsets) = layOutDynConstr con (addArgReps args) -- No void args in args_w_offsets - ; tmp <- allocDynClosure cl_info use_cc blame_cc args_w_offsets - ; return (regIdInfo binder lf_info tmp) } + ; (tmp, init) <- allocDynClosure cl_info use_cc blame_cc args_w_offsets + ; return (regIdInfo binder lf_info tmp, init) } where lf_info = mkConLFInfo con @@ -204,10 +207,11 @@ bindConArgs (DataAlt con) base args -- The binding below forces the masking out of the tag bits -- when accessing the constructor field. - bind_arg :: (Id, VirtualHpOffset) -> FCode LocalReg + bind_arg :: (NonVoid Id, VirtualHpOffset) -> FCode LocalReg bind_arg (arg, offset) = do { emit $ mkTaggedObjectLoad (idToReg arg) base offset tag - ; bindArgToReg arg } + ; pprTrace "bind_arg gets tag" (ppr arg <+> ppr tag) $ + bindArgToReg arg } bindConArgs _other_con _base args = ASSERT( null args ) return [] diff --git a/compiler/codeGen/StgCmmEnv.hs b/compiler/codeGen/StgCmmEnv.hs index c43bf80..67d82f0 100644 --- a/compiler/codeGen/StgCmmEnv.hs +++ b/compiler/codeGen/StgCmmEnv.hs @@ -14,6 +14,8 @@ module StgCmmEnv ( litIdInfo, lneIdInfo, regIdInfo, idInfoToAmode, + NonVoid(..), isVoidId, nonVoidIds, + addBindC, addBindsC, bindArgsToRegs, bindToReg, rebindToReg, @@ -25,6 +27,7 @@ module StgCmmEnv ( #include "HsVersions.h" +import TyCon import StgCmmMonad import StgCmmUtils import StgCmmClosure @@ -39,11 +42,28 @@ import PprCmm ( {- instance Outputable -} ) import Id import VarEnv import Maybes +import Monad import Name import StgSyn import Outputable +------------------------------------- +-- Non-void types +------------------------------------- +-- We frequently need the invariant that an Id or a an argument +-- is of a non-void type. This type is a witness to the invariant. + +newtype NonVoid a = NonVoid a + deriving (Eq, Show) + +instance (Outputable a) => Outputable (NonVoid a) where + ppr (NonVoid a) = ppr a + +isVoidId :: Id -> Bool +isVoidId = isVoidRep . idPrimRep +nonVoidIds :: [Id] -> [NonVoid Id] +nonVoidIds ids = [NonVoid id | id <- ids, not (isVoidRep (idPrimRep id))] ------------------------------------- -- Manipulating CgIdInfo @@ -65,15 +85,16 @@ lneIdInfo id regs blk_id = mkBlockId (idUnique id) litIdInfo :: Id -> LambdaFormInfo -> CmmLit -> CgIdInfo -litIdInfo id lf_info lit = mkCgIdInfo id lf_info (CmmLit lit) +litIdInfo id lf_info lit = --mkCgIdInfo id lf_info (CmmLit lit) + mkCgIdInfo id lf_info (addDynTag (CmmLit lit) (lfDynTag lf_info)) regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CgIdInfo -regIdInfo id lf_info reg = mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)) +regIdInfo id lf_info reg = + mkCgIdInfo id lf_info (addDynTag (CmmReg (CmmLocal reg)) (lfDynTag lf_info)) idInfoToAmode :: CgIdInfo -> CmmExpr -- Returns a CmmExpr for the *tagged* pointer -idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e, cg_tag = tag }) - = addDynTag e tag +idInfoToAmode (CgIdInfo { cg_loc = CmmLoc e }) = e idInfoToAmode cg_info = pprPanic "idInfoToAmode" (ppr (cg_id cg_info)) -- LneLoc @@ -105,10 +126,10 @@ addBindC name stuff_to_bind = do binds <- getBinds setBinds $ extendVarEnv binds name stuff_to_bind -addBindsC :: [(Id, CgIdInfo)] -> FCode () +addBindsC :: [CgIdInfo] -> FCode () addBindsC new_bindings = do binds <- getBinds - let new_binds = foldl (\ binds (name,info) -> extendVarEnv binds name info) + let new_binds = foldl (\ binds info -> extendVarEnv binds (cg_id info) info) binds new_bindings setBinds new_binds @@ -155,10 +176,11 @@ cgLookupPanic id -------------------- -getArgAmode :: StgArg -> FCode CmmExpr -getArgAmode (StgVarArg var) = do { info <- getCgIdInfo var; return (idInfoToAmode info) } -getArgAmode (StgLitArg lit) = return (CmmLit (mkSimpleLit lit)) -getArgAmode (StgTypeArg _) = panic "getArgAmode: type arg" +getArgAmode :: NonVoid StgArg -> FCode CmmExpr +getArgAmode (NonVoid (StgVarArg var)) = + do { info <- getCgIdInfo var; return (idInfoToAmode info) } +getArgAmode (NonVoid (StgLitArg lit)) = liftM CmmLit $ cgLit lit +getArgAmode (NonVoid (StgTypeArg _)) = panic "getArgAmode: type arg" getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] -- NB: Filters out void args, @@ -166,7 +188,7 @@ getNonVoidArgAmodes :: [StgArg] -> FCode [CmmExpr] getNonVoidArgAmodes [] = return [] getNonVoidArgAmodes (arg:args) | isVoidRep (argPrimRep arg) = getNonVoidArgAmodes args - | otherwise = do { amode <- getArgAmode arg + | otherwise = do { amode <- getArgAmode (NonVoid arg) ; amodes <- getNonVoidArgAmodes args ; return ( amode : amodes ) } @@ -175,27 +197,27 @@ getNonVoidArgAmodes (arg:args) -- Interface functions for binding and re-binding names ------------------------------------------------------------------------ -bindToReg :: Id -> LambdaFormInfo -> FCode LocalReg +bindToReg :: NonVoid Id -> LambdaFormInfo -> FCode LocalReg -- Bind an Id to a fresh LocalReg -bindToReg id lf_info - = do { let reg = idToReg id - ; addBindC id (regIdInfo id lf_info reg) +bindToReg nvid@(NonVoid id) lf_info + = do { let reg = idToReg nvid + ; addBindC id (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg))) ; return reg } -rebindToReg :: Id -> FCode LocalReg +rebindToReg :: NonVoid Id -> FCode LocalReg -- Like bindToReg, but the Id is already in scope, so -- get its LF info from the envt -rebindToReg id +rebindToReg nvid@(NonVoid id) = do { info <- getCgIdInfo id - ; bindToReg id (cgIdInfoLF info) } + ; bindToReg nvid (cgIdInfoLF info) } -bindArgToReg :: Id -> FCode LocalReg -bindArgToReg id = bindToReg id (mkLFArgument id) +bindArgToReg :: NonVoid Id -> FCode LocalReg +bindArgToReg nvid@(NonVoid id) = bindToReg nvid (mkLFArgument id) -bindArgsToRegs :: [Id] -> FCode [LocalReg] +bindArgsToRegs :: [NonVoid Id] -> FCode [LocalReg] bindArgsToRegs args = mapM bindArgToReg args -idToReg :: Id -> LocalReg +idToReg :: NonVoid Id -> LocalReg -- Make a register from an Id, typically a function argument, -- free variable, or case binder -- @@ -203,7 +225,8 @@ idToReg :: Id -> LocalReg -- -- By now the Ids should be uniquely named; else one would worry -- about accidental collision -idToReg id = LocalReg (idUnique id) - (primRepCmmType (idPrimRep id)) +idToReg (NonVoid id) = LocalReg (idUnique id) + (case idPrimRep id of VoidRep -> pprPanic "idToReg" (ppr id) + _ -> primRepCmmType (idPrimRep id)) diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs index 74c69b7..379f1cd 100644 --- a/compiler/codeGen/StgCmmExpr.hs +++ b/compiler/codeGen/StgCmmExpr.hs @@ -33,7 +33,9 @@ import Cmm() import CmmExpr import CoreSyn import DataCon +import ForeignCall import Id +import PrimOp import TyCon import CostCentre ( CostCentreStack, currentCCS ) import Maybes @@ -50,16 +52,16 @@ cgExpr :: StgExpr -> FCode () cgExpr (StgApp fun args) = cgIdApp fun args cgExpr (StgOpApp op args ty) = cgOpApp op args ty cgExpr (StgConApp con args) = cgConApp con args - cgExpr (StgSCC cc expr) = do { emitSetCCC cc; cgExpr expr } cgExpr (StgTick m n expr) = do { emit (mkTickBox m n); cgExpr expr } -cgExpr (StgLit lit) = emitReturn [CmmLit (mkSimpleLit lit)] +cgExpr (StgLit lit) = do cmm_lit <- cgLit lit + emitReturn [CmmLit cmm_lit] -cgExpr (StgLet binds expr) = do { emit (mkComment $ mkFastString "calling cgBind"); cgBind binds; emit (mkComment $ mkFastString "calling cgExpr"); cgExpr expr } +cgExpr (StgLet binds expr) = do { cgBind binds; cgExpr expr } cgExpr (StgLetNoEscape _ _ binds expr) = do { cgLneBinds binds; cgExpr expr } -cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) - = cgCase expr bndr srt alt_type alts +cgExpr (StgCase expr _live_vars _save_vars bndr srt alt_type alts) = + cgCase expr bndr srt alt_type alts cgExpr (StgLam {}) = panic "cgExpr: StgLam" @@ -68,7 +70,7 @@ cgExpr (StgLam {}) = panic "cgExpr: StgLam" ------------------------------------------------------------------------ {- Generating code for a let-no-escape binding, aka join point is very -very similar to whatwe do for a case expression. The duality is +very similar to what we do for a case expression. The duality is between let-no-escape x = b in e @@ -86,8 +88,8 @@ cgLneBinds :: StgBinding -> FCode () cgLneBinds (StgNonRec bndr rhs) = do { local_cc <- saveCurrentCostCentre -- See Note [Saving the current cost centre] - ; (bndr,info) <- cgLetNoEscapeRhs local_cc bndr rhs - ; addBindC bndr info } + ; info <- cgLetNoEscapeRhs local_cc bndr rhs + ; addBindC (cg_id info) info } cgLneBinds (StgRec pairs) = do { local_cc <- saveCurrentCostCentre @@ -98,16 +100,24 @@ cgLneBinds (StgRec pairs) ; addBindsC new_bindings } + ------------------------- -cgLetNoEscapeRhs +cgLetNoEscapeRhs, cgLetNoEscapeRhsBody :: Maybe LocalReg -- Saved cost centre -> Id -> StgRhs - -> FCode (Id, CgIdInfo) - -cgLetNoEscapeRhs local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body) - = cgLetNoEscapeClosure bndr local_cc cc srt args body -cgLetNoEscapeRhs local_cc bndr (StgRhsCon cc con args) + -> FCode CgIdInfo + +cgLetNoEscapeRhs local_cc bndr rhs = + do { (info, rhs_body) <- getCodeR $ cgLetNoEscapeRhsBody local_cc bndr rhs + ; let (bid, _) = expectJust "cgLetNoEscapeRhs" $ maybeLetNoEscape info + ; emit (outOfLine $ mkLabel bid emptyStackInfo <*> rhs_body) + ; return info + } + +cgLetNoEscapeRhsBody local_cc bndr (StgRhsClosure cc _bi _ _upd srt args body) + = cgLetNoEscapeClosure bndr local_cc cc srt (nonVoidIds args) body +cgLetNoEscapeRhsBody local_cc bndr (StgRhsCon cc con args) = cgLetNoEscapeClosure bndr local_cc cc NoSRT [] (StgConApp con args) -- For a constructor RHS we want to generate a single chunk of -- code which can be jumped to from many places, which will @@ -120,9 +130,9 @@ cgLetNoEscapeClosure -> Maybe LocalReg -- Slot for saved current cost centre -> CostCentreStack -- XXX: *** NOT USED *** why not? -> SRT - -> [Id] -- Args (as in \ args -> body) + -> [NonVoid Id] -- Args (as in \ args -> body) -> StgExpr -- Body (as in above) - -> FCode (Id, CgIdInfo) + -> FCode CgIdInfo cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body = do { arg_regs <- forkProc $ do @@ -133,7 +143,7 @@ cgLetNoEscapeClosure bndr cc_slot _unused_cc srt args body -- Using altHeapCheck just reduces -- instructions to save on stack ; return arg_regs } - ; return (bndr, lneIdInfo bndr arg_regs) } + ; return $ lneIdInfo bndr arg_regs} ------------------------------------------------------------------------ @@ -253,6 +263,11 @@ data GcPlan ------------------------------------- cgCase :: StgExpr -> Id -> SRT -> AltType -> [StgAlt] -> FCode () +-- cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2] + -- | isBoolTy (idType bndr) + -- , isDeadBndr bndr + -- = + cgCase scrut bndr srt alt_type alts = do { up_hp_usg <- getVirtHp -- Upstream heap usage ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts @@ -270,7 +285,7 @@ cgCase scrut bndr srt alt_type alts ; restoreCurrentCostCentre mb_cc ; bindArgsToRegs ret_bndrs - ; cgAlts gc_plan bndr alt_type alts } + ; cgAlts gc_plan (NonVoid bndr) alt_type alts } ----------------- maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg) @@ -279,17 +294,25 @@ maybeSaveCostCentre simple_scrut | otherwise = return Nothing - ----------------- isSimpleScrut :: StgExpr -> AltType -> Bool --- Simple scrutinee, does not allocate -isSimpleScrut (StgOpApp _ _ _) _ = True -isSimpleScrut (StgLit _) _ = True -isSimpleScrut (StgApp _ []) (PrimAlt _) = True +-- Simple scrutinee, does not block or allocate; hence safe to amalgamate +-- heap usage from alternatives into the stuff before the case +-- NB: if you get this wrong, and claim that the expression doesn't allocate +-- when it does, you'll deeply mess up allocation +isSimpleScrut (StgOpApp op _ _) _ = isSimpleOp op +isSimpleScrut (StgLit _) _ = True -- case 1# of { 0# -> ..; ... } +isSimpleScrut (StgApp _ []) (PrimAlt _) = True -- case x# of { 0# -> ..; ... } isSimpleScrut _ _ = False +isSimpleOp :: StgOp -> Bool +-- True iff the op cannot block or allocate +isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe) +isSimpleOp (StgFCallOp (DNCall _) _) = False -- Safe! +isSimpleOp (StgPrimOp op) = not (primOpOutOfLine op) + ----------------- -chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [Id] +chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id] -- These are the binders of a case that are assigned -- by the evaluation of the scrutinee -- Only non-void ones come back @@ -300,19 +323,16 @@ chooseReturnBndrs _bndr (UbxTupAlt _) [(_, ids, _, _)] = nonVoidIds ids -- 'bndr' is not assigned! chooseReturnBndrs bndr (AlgAlt _) _alts - = [bndr] -- Only 'bndr' is assigned + = nonVoidIds [bndr] -- Only 'bndr' is assigned chooseReturnBndrs bndr PolyAlt _alts - = [bndr] -- Only 'bndr' is assigned + = nonVoidIds [bndr] -- Only 'bndr' is assigned chooseReturnBndrs _ _ _ = panic "chooseReturnBndrs" -- UbxTupALt has only one alternative -nonVoidIds :: [Id] -> [Id] -nonVoidIds ids = [id | id <- ids, not (isVoidRep (idPrimRep id))] - ------------------------------------- -cgAlts :: GcPlan -> Id -> AltType -> [StgAlt] -> FCode () +cgAlts :: GcPlan -> NonVoid Id -> AltType -> [StgAlt] -> FCode () -- At this point the result of the case are in the binders cgAlts gc_plan _bndr PolyAlt [(_, _, _, rhs)] = maybeAltHeapCheck gc_plan (cgExpr rhs) @@ -347,7 +367,7 @@ cgAlts gc_plan bndr (AlgAlt tycon) alts | (DataAlt con, cmm) <- tagged_cmms ] -- Is the constructor tag in the node reg? - ; if isSmallFamily fam_sz + ; if isSmallFamily fam_sz then let -- Yes, bndr_reg has constr. tag in ls bits tag_expr = cmmConstrTag1 (CmmReg bndr_reg) branches' = [(tag+1,branch) | (tag,branch) <- branches] @@ -366,7 +386,7 @@ cgAlts _ _ _ _ = panic "cgAlts" -- UbxTupAlt and PolyAlt have only one alternative ------------------- -cgAltRhss :: GcPlan -> Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)] +cgAltRhss :: GcPlan -> NonVoid Id -> [StgAlt] -> FCode [(AltCon, CmmAGraph)] cgAltRhss gc_plan bndr alts = forkAlts (map cg_alt alts) where @@ -375,7 +395,7 @@ cgAltRhss gc_plan bndr alts cg_alt (con, bndrs, _uses, rhs) = getCodeR $ maybeAltHeapCheck gc_plan $ - do { bindConArgs con base_reg bndrs + do { pprTrace "binding args for" (ppr bndr <+> ppr con) $ bindConArgs con base_reg bndrs ; cgExpr rhs ; return con } @@ -392,19 +412,28 @@ maybeAltHeapCheck (GcInAlts regs srt) code cgConApp :: DataCon -> [StgArg] -> FCode () cgConApp con stg_args + | isUnboxedTupleCon con -- Unboxed tuple: assign and return + = do { arg_exprs <- getNonVoidArgAmodes stg_args + ; tickyUnboxedTupleReturn (length arg_exprs) + ; emitReturn arg_exprs } + + | otherwise -- Boxed constructors; allocate and return = ASSERT( stg_args `lengthIs` dataConRepArity con ) - do { idinfo <- buildDynCon (dataConWorkId con) currentCCS con stg_args + do { (idinfo, init) <- buildDynCon (dataConWorkId con) currentCCS con stg_args -- The first "con" says that the name bound to this closure is -- is "con", which is a bit of a fudge, but it only affects profiling + ; emit init ; emitReturn [idInfoToAmode idinfo] } + cgIdApp :: Id -> [StgArg] -> FCode () +cgIdApp fun_id [] | isVoidId fun_id = emitReturn [] cgIdApp fun_id args = do { fun_info <- getCgIdInfo fun_id - ; case maybeLetNoEscape fun_info of - Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args - Nothing -> cgTailCall fun_id fun_info args } + ; case maybeLetNoEscape fun_info of + Just (blk_id, lne_regs) -> cgLneJump blk_id lne_regs args + Nothing -> cgTailCall fun_id fun_info args } cgLneJump :: BlockId -> [LocalReg] -> [StgArg] -> FCode () cgLneJump blk_id lne_regs args -- Join point; discard sequel @@ -416,35 +445,40 @@ cgTailCall :: Id -> CgIdInfo -> [StgArg] -> FCode () cgTailCall fun_id fun_info args = case (getCallMethod fun_name (idCafInfo fun_id) lf_info (length args)) of - -- A value in WHNF, so we can just return it. + -- A value in WHNF, so we can just return it. ReturnIt -> emitReturn [fun] -- ToDo: does ReturnIt guarantee tagged? EnterIt -> ASSERT( null args ) -- Discarding arguments - do { [ret,call] <- forkAlts [ + do { let fun' = CmmLoad fun (cmmExprType fun) + ; [ret,call] <- forkAlts [ getCode $ emitReturn [fun], -- Is tagged; no need to untag - getCode $ emitCall (entryCode fun) [fun]] -- Not tagged + getCode $ do emit (mkAssign nodeReg fun) + emitCall Native (entryCode fun') []] -- Not tagged ; emit (mkCmmIfThenElse (cmmIsTagged fun) ret call) } SlowCall -> do -- A slow function call via the RTS apply routines { tickySlowCall lf_info args + ; emit $ mkComment $ mkFastString "slowCall" ; slowCall fun args } -- A direct function call (possibly with some left-over arguments) DirectEntry lbl arity -> do { tickyDirectCall arity args ; if node_points then - do call <- getCode $ directCall lbl arity args - emit (mkAssign nodeReg fun <*> call) + do emit $ mkComment $ mkFastString "directEntry" + emit (mkAssign nodeReg fun) + directCall lbl arity args -- directCall lbl (arity+1) (StgVarArg fun_id : args)) -- >>= (emit . (mkComment (mkFastString "DirectEntry") <*>)) - else directCall lbl arity args } + else do emit $ mkComment $ mkFastString "directEntry else" + directCall lbl arity args } JumpToIt {} -> panic "cgTailCall" -- ??? where - fun_name = idName fun_id - fun = idInfoToAmode fun_info - lf_info = cgIdInfoLF fun_info + fun_name = idName fun_id + fun = idInfoToAmode fun_info + lf_info = cgIdInfoLF fun_info node_points = nodeMustPointToIt lf_info diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs index 2d5d79e..2a6b794 100644 --- a/compiler/codeGen/StgCmmForeign.hs +++ b/compiler/codeGen/StgCmmForeign.hs @@ -10,11 +10,10 @@ ----------------------------------------------------------------------------- module StgCmmForeign ( - cgForeignCall, + cgForeignCall, loadThreadState, saveThreadState, emitPrimCall, emitCCall, emitSaveThreadState, -- will be needed by the Cmm parser emitLoadThreadState, -- ditto - emitCloseNursery, emitOpenNursery, ) where @@ -27,18 +26,23 @@ import StgCmmMonad import StgCmmUtils import StgCmmClosure -import MkZipCfgCmm +import BlockId import Cmm import CmmUtils +import MkZipCfg +import MkZipCfgCmm hiding (CmmAGraph) import Type import TysPrim +import UniqSupply import CLabel import SMRep import ForeignCall import Constants import StaticFlags +import FastString import Maybes import Outputable +import ZipCfgCmmRep import Control.Monad @@ -64,8 +68,9 @@ cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_a DynamicTarget -> case args of fn:rest -> (rest, fn) call_target = ForeignTarget cmm_target fc - ; srt <- getSRTInfo (panic "emitForeignCall") -- SLPJ: Not sure what SRT - -- is right here + ; srt <- getSRTInfo NoSRT -- SLPJ: Not sure what SRT + -- is right here + -- JD: Does it matter in the new codegen? ; emitForeignCall safety results call_target call_args srt CmmMayReturn } where -- in the stdcall calling convention, the symbol needs @size appended @@ -111,50 +116,18 @@ emitForeignCall -> CmmReturnInfo -- This can say "never returns" -- only RTS procedures do this -> FCode () -emitForeignCall safety results target args _srt _ret - | not (playSafe safety) = trace "emitForeignCall; ret is undone" $ do +emitForeignCall safety results target args _srt ret + | not (playSafe safety) = do -- trace "emitForeignCall; ret is undone" $ do let (caller_save, caller_load) = callerSaveVolatileRegs + updfr_off <- getUpdFrameOff emit caller_save - emit (mkUnsafeCall target results args) + emit $ mkUnsafeCall target results args emit caller_load - | otherwise = panic "ToDo: emitForeignCall'" - -{- | otherwise = do - -- 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)) + updfr_off <- getUpdFrameOff temp_target <- load_target_into_temp target - let (caller_save, caller_load) = callerSaveVolatileRegs - emitSaveThreadState - emit caller_save - -- The CmmUnsafe arguments are only correct because this part - -- of the code hasn't been moved into the CPS pass yet. - -- Once that happens, this function will just emit a (CmmSafe srt) call, - -- and the CPS will will be the one to convert that - -- to this sequence of three CmmUnsafe calls. - emit (mkCmmCall (CmmCallee suspendThread CCallConv) - [ (id,AddrHint) ] - [ (CmmReg (CmmGlobal BaseReg), AddrHint) ] - CmmUnsafe - ret) - emit (mkCmmCall temp_target results args CmmUnsafe ret) - emit (mkCmmCall (CmmCallee resumeThread CCallConv) - [ (new_base, AddrHint) ] - [ (CmmReg (CmmLocal id), AddrHint) ] - CmmUnsafe - ret ) - -- Assign the result to BaseReg: we - -- might now have a different Capability! - emit (mkAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base))) - emit caller_load - emitLoadThreadState - -suspendThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("suspendThread"))) -resumeThread = CmmLit (CmmLabel (mkRtsCodeLabel SLIT("resumeThread"))) --} + emit $ mkSafeCall temp_target results args updfr_off {- @@ -170,23 +143,23 @@ load_args_into_temps = mapM arg_assign_temp where arg_assign_temp (e,hint) = do tmp <- maybe_assign_temp e return (tmp,hint) +-} -load_target_into_temp (CmmCallee expr conv) = do +load_target_into_temp (ForeignTarget expr conv) = do tmp <- maybe_assign_temp expr - return (CmmCallee tmp conv) -load_target_into_temp other_target = + return (ForeignTarget tmp conv) +load_target_into_temp other_target@(PrimTarget _) = return other_target maybe_assign_temp e | hasNoGlobalRegs e = return e - | otherwise = do + | otherwise = do -- don't use assignTemp, it uses its own notion of "trivial" -- expressions, which are wrong here. -- this is a NonPtr because it only duplicates an existing reg <- newTemp (cmmExprType e) --TODO FIXME NOW emit (mkAssign (CmmLocal reg) e) return (CmmReg (CmmLocal reg)) --} -- ----------------------------------------------------------------------------- -- Save/restore the thread state in the TSO @@ -194,23 +167,34 @@ maybe_assign_temp e -- This stuff can't be done in suspendThread/resumeThread, because it -- refers to global registers which aren't available in the C world. -emitSaveThreadState :: FCode () -emitSaveThreadState = do +saveThreadState :: CmmAGraph +saveThreadState = -- CurrentTSO->sp = Sp; - emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp - emitCloseNursery + mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp + <*> closeNursery + -- and save the current cost centre stack in the TSO when profiling: + <*> if opt_SccProfilingOn then + mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS + else mkNop + +emitSaveThreadState :: BlockId -> FCode () +emitSaveThreadState bid = do + -- CurrentTSO->sp = Sp; + emit $ mkStore (cmmOffset stgCurrentTSO tso_SP) + (CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord))) + emit closeNursery -- and save the current cost centre stack in the TSO when profiling: when opt_SccProfilingOn $ emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS) -- CurrentNursery->free = Hp+1; -emitCloseNursery :: FCode () -emitCloseNursery = emit $ mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) +closeNursery :: CmmAGraph +closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1) -emitLoadThreadState :: FCode () -emitLoadThreadState = do - tso <- newTemp gcWord -- TODO FIXME NOW - emit $ catAGraphs [ +loadThreadState :: LocalReg -> CmmAGraph +loadThreadState tso = do + -- tso <- newTemp gcWord -- TODO FIXME NOW + catAGraphs [ -- tso = CurrentTSO; mkAssign (CmmLocal tso) stgCurrentTSO, -- Sp = tso->sp; @@ -218,16 +202,18 @@ emitLoadThreadState = do bWord), -- SpLim = tso->stack + RESERVED_STACK_WORDS; mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK) - rESERVED_STACK_WORDS) - ] - emitOpenNursery - -- and load the current cost centre stack from the TSO when profiling: - when opt_SccProfilingOn $ - emit (mkStore curCCSAddr - (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)) - -emitOpenNursery :: FCode () -emitOpenNursery = emit $ catAGraphs [ + rESERVED_STACK_WORDS), + openNursery, + -- and load the current cost centre stack from the TSO when profiling: + if opt_SccProfilingOn then + mkStore curCCSAddr + (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType) + else mkNop] +emitLoadThreadState :: LocalReg -> FCode () +emitLoadThreadState tso = emit $ loadThreadState tso + +openNursery :: CmmAGraph +openNursery = catAGraphs [ -- Hp = CurrentNursery->free - 1; mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (-1)), @@ -246,7 +232,8 @@ emitOpenNursery = emit $ catAGraphs [ ) ) ] - +emitOpenNursery :: FCode () +emitOpenNursery = emit openNursery nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start @@ -285,7 +272,7 @@ currentNursery = CmmGlobal CurrentNursery getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)] -- (a) Drop void args --- (b) Add foriegn-call shim code +-- (b) Add foreign-call shim code -- It's (b) that makes this differ from getNonVoidArgAmodes getFCallArgs args @@ -295,7 +282,7 @@ getFCallArgs args get arg | isVoidRep arg_rep = return Nothing | otherwise - = do { cmm <- getArgAmode arg + = do { cmm <- getArgAmode (NonVoid arg) ; return (Just (add_shim arg_ty cmm, hint)) } where arg_ty = stgArgType arg diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs index 6a8a435..3f803d1 100644 --- a/compiler/codeGen/StgCmmHeap.hs +++ b/compiler/codeGen/StgCmmHeap.hs @@ -51,14 +51,14 @@ import Data.List layOutDynConstr, layOutStaticConstr :: DataCon -> [(PrimRep, a)] - -> (ClosureInfo, [(a, VirtualHpOffset)]) + -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)]) -- No Void arguments in result layOutDynConstr = layOutConstr False layOutStaticConstr = layOutConstr True layOutConstr :: Bool -> DataCon -> [(PrimRep, a)] - -> (ClosureInfo, [(a, VirtualHpOffset)]) + -> (ClosureInfo, [(NonVoid a, VirtualHpOffset)]) layOutConstr is_static data_con args = (mkConInfo is_static data_con tot_wds ptr_wds, things_w_offsets) @@ -78,13 +78,16 @@ allocDynClosure -> CmmExpr -- Cost Centre to blame for this alloc -- (usually the same; sometimes "OVERHEAD") - -> [(StgArg, VirtualHpOffset)] -- Offsets from start of the object - -- ie Info ptr has offset zero. - -- No void args in here - -> FCode LocalReg + -> [(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, -- 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 +-- the graph. -- Note [Return a LocalReg] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -132,7 +135,7 @@ allocDynClosure cl_info use_cc _blame_cc args_w_offsets -- Assign to a temporary and return -- Note [Return a LocalReg] ; hp_rel <- getHpRelOffset info_offset - ; assignTemp hp_rel } + ; getCodeR $ assignTemp hp_rel } emitSetDynHdr :: CmmExpr -> CmmExpr -> CmmExpr -> FCode () emitSetDynHdr base info_ptr ccs @@ -210,7 +213,7 @@ mkStaticClosure :: CLabel -> CostCentreStack -> [CmmLit] mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_field = [CmmLabel info_lbl] ++ variable_header_words - ++ payload + ++ concatMap padLitToWord payload ++ padding_wds ++ static_link_field ++ saved_info_field @@ -221,6 +224,19 @@ mkStaticClosure info_lbl ccs payload padding_wds static_link_field saved_info_fi ++ 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? +padLitToWord :: CmmLit -> [CmmLit] +padLitToWord lit = lit : padding pad_length + where width = typeWidth (cmmLitType lit) + pad_length = wORD_SIZE - widthInBytes width :: Int + + padding n | n <= 0 = [] + | n `rem` 2 /= 0 = CmmInt 0 W8 : padding (n-1) + | n `rem` 4 /= 0 = CmmInt 0 W16 : padding (n-2) + | n `rem` 8 /= 0 = CmmInt 0 W32 : padding (n-4) + | otherwise = CmmInt 0 W64 : padding (n-8) + ----------------------------------------------------------- -- Heap overflow checking ----------------------------------------------------------- @@ -286,7 +302,7 @@ These are used in the following circumstances 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 + spots this sharing opportunity) (b) No canned sequence for results of f Note second info table @@ -318,24 +334,30 @@ These are used in the following circumstances -------------------------------------------------------------- -- A heap/stack check at a function or thunk entry point. -entryHeapCheck :: LocalReg -- Function - -> [LocalReg] -- Args (empty for thunk) +entryHeapCheck :: LocalReg -- Function (closure environment) + -> Int -- Arity -- not same as length args b/c of voids + -> [LocalReg] -- Non-void args (empty for thunk) -> C_SRT -> FCode () -> FCode () -entryHeapCheck fun args srt code - = heapCheck gc_call code -- The 'fun' keeps relevant CAFs alive +entryHeapCheck fun arity args srt code + = do updfr_sz <- getUpdFrameOff + heapCheck True (gc_call updfr_sz) code -- The 'fun' keeps relevant CAFs alive where - gc_call - | null args = mkJump (CmmReg (CmmGlobal GCEnter1)) [CmmReg (CmmLocal fun)] - | otherwise = case gc_lbl args of - Just lbl -> mkJump (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) - (map (CmmReg . CmmLocal) (fun:args)) - Nothing -> mkCmmCall generic_gc [] [] srt + fun_expr = CmmReg (CmmLocal fun) + -- JD: ugh... we should only do the following for dynamic closures + args' = fun_expr : map (CmmReg . CmmLocal) args + gc_call updfr_sz + | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) args' updfr_sz + | otherwise = case gc_lbl (fun : args) of + Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl))) + args' updfr_sz + Nothing -> mkCall generic_gc GC [] [] updfr_sz gc_lbl :: [LocalReg] -> Maybe LitString - gc_lbl [reg] +{- + 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" @@ -348,6 +370,7 @@ entryHeapCheck fun args srt code where ty = localRegType reg width = typeWidth ty +-} gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs) @@ -360,19 +383,19 @@ entryHeapCheck fun args srt code altHeapCheck :: [LocalReg] -> C_SRT -> FCode a -> FCode a altHeapCheck regs srt code - = heapCheck gc_call code + = do updfr_sz <- getUpdFrameOff + heapCheck False (gc_call updfr_sz) code where - gc_call - | null regs = mkCmmCall generic_gc [] [] srt + gc_call updfr_sz + | null regs = mkCall generic_gc GC [] [] updfr_sz | Just gc_lbl <- rts_label regs -- Canned call - = mkCmmCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) - regs - (map (CmmReg . CmmLocal) regs) - srt + = mkCall (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) GC + regs (map (CmmReg . CmmLocal) regs) updfr_sz | otherwise -- No canned call, and non-empty live vars - = mkCmmCall generic_gc [] [] srt + = mkCall generic_gc GC [] [] updfr_sz +{- rts_label [reg] | isGcPtrType ty = Just (sLit "stg_gc_unpt_r1") | isFloatType ty = case width of @@ -381,23 +404,26 @@ altHeapCheck regs srt code _other -> Nothing | otherwise = case width of W32 -> Just (sLit "stg_gc_unbx_r1") - W64 -> Just (sLit "stg_gc_unbx_l1") + W64 -> Just (sLit "stg_gc_l1") -- "stg_gc_fun_unbx_l1" _other -> Nothing -- Narrow cases 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 (mkRtsCodeLabel (sLit "stg_gc_fun"))) +generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs"))) +-- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST... +-- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun"))) ------------------------------- -heapCheck :: CmmAGraph -> FCode a -> FCode a -heapCheck do_gc code +heapCheck :: Bool -> CmmAGraph -> FCode a -> FCode a +heapCheck checkStack do_gc code = getHeapUsage $ \ hpHw -> - do { emit (do_checks hpHw do_gc) + 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 @@ -405,20 +431,27 @@ heapCheck do_gc code ; setRealHp hpHw ; code } -do_checks :: WordOff -- Heap headroom - -> CmmAGraph -- What to do on failure - -> CmmAGraph -do_checks 0 _ - = mkNop -do_checks alloc do_gc - = withFreshLabel "gc" $ \ blk_id -> - mkLabel blk_id Nothing - <*> mkAssign hpReg bump_hp - <*> mkCmmIfThen hp_oflo - (save_alloc - <*> do_gc - <*> mkBranch blk_id) - -- Bump heap pointer, and test for heap exhaustion +do_checks :: Bool -- Should we check the stack? + -> 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 emptyStackInfo + <*> (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) + <*> mkComment (mkFastString "outOfLine should follow:") + <*> outOfLine (mkLabel gc_id emptyStackInfo + <*> 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 @@ -427,6 +460,11 @@ do_checks alloc do_gc 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))) + [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. diff --git a/compiler/codeGen/StgCmmLayout.hs b/compiler/codeGen/StgCmmLayout.hs index f8d3964..1269897 100644 --- a/compiler/codeGen/StgCmmLayout.hs +++ b/compiler/codeGen/StgCmmLayout.hs @@ -17,7 +17,8 @@ module StgCmmLayout ( mkArgDescr, emitCall, emitReturn, - emitClosureCodeAndInfoTable, + emitClosureProcAndInfoTable, + emitClosureAndInfoTable, slowCall, directCall, @@ -47,6 +48,7 @@ import CmmUtils import Cmm import CLabel import StgSyn +import DataCon import Id import Name import TyCon ( PrimRep(..) ) @@ -62,7 +64,7 @@ import Constants import Util import Data.List import Outputable -import FastString ( LitString, sLit ) +import FastString ( mkFastString, LitString, sLit ) ------------------------------------------------------------------------ -- Call and return sequences @@ -77,21 +79,24 @@ emitReturn :: [CmmExpr] -> FCode () -- p=x; q=y; emitReturn results = do { adjustHpBackwards - ; sequel <- getSequel; + ; sequel <- getSequel; + ; updfr_off <- getUpdFrameOff ; case sequel of - Return _ -> emit (mkReturn results) - AssignTo regs _ -> emit (mkMultiAssign regs results) + Return _ -> emit (mkReturnSimple results updfr_off) + AssignTo regs _ -> emit (mkMultiAssign regs results) } -emitCall :: CmmExpr -> [CmmExpr] -> FCode () +emitCall :: Convention -> CmmExpr -> [CmmExpr] -> FCode () -- (cgCall fun args) makes a call to the entry-code of 'fun', -- passing 'args', and returning the results to the current sequel -emitCall fun args +emitCall conv fun args = do { adjustHpBackwards - ; sequel <- getSequel; + ; sequel <- getSequel + ; updfr_off <- getUpdFrameOff + ; emit $ mkComment $ mkFastString "emitcall" ; case sequel of - Return _ -> emit (mkJump fun args) - AssignTo res_regs srt -> emit (mkCmmCall fun res_regs args srt) + Return _ -> emit (mkForeignJump conv fun args updfr_off) + AssignTo res_regs srt -> emit (mkCall fun conv res_regs args updfr_off) } adjustHpBackwards :: FCode () @@ -132,7 +137,7 @@ directCall :: CLabel -> Arity -> [StgArg] -> FCode () -- Both arity and args include void args directCall lbl arity stg_args = do { cmm_args <- getNonVoidArgAmodes stg_args - ; direct_call lbl arity cmm_args (argsLReps stg_args) } + ; direct_call "directCall" lbl arity cmm_args (argsLReps stg_args) } slowCall :: CmmExpr -> [StgArg] -> FCode () -- (slowCall fun args) applies fun to args, returning the results to Sequel @@ -141,36 +146,42 @@ slowCall fun stg_args ; slow_call fun cmm_args (argsLReps stg_args) } -------------- -direct_call :: CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode () --- NB1: (length args) maybe less than (length reps), because +direct_call :: String -> CLabel -> Arity -> [CmmExpr] -> [LRep] -> FCode () +-- NB1: (length args) may be less than (length reps), because -- the args exclude the void ones -- NB2: 'arity' refers to the *reps* -direct_call lbl arity args reps - | null rest_args - = ASSERT( arity == length args) - emitCall target args +direct_call caller lbl arity args reps + | debugIsOn && arity > length reps -- Too few args + = -- Caller should ensure that there enough args! + pprPanic "direct_call" (text caller <+> ppr arity <+> ppr lbl <+> ppr (length reps) + <+> ppr args <+> ppr reps ) - | otherwise + | null rest_reps -- Precisely the right number of arguments + = emitCall Native target args + + | otherwise -- Over-saturated call = ASSERT( arity == length initial_reps ) do { pap_id <- newTemp gcWord ; let srt = pprTrace "Urk! SRT for over-sat call" (ppr lbl) NoC_SRT -- XXX: what if rest_args contains static refs? ; withSequel (AssignTo [pap_id] srt) - (emitCall target args) + (emitCall Native target fast_args) ; slow_call (CmmReg (CmmLocal pap_id)) rest_args rest_reps } where target = CmmLit (CmmLabel lbl) (initial_reps, rest_reps) = splitAt arity reps arg_arity = count isNonV initial_reps - (_, rest_args) = splitAt arg_arity args + (fast_args, rest_args) = splitAt arg_arity args -------------- slow_call :: CmmExpr -> [CmmExpr] -> [LRep] -> FCode () slow_call fun args reps - = direct_call (mkRtsApFastLabel rts_fun) (arity+1) - (fun : args) (P : reps) + = do call <- getCode $ direct_call "slow_call" (mkRtsApFastLabel rts_fun) arity args reps + emit $ mkComment $ mkFastString ("slow_call for " ++ showSDoc (ppr fun) ++ + " with pat " ++ showSDoc (ptext rts_fun)) + emit (mkAssign nodeReg fun <*> call) where (rts_fun, arity) = slowCallPattern reps @@ -207,6 +218,13 @@ data LRep = P -- GC Ptr | V -- Void | F -- Float | D -- Double +instance Outputable LRep where + ppr P = text "P" + ppr N = text "N" + ppr L = text "L" + ppr V = text "V" + ppr F = text "F" + ppr D = text "D" toLRep :: PrimRep -> LRep toLRep VoidRep = V @@ -254,7 +272,7 @@ mkVirtHeapOffsets -> [(PrimRep,a)] -- Things to make offsets for -> (WordOff, -- _Total_ number of words allocated WordOff, -- Number of words allocated for *pointers* - [(a, VirtualHpOffset)]) + [(NonVoid a, VirtualHpOffset)]) -- Things with their offsets from start of object in order of -- increasing offset; BUT THIS MAY BE DIFFERENT TO INPUT ORDER @@ -279,7 +297,7 @@ mkVirtHeapOffsets is_thunk things computeOffset wds_so_far (rep, thing) = (wds_so_far + lRepSizeW (toLRep rep), - (thing, hdr_size + wds_so_far)) + (NonVoid thing, hdr_size + wds_so_far)) ------------------------------------------------------------------------- @@ -437,12 +455,36 @@ mkRegLiveness regs ptrs nptrs -- Here we make an info table of type 'CmmInfo'. The concrete -- representation as a list of 'CmmAddr' is handled later -- in the pipeline by 'cmmToRawCmm'. - -emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals - -> CmmAGraph -> FCode () -emitClosureCodeAndInfoTable cl_info args body - = do { info <- mkCmmInfo cl_info - ; emitProc info (infoLblToEntryLbl info_lbl) args body } +-- When loading the free variables, a function closure pointer may be tagged, +-- so we must take it into account. + +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 + -> FCode () +emitClosureProcAndInfoTable top_lvl bndr cl_info args body + = do { let lf_info = closureLFInfo cl_info + -- Bind the binder itself, but only if it's not a top-level + -- binding. We need non-top let-bindings to refer to the + -- top-level binding, which this binding would incorrectly shadow. + ; node <- if top_lvl then return $ idToReg (NonVoid bndr) + else bindToReg (NonVoid bndr) lf_info + ; arg_regs <- + pprTrace "bindArgsToRegs" (ppr args) $ + bindArgsToRegs args + ; emitClosureAndInfoTable cl_info (node : arg_regs) $ body (node, arg_regs) + } + +-- Data constructors need closures, but not with all the argument handling +-- needed for functions. The shared part goes here. +emitClosureAndInfoTable :: ClosureInfo -> [LocalReg] -> FCode () -> FCode () +emitClosureAndInfoTable cl_info args body + = do { info <- mkCmmInfo cl_info + ; blks <- getCode body + ; emitProc info (infoLblToEntryLbl info_lbl) args blks + } where info_lbl = infoTableLabelFromCI cl_info @@ -450,14 +492,18 @@ emitClosureCodeAndInfoTable cl_info args body -- Not used for return points. (The 'smRepClosureTypeInt' call would panic.) mkCmmInfo :: ClosureInfo -> FCode CmmInfo mkCmmInfo cl_info - = do { prof <- if opt_SccProfilingOn then + = do { info <- closureTypeInfo cl_info k_with_con_name return + ; prof <- if opt_SccProfilingOn then do fd_lit <- mkStringCLit (closureTypeDescr 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 prof cl_type info)) } + ; return (CmmInfo gc_target Nothing + (CmmInfoTable (isStaticClosure cl_info) prof cl_type info)) } where - info = closureTypeInfo cl_info + 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. diff --git a/compiler/codeGen/StgCmmMonad.hs b/compiler/codeGen/StgCmmMonad.hs index 3652639..2249a46 100644 --- a/compiler/codeGen/StgCmmMonad.hs +++ b/compiler/codeGen/StgCmmMonad.hs @@ -13,7 +13,7 @@ module StgCmmMonad ( returnFC, fixC, nopC, whenC, newUnique, newUniqSupply, - emit, emitData, emitProc, emitSimpleProc, + emit, emitData, emitProc, emitProcWithConvention, emitSimpleProc, getCmm, cgStmtsToBlocks, getCodeR, getCode, getHeapUsage, @@ -28,6 +28,8 @@ module StgCmmMonad ( setSRTLabel, getSRTLabel, setTickyCtrLabel, getTickyCtrLabel, + withUpdFrameOff, getUpdFrameOff, initUpdFrameOff, + HeapUsage(..), VirtualHpOffset, initHpUsage, getHpUsage, setHpUsage, heapHWM, setVirtHp, getVirtHp, setRealHp, @@ -50,6 +52,7 @@ module StgCmmMonad ( import StgCmmClosure import DynFlags import MkZipCfgCmm +import ZipCfgCmmRep (UpdFrameOffset) import BlockId import Cmm import CLabel @@ -157,12 +160,13 @@ fixC fcode = FCode ( data CgInfoDownwards -- information only passed *downwards* by the monad = MkCgInfoDown { - cgd_dflags :: DynFlags, - cgd_mod :: Module, -- Module being compiled - cgd_statics :: CgBindings, -- [Id -> info] : static environment - cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT - cgd_ticky :: CLabel, -- Current destination for ticky counts - cgd_sequel :: Sequel -- What to do at end of basic block + cgd_dflags :: DynFlags, + cgd_mod :: Module, -- Module being compiled + cgd_statics :: CgBindings, -- [Id -> info] : static environment + cgd_srt_lbl :: CLabel, -- Label of the current top-level SRT + cgd_updfr_off :: UpdFrameOffset, -- Size of current update frame + cgd_ticky :: CLabel, -- Current destination for ticky counts + cgd_sequel :: Sequel -- What to do at end of basic block } type CgBindings = IdEnv CgIdInfo @@ -173,10 +177,10 @@ data CgIdInfo -- Can differ from the Id at occurrence sites by -- virtue of being externalised, for splittable C , cg_lf :: LambdaFormInfo - , cg_loc :: CgLoc + , cg_loc :: CgLoc -- CmmExpr for the *tagged* value , cg_rep :: PrimRep -- Cache for (idPrimRep id) , cg_tag :: {-# UNPACK #-} !DynTag -- Cache for (lfDynTag cg_lf) - } + } data CgLoc = CmmLoc CmmExpr -- A stable CmmExpr; that is, one not mentioning @@ -206,21 +210,28 @@ data Sequel [LocalReg] -- Put result(s) in these regs and fall through -- NB: no void arguments here C_SRT -- Here are the statics live in the continuation - + -- E.g. case (case x# of 0# -> a; DEFAULT -> b) of { + -- r -> + -- When compiling the nested case, remember to put the + -- result in r, and fall through initCgInfoDown :: DynFlags -> Module -> CgInfoDownwards initCgInfoDown dflags mod - = MkCgInfoDown { cgd_dflags = dflags, - cgd_mod = mod, - cgd_statics = emptyVarEnv, - cgd_srt_lbl = error "initC: srt_lbl", - cgd_ticky = mkTopTickyCtrLabel, - cgd_sequel = initSequel } + = MkCgInfoDown { cgd_dflags = dflags, + cgd_mod = mod, + cgd_statics = emptyVarEnv, + cgd_srt_lbl = error "initC: srt_lbl", + cgd_updfr_off = initUpdFrameOff, + cgd_ticky = mkTopTickyCtrLabel, + cgd_sequel = initSequel } initSequel :: Sequel initSequel = Return False +initUpdFrameOff :: UpdFrameOffset +initUpdFrameOff = widthInBytes wordWidth -- space for the RA + -------------------------------------------------------- -- The code generator state @@ -240,7 +251,7 @@ data CgState -- the info-down part cgs_hp_usg :: HeapUsage, - + cgs_uniqs :: UniqSupply } data HeapUsage = @@ -253,10 +264,10 @@ type VirtualHpOffset = WordOff initCgState :: UniqSupply -> CgState initCgState uniqs - = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, - cgs_binds = emptyVarEnv, - cgs_hp_usg = initHpUsage, - cgs_uniqs = uniqs } + = MkCgState { cgs_stmts = mkNop, cgs_tops = nilOL, + cgs_binds = emptyVarEnv, + cgs_hp_usg = initHpUsage, + cgs_uniqs = uniqs } stateIncUsage :: CgState -> CgState -> CgState -- stateIncUsage@ e1 e2 incorporates in e1 @@ -408,6 +419,26 @@ setSRTLabel srt_lbl code withInfoDown code (info { cgd_srt_lbl = srt_lbl}) -- ---------------------------------------------------------------------------- +-- Get/set the size of the update frame + +-- We keep track of the size of the update frame so that we +-- can set the stack pointer to the proper address on return +-- (or tail call) from the closure. +-- There should be at most one update frame for each closure. +-- Note: I'm including the size of the original return address +-- in the size of the update frame -- hence the default case on `get'. + +withUpdFrameOff :: UpdFrameOffset -> FCode () -> FCode () +withUpdFrameOff size code + = do { info <- getInfoDown + ; withInfoDown code (info {cgd_updfr_off = size }) } + +getUpdFrameOff :: FCode UpdFrameOffset +getUpdFrameOff + = do { info <- getInfoDown + ; return $ cgd_updfr_off info } + +-- ---------------------------------------------------------------------------- -- Get/set the current ticky counter label getTickyCtrLabel :: FCode CLabel @@ -440,7 +471,8 @@ forkClosureBody body_code = do { info <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let body_info_down = info { cgd_sequel = initSequel } + ; let body_info_down = info { cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff } fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } ((),fork_state_out) = doFCode body_code body_info_down fork_state_in @@ -455,8 +487,9 @@ forkStatics body_code = do { info <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let rhs_info_down = info { cgd_statics = cgs_binds state, - cgd_sequel = initSequel } + ; let rhs_info_down = info { cgd_statics = cgs_binds state + , cgd_sequel = initSequel + , cgd_updfr_off = initUpdFrameOff } (result, fork_state_out) = doFCode body_code rhs_info_down (initCgState us) ; setState (state `addCodeBlocksFrom` fork_state_out) @@ -473,9 +506,9 @@ forkProc body_code = do { info_down <- getInfoDown ; us <- newUniqSupply ; state <- getState - ; let fork_state_in = (initCgState us) - { cgs_binds = cgs_binds state } - (result, fork_state_out) = doFCode body_code info_down fork_state_in + ; let info_down' = info_down { cgd_sequel = initSequel } + fork_state_in = (initCgState us) { cgs_binds = cgs_binds state } + (result, fork_state_out) = doFCode body_code info_down' fork_state_in ; setState $ state `addCodeBlocksFrom` fork_state_out ; return result } @@ -562,20 +595,22 @@ emitData sect lits where data_block = CmmData sect lits -emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () -emitProc info lbl args blocks +emitProcWithConvention :: Convention -> CmmInfo -> CLabel -> CmmFormals -> + CmmAGraph -> FCode () +emitProcWithConvention conv info lbl args blocks = do { us <- newUniqSupply - ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) Native args + ; let (offset, entry) = mkEntry (mkBlockId $ uniqFromSupply us) conv args blks = initUs_ us $ lgraphOfAGraph offset $ entry <*> blocks - -- ; blks <- cgStmtsToBlocks blocks ; let proc_block = CmmProc info lbl args blks ; state <- getState ; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } } +emitProc :: CmmInfo -> CLabel -> CmmFormals -> CmmAGraph -> FCode () +emitProc = emitProcWithConvention Native + emitSimpleProc :: CLabel -> CmmAGraph -> FCode () --- Emit a procedure whose body is the specified code; no info table -emitSimpleProc lbl code - = emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code +emitSimpleProc lbl code = + emitProc (CmmInfo Nothing Nothing CmmNonInfoTable) lbl [] code getCmm :: FCode () -> FCode CmmZ -- Get all the CmmTops (there should be no stmts) diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs index 96467fe..6940908 100644 --- a/compiler/codeGen/StgCmmPrim.hs +++ b/compiler/codeGen/StgCmmPrim.hs @@ -66,7 +66,9 @@ cgOpApp (StgFCallOp fcall _) stg_args res_ty cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty = ASSERT(isEnumerationTyCon tycon) - do { amode <- getArgAmode arg + do { args' <- getNonVoidArgAmodes [arg] + ; let amode = case args' of [amode] -> amode + _ -> panic "TagToEnumOp had void arg" ; emitReturn [tagToClosure tycon amode] } where -- If you're reading this code in the attempt to figure @@ -79,8 +81,8 @@ cgOpApp (StgPrimOp TagToEnumOp) [arg] res_ty cgOpApp (StgPrimOp primop) args res_ty | primOpOutOfLine primop = do { cmm_args <- getNonVoidArgAmodes args - ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) - ; emitCall fun cmm_args } + ; let fun = CmmLit (CmmLabel (mkRtsPrimOpLabel primop)) + ; pprTrace "cgOpApp" (ppr primop) $ emitCall PrimOp fun cmm_args } | ReturnsPrim VoidRep <- result_info = do cgPrimOp [] primop args diff --git a/compiler/codeGen/StgCmmProf.hs b/compiler/codeGen/StgCmmProf.hs index f442295..1a18b99 100644 --- a/compiler/codeGen/StgCmmProf.hs +++ b/compiler/codeGen/StgCmmProf.hs @@ -37,6 +37,7 @@ module StgCmmProf ( -- For REP_xxx constants, which are MachReps import StgCmmClosure +import StgCmmEnv import StgCmmUtils import StgCmmMonad import SMRep @@ -185,10 +186,10 @@ profAlloc words ccs -- Setting the cost centre in a new closure chooseDynCostCentres :: CostCentreStack - -> [Id] -- Args + -> [Id] -- Args -> StgExpr -- Body -> FCode (CmmExpr, CmmExpr) --- Called when alllcating a closure +-- Called when allocating a closure -- Tells which cost centre to put in the object, and which -- to blame the cost of allocation on chooseDynCostCentres ccs args body = do diff --git a/compiler/codeGen/StgCmmUtils.hs b/compiler/codeGen/StgCmmUtils.hs index 6cfca5f..057e559 100644 --- a/compiler/codeGen/StgCmmUtils.hs +++ b/compiler/codeGen/StgCmmUtils.hs @@ -52,6 +52,7 @@ import BlockId import Cmm import CmmExpr import MkZipCfgCmm +import ZipCfg hiding (last, unzip, zip) import CLabel import CmmUtils import PprCmm ( {- instances -} ) @@ -307,15 +308,17 @@ emitRtsCall' -> FCode () emitRtsCall' res fun args _vols safe = --error "emitRtsCall'" - do { emit caller_save - ; emit call + do { updfr_off <- getUpdFrameOff + ; emit caller_save + ; emit $ call updfr_off ; emit caller_load } where - call = if safe then - mkCall fun_expr CCallConv res' args' undefined - else - mkUnsafeCall (ForeignTarget fun_expr - (ForeignConvention CCallConv arg_hints res_hints)) res' args' + call updfr_off = + if safe then + mkCall fun_expr Native res' args' updfr_off + else + mkUnsafeCall (ForeignTarget fun_expr + (ForeignConvention CCallConv arg_hints res_hints)) res' args' (args', arg_hints) = unzip args (res', res_hints) = unzip res (caller_save, caller_load) = callerSaveVolatileRegs @@ -633,7 +636,7 @@ mkCmmSwitch via_C tag_expr branches mb_deflt lo_tag hi_tag mk_switch tag_expr' (sortLe le branches) mb_deflt lo_tag hi_tag via_C -- Sort the branches before calling mk_switch - <*> mkLabel join_lbl Nothing + <*> mkLabel join_lbl emptyStackInfo where (t1,_) `le` (t2,_) = t1 <= t2 @@ -706,9 +709,9 @@ mk_switch tag_expr branches mb_deflt lo_tag hi_tag via_C | Just deflt <- mb_deflt, (hi_tag - highest_branch) >= n_branches = mkCmmIfThenElse (cmmUGtWord tag_expr (CmmLit (mkIntCLit highest_branch))) + (mkBranch deflt) (mk_switch tag_expr branches mb_deflt lo_tag highest_branch via_C) - (mkBranch deflt) | otherwise -- Use an if-tree = mkCmmIfThenElse @@ -788,6 +791,7 @@ mkCmmLitSwitch scrut branches deflt label_code join_lbl deflt $ \ deflt -> label_branches join_lbl branches $ \ branches -> mk_lit_switch scrut' deflt (sortLe le branches) + <*> mkLabel join_lbl emptyStackInfo where le (t1,_) (t2,_) = t1 <= t2 @@ -795,12 +799,12 @@ mk_lit_switch :: CmmExpr -> BlockId -> [(Literal,BlockId)] -> CmmAGraph mk_lit_switch scrut deflt [(lit,blk)] - = mkCbranch - (CmmMachOp (MO_Ne rep) [scrut, CmmLit cmm_lit]) - deflt blk + = mkCbranch (CmmMachOp ne [scrut, CmmLit cmm_lit]) deflt blk where cmm_lit = mkSimpleLit lit - rep = typeWidth (cmmLitType cmm_lit) + cmm_ty = cmmLitType cmm_lit + rep = typeWidth cmm_ty + ne = if isFloatType cmm_ty then MO_F_Ne rep else MO_Ne rep mk_lit_switch scrut deflt_blk_id branches = mkCmmIfThenElse cond @@ -846,7 +850,7 @@ label_code :: BlockId -> CmmAGraph -> (BlockId -> CmmAGraph) -> CmmAGraph -- [L: code; goto J] fun L label_code join_lbl code thing_inside = withFreshLabel "switch" $ \lbl -> - outOfLine (mkLabel lbl Nothing <*> code <*> mkBranch join_lbl) + outOfLine (mkLabel lbl emptyStackInfo <*> code <*> mkBranch join_lbl) <*> thing_inside lbl @@ -881,10 +885,12 @@ getSRTInfo (SRT off len bmp) = do { id <- newUnique ; top_srt <- getSRTLabel ; let srt_desc_lbl = mkLargeSRTLabel id - ; emitRODataLits srt_desc_lbl - ( cmmLabelOffW top_srt off - : mkWordCLit (fromIntegral len) - : map mkWordCLit bmp) + -- JD: We're not constructing and emitting SRTs in the back end, + -- which renders this code wrong (and it now names a now-non-existent label). + -- ; emitRODataLits srt_desc_lbl + -- ( cmmLabelOffW top_srt off + -- : mkWordCLit (fromIntegral len) + -- : map mkWordCLit bmp) ; return (C_SRT srt_desc_lbl 0 srt_escape) } | otherwise diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index 3518761..22181fd 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -165,6 +165,7 @@ Library CLabel Cmm CmmBrokenBlock + CmmBuildInfoTables CmmCPS CmmCPSGen CmmCPSZ @@ -183,6 +184,7 @@ Library CmmProcPoint CmmProcPointZ CmmSpillReload + CmmStackLayout CmmTx CmmUtils CmmZipUtil diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs index dd88f72..c4e8ae7 100644 --- a/compiler/main/HscMain.lhs +++ b/compiler/main/HscMain.lhs @@ -81,6 +81,7 @@ import CodeGen ( codeGen ) import Cmm ( Cmm ) import PprCmm ( pprCmms ) import CmmParse ( parseCmmFile ) +import CmmBuildInfoTables import CmmCPS import CmmCPSZ import CmmInfo @@ -667,14 +668,12 @@ hscGenHardCode cgguts mod_summary <- {-# SCC "CoreToStg" #-} myCoreToStg dflags this_mod prepd_binds - ------------------ Try new code gen route ---------- - cmms <- tryNewCodeGen hsc_env this_mod data_tycons - dir_imps cost_centre_info - stg_binds hpc_info - ------------------ Code generation ------------------ cmms <- if dopt Opt_TryNewCodeGen (hsc_dflags hsc_env) - then pprTrace "cmms" (ppr cmms) $ return cmms + then do cmms <- tryNewCodeGen hsc_env this_mod data_tycons + dir_imps cost_centre_info + stg_binds hpc_info + pprTrace "cmms" (ppr cmms) $ return cmms else {-# SCC "CodeGen" #-} codeGen dflags this_mod data_tycons dir_imps cost_centre_info @@ -764,14 +763,17 @@ tryNewCodeGen hsc_env this_mod data_tycons imported_mods ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog -- Control flow optimisation - ; prog <- mapM (protoCmmCPSZ hsc_env) prog + -- Note: Have to thread the module's SRT through all the procedures + -- because we greedily build it as we go. + ; us <- mkSplitUniqSupply 'S' + ; let topSRT = initUs_ us emptySRT + ; (topSRT, prog) <- foldM (protoCmmCPSZ hsc_env) (topSRT, []) prog -- The main CPS conversion - ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) prog + ; prog <- return $ map (runTx $ runCmmOpts cmmCfgOptsZ) (srtToData topSRT : prog) -- Control flow optimisation, again - ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" - (pprCmms prog) + ; dumpIfSet_dyn dflags Opt_D_dump_cmmz "New Cmm" (pprCmms prog) ; return $ map cmmOfZgraph prog } @@ -802,7 +804,9 @@ testCmmConversion hsc_env cmm = let cvtm = do g <- cmmToZgraph cmm return $ cfopts g let zgraph = initUs_ us cvtm - cps_zgraph <- protoCmmCPSZ hsc_env zgraph + us <- mkSplitUniqSupply 'S' + let topSRT = initUs_ us emptySRT + (topSRT, [cps_zgraph]) <- protoCmmCPSZ 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" diff --git a/compiler/main/StaticFlagParser.hs b/compiler/main/StaticFlagParser.hs index 5e38af5..e68a111 100644 --- a/compiler/main/StaticFlagParser.hs +++ b/compiler/main/StaticFlagParser.hs @@ -122,6 +122,7 @@ static_flags = [ , Flag "dppr-user-length" (AnySuffix addOpt) Supported , Flag "dopt-fuel" (AnySuffix addOpt) Supported , Flag "dno-debug-output" (PassFlag addOpt) Supported + , Flag "dstub-dead-values" (PassFlag addOpt) Supported -- rest of the debugging flags are dynamic --------- Profiling -------------------------------------------------- diff --git a/compiler/main/StaticFlags.hs b/compiler/main/StaticFlags.hs index 2060554..2398c20 100644 --- a/compiler/main/StaticFlags.hs +++ b/compiler/main/StaticFlags.hs @@ -74,6 +74,7 @@ module StaticFlags ( opt_EmitExternalCore, v_Ld_inputs, tablesNextToCode, + opt_StubDeadValues, -- For the parser addOpt, removeOpt, addWay, findBuildTag, v_opt_C_ready @@ -242,6 +243,8 @@ opt_HistorySize :: Int opt_HistorySize = lookup_def_int "-fhistory-size" 20 opt_OmitBlackHoling :: Bool opt_OmitBlackHoling = lookUp (fsLit "-dno-black-holing") +opt_StubDeadValues :: Bool +opt_StubDeadValues = lookUp (fsLit "-dstub-dead-values") -- Simplifier switches opt_SimplNoPreInlining :: Bool diff --git a/compiler/nativeGen/MachRegs.lhs b/compiler/nativeGen/MachRegs.lhs index 2e578c0..5267e5b 100644 --- a/compiler/nativeGen/MachRegs.lhs +++ b/compiler/nativeGen/MachRegs.lhs @@ -96,6 +96,7 @@ module MachRegs ( #include "../includes/MachRegs.h" +import BlockId import Cmm import CgUtils ( get_GlobalReg_addr ) import CLabel ( CLabel, mkMainCapabilityLabel ) @@ -237,6 +238,7 @@ litToImm (CmmLabelDiffOff l1 l2 off) = ImmConstantSum (ImmConstantDiff (ImmCLbl l1) (ImmCLbl l2)) (ImmInt off) +litToImm (CmmBlock id) = ImmCLbl (infoTblLbl id) -- ----------------------------------------------------------------------------- -- Addressing modes diff --git a/compiler/nativeGen/PprMach.hs b/compiler/nativeGen/PprMach.hs index bb04287..2d59cf4 100644 --- a/compiler/nativeGen/PprMach.hs +++ b/compiler/nativeGen/PprMach.hs @@ -474,7 +474,7 @@ pprImm (ImmCLbl l) = pprCLabel_asm l pprImm (ImmIndex l i) = pprCLabel_asm l <> char '+' <> int i pprImm (ImmLit s) = s -pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") +pprImm (ImmFloat _) = ptext (sLit "naughty float immediate") pprImm (ImmDouble _) = ptext (sLit "naughty double immediate") pprImm (ImmConstantSum a b) = pprImm a <> char '+' <> pprImm b diff --git a/compiler/nativeGen/RegAllocLinear.hs b/compiler/nativeGen/RegAllocLinear.hs index 918d7c6..2e6e37c 100644 --- a/compiler/nativeGen/RegAllocLinear.hs +++ b/compiler/nativeGen/RegAllocLinear.hs @@ -246,9 +246,8 @@ regAlloc (CmmData sec d) , Nothing ) regAlloc (CmmProc (LiveInfo info _ _) lbl params (ListGraph [])) - = return - ( CmmProc info lbl params (ListGraph []) - , Nothing ) + = return ( CmmProc info lbl params (ListGraph []) + , Nothing ) regAlloc (CmmProc static lbl params (ListGraph comps)) | LiveInfo info (Just first_id) block_live <- static @@ -350,7 +349,7 @@ processBlock block_live (BasicBlock id instrs) initBlock :: BlockId -> RegM () initBlock id = do block_assig <- getBlockAssigR - case lookupUFM block_assig id of + case lookupBlockEnv block_assig id of -- no prior info about this block: assume everything is -- free and the assignment is empty. Nothing @@ -775,13 +774,13 @@ joinToTargets block_live new_blocks instr (dest:dests) = do regsOfLoc (InBoth r _) = [r] regsOfLoc (InMem _) = [] -- in - case lookupUFM block_assig dest of + case lookupBlockEnv block_assig dest of -- Nothing <=> this is the first time we jumped to this -- block. Nothing -> do freeregs <- getFreeRegsR let freeregs' = foldr releaseReg freeregs to_free - setBlockAssigR (addToUFM block_assig dest + setBlockAssigR (extendBlockEnv block_assig dest (freeregs',adjusted_assig)) joinToTargets block_live new_blocks instr dests @@ -1114,5 +1113,5 @@ my_fromJust :: String -> SDoc -> Maybe a -> a my_fromJust _ _ (Just x) = x my_fromJust s p Nothing = pprPanic ("fromJust: " ++ s) p -lookItUp :: Uniquable b => String -> UniqFM a -> b -> a -lookItUp str fm x = my_fromJust str (ppr (getUnique x)) (lookupUFM fm x) +lookItUp :: String -> BlockMap a -> BlockId -> a +lookItUp str fm x = my_fromJust str (ppr x) (lookupBlockEnv fm x) diff --git a/compiler/nativeGen/RegLiveness.hs b/compiler/nativeGen/RegLiveness.hs index 039a5de..fc8749c 100644 --- a/compiler/nativeGen/RegLiveness.hs +++ b/compiler/nativeGen/RegLiveness.hs @@ -58,10 +58,10 @@ type RegMap a = UniqFM a emptyRegMap :: UniqFM a emptyRegMap = emptyUFM -type BlockMap a = UniqFM a +type BlockMap a = BlockEnv a -emptyBlockMap :: UniqFM a -emptyBlockMap = emptyUFM +emptyBlockMap :: BlockEnv a +emptyBlockMap = emptyBlockEnv -- | A top level thing which carries liveness information. @@ -200,7 +200,7 @@ slurpConflicts live slurpBlock info rs (BasicBlock blockId instrs) | LiveInfo _ _ blockLive <- info - , Just rsLiveEntry <- lookupUFM blockLive blockId + , Just rsLiveEntry <- lookupBlockEnv blockLive blockId , (conflicts, moves) <- slurpLIs rsLiveEntry rs instrs = (consBag rsLiveEntry conflicts, moves) @@ -346,7 +346,8 @@ stripLive live where stripCmm (CmmData sec ds) = CmmData sec ds stripCmm (CmmProc (LiveInfo info _ _) label params (ListGraph comps)) - = CmmProc info label params (ListGraph $ concatMap stripComp comps) + = CmmProc info label params + (ListGraph $ concatMap stripComp comps) stripComp (BasicBlock _ blocks) = map stripBlock blocks stripBlock (BasicBlock i instrs) = BasicBlock i (map stripLI instrs) @@ -411,7 +412,7 @@ patchEraseLive patchF cmm patchCmm (CmmProc info label params (ListGraph comps)) | LiveInfo static id blockMap <- info = let patchRegSet set = mkUniqSet $ map patchF $ uniqSetToList set - blockMap' = mapUFM patchRegSet blockMap + blockMap' = mapBlockEnv patchRegSet blockMap info' = LiveInfo static id blockMap' in CmmProc info' label params $ ListGraph $ map patchComp comps @@ -480,7 +481,7 @@ regLiveness (CmmData i d) regLiveness (CmmProc info lbl params (ListGraph [])) = returnUs $ CmmProc - (LiveInfo info Nothing emptyUFM) + (LiveInfo info Nothing emptyBlockEnv) lbl params (ListGraph []) regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _))) @@ -496,9 +497,8 @@ regLiveness (CmmProc info lbl params (ListGraph blocks@(first : _))) -> panic "RegLiveness.regLiveness: no blocks in scc list") $ ann_sccs - in returnUs $ CmmProc - (LiveInfo info (Just first_id) block_live) - lbl params (ListGraph liveBlocks) + in returnUs $ CmmProc (LiveInfo info (Just first_id) block_live) + lbl params (ListGraph liveBlocks) sccBlocks :: [NatBasicBlock] -> [SCC NatBasicBlock] @@ -569,8 +569,8 @@ livenessSCCs blockmap done -- BlockMaps for equality. equalBlockMaps a b = a' == b' - where a' = map f $ ufmToList a - b' = map f $ ufmToList b + where a' = map f $ blockEnvToList a + b' = map f $ blockEnvToList b f (key,elt) = (key, uniqSetToList elt) @@ -586,7 +586,7 @@ livenessBlock blockmap (BasicBlock block_id instrs) = let (regsLiveOnEntry, instrs1) = livenessBack emptyUniqSet blockmap [] (reverse instrs) - blockmap' = addToUFM blockmap block_id regsLiveOnEntry + blockmap' = extendBlockEnv blockmap block_id regsLiveOnEntry instrs2 = livenessForward regsLiveOnEntry instrs1 @@ -686,9 +686,9 @@ liveness1 liveregs blockmap instr not_a_branch = null targets targetLiveRegs target - = case lookupUFM blockmap target of + = case lookupBlockEnv blockmap target of Just ra -> ra - Nothing -> emptyBlockMap + Nothing -> emptyRegMap live_from_branch = unionManyUniqSets (map targetLiveRegs targets) diff --git a/compiler/nativeGen/RegSpillCost.hs b/compiler/nativeGen/RegSpillCost.hs index d987937..6a2066a 100644 --- a/compiler/nativeGen/RegSpillCost.hs +++ b/compiler/nativeGen/RegSpillCost.hs @@ -21,6 +21,7 @@ import RegLiveness import RegAllocInfo import MachInstrs import MachRegs +import BlockId import Cmm import UniqFM @@ -78,7 +79,7 @@ slurpSpillCostInfo cmm -- the info table from the CmmProc countBlock info (BasicBlock blockId instrs) | LiveInfo _ _ blockLive <- info - , Just rsLiveEntry <- lookupUFM blockLive blockId + , Just rsLiveEntry <- lookupBlockEnv blockLive blockId = countLIs rsLiveEntry instrs | otherwise -- 1.7.10.4