-{-# OPTIONS_GHC -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/WorkingConventions#Warnings
--- for details
-
module CmmCPS (
-- | Converts C-- with full proceedures and parameters
-- to a CPS transformed C-- with the stack made manifest.
#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
-- 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 _ _ _ [])
+cpsProc _ proc@(CmmProc _ _ _ (ListGraph []))
= pprTrace "cpsProc: unexpected empty proc" (ppr proc) [proc]
-- CPS transform for those procs that actually need it
-- * 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 blocks) = cps_procs
+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]
-- then great, well check the stack.
CmmInfo (Just gc_block) _ _
-> [CmmCondBranch
- (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
+ (CmmMachOp (MO_U_Lt (typeWidth (cmmRegType spReg)))
[CmmReg stack_use, CmmReg spLimReg])
gc_block]
-- If we aren't given a stack check handler,
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
+ 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
+ argumentsSize (cmmExprType . hintlessCmm) args
stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
panic "Safe call in processFormats"
stmt_arg_size (CmmReturn _) =
-> 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