-{-# OPTIONS -w #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and fix
--- any warnings in the module. See
--- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
--- for details
-
module CmmCPS (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
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 dflags cmm_with_calls
= do { when (dopt Opt_DoCmmLinting dflags) $
do showPass dflags "CmmLint"
- case firstJust $ map cmmLint cmm_with_calls of
+ case firstJusts $ map cmmLint cmm_with_calls of
Just err -> do printDump err
ghcExit dflags 1
Nothing -> return ()
-- 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 _ _ _ (ListGraph []))
+cpsProc _ proc@(CmmProc _ _ _ (ListGraph []))
= pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
-- CPS transform for those procs that actually need it
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]
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"
argumentsSize (cmmExprType . hintlessCmm) args
final_arg_size (FinalJump _ args) =
argumentsSize (cmmExprType . hintlessCmm) args
- final_arg_size (FinalCall next _ _ args _ _ True) = 0
+ 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
-> 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
projects / ghc-hetmet.git / blobdiff