Commit e6243a81 authored by's avatar

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.
parent 176fa33f
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
......@@ -107,7 +107,7 @@ module CLabel (
infoLblToEntryLbl, entryLblToInfoLbl,
infoLblToEntryLbl, entryLblToInfoLbl, cvtToClosureLbl, cvtToSRTLbl,
needsCDecl, isAsmTemp, maybeAsmTemp, externallyVisibleCLabel,
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
......@@ -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,
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
(Maybe UpdateFrame) -- Update frame
CmmInfoTable -- Info table
-- Info table as a haskell data type
data CmmInfoTable
= CmmInfoTable
ClosureTypeTag -- Int
| 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.
......@@ -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
......@@ -219,7 +219,7 @@ collectNonProcPointTargets proc_points blocks current_targets new_blocks =
(map (:[]) targets)
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
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 =
-- 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
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
gc = Nothing -- Generated continuations never need a stack check
......@@ -5,36 +5,59 @@ module CmmCPSZ (
) 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
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
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 =
......@@ -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
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
(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
(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
(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)
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
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.