#include "HsVersions.h"
+import BlockId
import Cmm
import CmmLint
import PprCmm
import CmmUtils
import ClosureInfo
-import MachOp
import CLabel
import SMRep
import Constants
import Maybes
import Outputable
import UniqSupply
-import UniqFM
import UniqSet
import Unique
-import Monad
-import IO
-import Data.List
+import Control.Monad
-----------------------------------------------------------------------------
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
- -> [GenCmm CmmStatic CmmInfo CmmStmt] -- ^ Input C-- with Proceedures
- -> IO [GenCmm CmmStatic CmmInfo CmmStmt] -- ^ Output CPS transformed C--
-cmmCPS dflags abstractC = do
- when (dopt Opt_DoCmmLinting dflags) $
- do showPass dflags "CmmLint"
- case firstJust $ map cmmLint abstractC of
- Just err -> do printDump err
- ghcExit dflags 1
- Nothing -> return ()
- showPass dflags "CPS"
+ -> [Cmm] -- ^ Input C-- with Proceedures
+ -> IO [Cmm] -- ^ Output CPS transformed C--
+cmmCPS dflags cmm_with_calls
+ = do { when (dopt Opt_DoCmmLinting dflags) $
+ do showPass dflags "CmmLint"
+ case firstJusts $ map cmmLint cmm_with_calls of
+ Just err -> do printDump err
+ ghcExit dflags 1
+ Nothing -> return ()
+ ; showPass dflags "CPS"
-- TODO: more lint checking
-- check for use of branches to non-existant blocks
-- check for use of Sp, SpLim, R1, R2, etc.
- uniqSupply <- mkSplitUniqSupply 'p'
- let supplies = listSplitUniqSupply uniqSupply
- let doCpsProc s (Cmm c) =
- Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
- let continuationC = zipWith doCpsProc supplies abstractC
+ ; uniqSupply <- mkSplitUniqSupply 'p'
+ ; let supplies = listSplitUniqSupply uniqSupply
+ ; let cpsd_cmm = zipWith doCpsProc supplies cmm_with_calls
- dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms continuationC)
+ ; dumpIfSet_dyn dflags Opt_D_dump_cps_cmm "CPS Cmm" (pprCmms cpsd_cmm)
-- TODO: add option to dump Cmm to file
- return continuationC
+ ; return cpsd_cmm }
-make_stack_check stack_check_block_id info stack_use next_block_id =
- BasicBlock stack_check_block_id $
- check_stmts ++ [CmmBranch next_block_id]
- where
- check_stmts =
- case info of
- -- If we are given a stack check handler,
- -- then great, well check the stack.
- CmmInfo (Just gc_block) _ _
- -> [CmmCondBranch
- (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
- [CmmReg stack_use, CmmReg spLimReg])
- gc_block]
- -- If we aren't given a stack check handler,
- -- then humph! we just won't check the stack for them.
- CmmInfo Nothing _ _
- -> []
-----------------------------------------------------------------------------
-- |CPS a single CmmTop (proceedure)
-- Only 'CmmProc' are transformed 'CmmData' will be left alone.
-----------------------------------------------------------------------------
+doCpsProc :: UniqSupply -> Cmm -> Cmm
+doCpsProc s (Cmm c)
+ = Cmm $ concat $ zipWith cpsProc (listSplitUniqSupply s) c
+
cpsProc :: UniqSupply
- -> GenCmmTop CmmStatic CmmInfo CmmStmt -- ^Input proceedure
- -> [GenCmmTop CmmStatic CmmInfo CmmStmt] -- ^Output proceedure and continuations
+ -> CmmTop -- ^Input procedure
+ -> [CmmTop] -- ^Output procedures;
+ -- a single input procedure is converted to
+ -- multiple output procedures
-- Data blocks don't need to be CPS transformed
-cpsProc uniqSupply proc@(CmmData _ _) = [proc]
+cpsProc _ proc@(CmmData _ _) = [proc]
-- Empty functions just don't work with the CPS algorithm, but
-- they don't need the transformation anyway so just output them directly
-cpsProc uniqSupply proc@(CmmProc _ _ _ []) = [proc]
+cpsProc _ proc@(CmmProc _ _ _ (ListGraph []))
+ = pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
-- CPS transform for those procs that actually need it
-cpsProc uniqSupply (CmmProc info ident params blocks) = cps_procs
+-- The plan is this:
+--
+-- * Introduce a stack-check block as the first block
+-- * The first blocks gets a FunctionEntry; the rest are ControlEntry
+-- * Now break each block into a bunch of blocks (at call sites);
+-- all but the first will be ContinuationEntry
+--
+cpsProc uniqSupply (CmmProc info ident params (ListGraph blocks)) = cps_procs
where
-- We need to be generating uniques for several things.
-- We could make this function monadic to handle that
block_uniques = uniques
proc_uniques = map (map (map uniqsFromSupply . listSplitUniqSupply) . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
- stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegRep spReg) KindPtr)
+ stack_use = CmmLocal (LocalReg stack_use_unique (cmmRegType spReg))
stack_check_block_id = BlockId stack_check_block_unique
stack_check_block = make_stack_check stack_check_block_id info stack_use (blockId $ head blocks)
cps_procs :: [CmmTop]
cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
+make_stack_check :: BlockId -> CmmInfo -> CmmReg -> BlockId
+ -> GenBasicBlock CmmStmt
+make_stack_check stack_check_block_id info stack_use next_block_id =
+ BasicBlock stack_check_block_id $
+ check_stmts ++ [CmmBranch next_block_id]
+ where
+ check_stmts =
+ case info of
+ -- If we are given a stack check handler,
+ -- then great, well check the stack.
+ CmmInfo (Just gc_block) _ _
+ -> [CmmCondBranch
+ (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
+ [CmmReg stack_use, CmmReg spLimReg])
+ gc_block]
+ -- If we aren't given a stack check handler,
+ -- then humph! we just won't check the stack for them.
+ CmmInfo Nothing _ _
+ -> []
-----------------------------------------------------------------------------
collectNonProcPointTargets ::
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,
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 :: a -- Used at more than one type
unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
body = start_block : children_blocks
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
--------------------------------------------------------------------------------
where
-- User written continuations
selectContinuationFormat' (Continuation
- (Right (CmmInfo _ _ (CmmInfoTable _ _ (ContInfo format srt))))
+ (Right (CmmInfo _ _ (CmmInfoTable _ _ _ (ContInfo format _))))
label formals _ _) =
(formals, Just label, format)
-- Either user written non-continuation code
selectContinuationFormat' (Continuation (Right _) _ formals _ _) =
(formals, Nothing, [])
-- CPS generated continuations
- selectContinuationFormat' (Continuation (Left srt) label formals _ blocks) =
+ selectContinuationFormat' (Continuation (Left _) label formals _ blocks) =
-- TODO: assumes the first block is the entry block
let ident = brokenBlockId $ head blocks -- TODO: CLabel isn't a uniquable, but we need a better way than this
in (formals,
Just label,
map Just $ uniqSetToList $
- lookupWithDefaultUFM live unknown_block ident)
+ lookupWithDefaultBEnv live unknown_block ident)
unknown_block = panic "unknown BlockId in selectContinuationFormat"
update_size [] = 0
update_size (expr:exprs) = width + update_size exprs
where
- width = machRepByteWidth (cmmExprRep expr) `quot` wORD_SIZE
+ width = (widthInBytes $ typeWidth $ cmmExprType expr) `quot` wORD_SIZE
-- TODO: it would be better if we had a machRepWordWidth
-- TODO: get rid of "+ 1" etc.
stack_size (Nothing:formats) = 1 + stack_size formats -- one dead word
stack_size (Just reg:formats) = width + stack_size formats
where
- width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
+ width = (widthInBytes $ typeWidth $ localRegType reg) `quot` wORD_SIZE
-- TODO: it would be better if we had a machRepWordWidth
continuationMaxStack :: [(CLabel, ContinuationFormat)]
map stmt_arg_size (brokenBlockStmts block))
final_arg_size (FinalReturn args) =
- argumentsSize (cmmExprRep . fst) args
+ argumentsSize (cmmExprType . hintlessCmm) args
final_arg_size (FinalJump _ args) =
- argumentsSize (cmmExprRep . fst) args
- final_arg_size (FinalCall next _ _ args _ True) = 0
- final_arg_size (FinalCall next _ _ args _ False) =
+ argumentsSize (cmmExprType . hintlessCmm) args
+ final_arg_size (FinalCall _ _ _ _ _ _ True) = 0
+ final_arg_size (FinalCall next _ _ args _ _ False) =
-- We have to account for the stack used when we build a frame
-- for the *next* continuation from *this* continuation
- argumentsSize (cmmExprRep . fst) args +
+ argumentsSize (cmmExprType . hintlessCmm) args +
continuation_frame_size next_format
where
next_format = maybe unknown_format id $ lookup next' formats
final_arg_size _ = 0
stmt_arg_size (CmmJump _ args) =
- argumentsSize (cmmExprRep . fst) args
- stmt_arg_size (CmmCall _ _ _ (CmmSafe _)) =
+ argumentsSize (cmmExprType . hintlessCmm) args
+ stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
panic "Safe call in processFormats"
stmt_arg_size (CmmReturn _) =
panic "CmmReturn in processFormats"
-> 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
unknown_block = panic "unknown BlockId in applyContinuationFormat"
-- Either user written non-continuation code or CPS generated proc-point
-applyContinuationFormat formats (Continuation
+applyContinuationFormat _ (Continuation
(Right info) label formals is_gc blocks) =
Continuation info label formals is_gc blocks
-- CPS generated continuations
applyContinuationFormat formats (Continuation
(Left srt) label formals is_gc blocks) =
- Continuation (CmmInfo gc Nothing (CmmInfoTable 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