+{-# 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.
#include "HsVersions.h"
+import BlockId
import Cmm
import CmmLint
import PprCmm
import CmmProcPoint
import CmmCallConv
import CmmCPSGen
-import CmmInfo
import CmmUtils
import ClosureInfo
import MachOp
-import ForeignCall
import CLabel
import SMRep
import Constants
-- |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 firstJust $ 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 }
-stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
-make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
- where
- stmts = [CmmCall stg_gc_gen_target [] [] safety,
- CmmJump fun_expr actuals]
- stg_gc_gen_target =
- CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
- actuals = map (\x -> (CmmReg (CmmLocal x), NoHint)) formals
- fun_expr = CmmLit (CmmLabel fun_label)
-
-make_gc_check stack_use gc_block =
- [CmmCondBranch
- (CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
- [CmmReg stack_use, CmmReg spLimReg])
- gc_block]
-
-force_gc_block old_info stack_use block_id fun_label formals =
- case old_info of
- CmmInfo (Just existing) _ _
- -> (old_info, [], make_gc_check stack_use existing)
- CmmInfo Nothing update_frame info_table
- -> (CmmInfo (Just block_id) update_frame info_table,
- [make_gc_block block_id fun_label formals (CmmSafe $ cmmInfoTableSRT info_table)],
- make_gc_check stack_use block_id)
-
-cmmInfoTableSRT CmmNonInfoTable = NoC_SRT
-cmmInfoTableSRT (CmmInfoTable _ _ (ConstrInfo _ _ _)) = NoC_SRT
-cmmInfoTableSRT (CmmInfoTable _ _ (FunInfo _ srt _ _ _ _)) = srt
-cmmInfoTableSRT (CmmInfoTable _ _ (ThunkInfo _ srt)) = srt
-cmmInfoTableSRT (CmmInfoTable _ _ (ThunkSelectorInfo _ srt)) = srt
-cmmInfoTableSRT (CmmInfoTable _ _ (ContInfo _ srt)) = srt
-----------------------------------------------------------------------------
-- |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]
-- 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 uniqSupply 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
+ -- but since there is no other reason to make it monadic,
+ -- we instead will just split them all up right here.
(uniqSupply1, uniqSupply2) = splitUniqSupply uniqSupply
uniques :: [[Unique]]
uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply1
- (gc_unique:gc_block_unique:stack_use_unique:info_uniques):adaptor_uniques:block_uniques = uniques
- proc_uniques = map (map uniqsFromSupply . listSplitUniqSupply) $ listSplitUniqSupply uniqSupply2
+ (stack_check_block_unique:stack_use_unique:adaptor_uniques) :
+ 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 (cmmRegRep spReg) GCKindPtr)
+ 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)
- -- TODO: doc
- forced_gc :: (CmmInfo, [CmmBasicBlock], [CmmStmt])
- forced_gc = force_gc_block info stack_use (BlockId gc_unique) ident params
- (forced_info, gc_blocks, check_stmts) = forced_gc
- gc_block_id = BlockId gc_block_unique
+ forced_blocks = stack_check_block : blocks
- forced_blocks =
- BasicBlock gc_block_id
- (check_stmts++[CmmBranch $ blockId $ head blocks]) :
- blocks ++ gc_blocks
-
- forced_gc_id = case forced_info of
- CmmInfo (Just x) _ _ -> x
-
- update_frame = case info of CmmInfo _ u _ -> u
+ CmmInfo maybe_gc_block_id update_frame _ = info
-- Break the block at each function call.
-- The part after the function call will have to become a continuation.
broken_blocks :: ([(BlockId, ContFormat)], [BrokenBlock])
broken_blocks =
(\x -> (concatMap fst x, concatMap snd x)) $
- zipWith3 (breakBlock [forced_gc_id])
+ zipWith3 (breakBlock (maybeToList maybe_gc_block_id))
block_uniques
forced_blocks
- (FunctionEntry forced_info ident params :
+ (FunctionEntry info ident params :
repeat ControlEntry)
f' = selectContinuations (fst broken_blocks)
-- This is an association list instead of a UniqFM because
-- CLabel's don't have a 'Uniqueable' instance.
formats :: [(CLabel, -- key
- (CmmFormals, -- arguments
+ (CmmFormalsWithoutKinds, -- arguments
Maybe CLabel, -- label in top slot
[Maybe LocalReg]))] -- slots
formats = selectContinuationFormat live continuations
cps_procs :: [CmmTop]
cps_procs = zipWith (continuationToProc formats' stack_use) proc_uniques continuations'
+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 _ _
+ -> []
-----------------------------------------------------------------------------
collectNonProcPointTargets ::
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 (panic "TODO") start
+ start_block = lookupWithDefaultUFM blocks unknown_block start
+ children_blocks = map (lookupWithDefaultUFM blocks unknown_block) (uniqSetToList children)
unknown_block = panic "unknown block in gatherBlocksIntoContinuation"
- children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
body = start_block : children_blocks
-- We can't properly annotate the continuation's stack parameters
selectContinuationFormat :: BlockEnv CmmLive
-> [Continuation (Either C_SRT CmmInfo)]
- -> [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
+ -> [(CLabel, (CmmFormalsWithoutKinds, Maybe CLabel, [Maybe LocalReg]))]
selectContinuationFormat live continuations =
map (\c -> (continuationLabel c, selectContinuationFormat' c)) continuations
where
unknown_block = panic "unknown BlockId in selectContinuationFormat"
-processFormats :: [(CLabel, (CmmFormals, Maybe CLabel, [Maybe LocalReg]))]
+processFormats :: [(CLabel, (CmmFormalsWithoutKinds, Maybe CLabel, [Maybe LocalReg]))]
-> Maybe UpdateFrame
-> [Continuation (Either C_SRT CmmInfo)]
-> (WordOff, WordOff, [(CLabel, ContinuationFormat)])
map stmt_arg_size (brokenBlockStmts block))
final_arg_size (FinalReturn args) =
- argumentsSize (cmmExprRep . fst) args
+ argumentsSize (cmmExprRep . kindlessCmm) 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 (cmmExprRep . kindlessCmm) args
+ final_arg_size (FinalCall next _ _ args _ _ 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 (cmmExprRep . kindlessCmm) 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 (cmmExprRep . kindlessCmm) args
+ stmt_arg_size (CmmCall _ _ _ (CmmSafe _) _) =
panic "Safe call in processFormats"
stmt_arg_size (CmmReturn _) =
panic "CmmReturn in processFormats"
projects / ghc-hetmet.git / blobdiff