| LargeSRTLabel -- Label of an StgLargeSRT
{-# UNPACK #-} !Unique
+ | LargeBitmapLabel -- A bitmap (function or case return)
+ {-# UNPACK #-} !Unique
+
deriving (Eq, Ord)
data IdLabelInfo
| RednCounts -- Label of place to keep Ticky-ticky info for
-- this Id
- | Bitmap -- A bitmap (function or case return)
-
| ConEntry -- constructor entry point
| ConInfoTable -- corresponding info table
| StaticConEntry -- static constructor entry point
-- These are always local:
mkSRTLabel name = IdLabel name SRT
mkSlowEntryLabel name = IdLabel name Slow
-mkBitmapLabel name = IdLabel name Bitmap
mkRednCountsLabel name = IdLabel name RednCounts
-- These have local & (possibly) external variants:
| otherwise = IdLabel name StaticConEntry
mkLargeSRTLabel uniq = LargeSRTLabel uniq
+mkBitmapLabel uniq = LargeBitmapLabel uniq
mkReturnPtLabel uniq = CaseLabel uniq CaseReturnPt
mkReturnInfoLabel uniq = CaseLabel uniq CaseReturnInfo
-- they are defined before use.
needsCDecl (IdLabel _ SRT) = False
needsCDecl (LargeSRTLabel _) = False
-needsCDecl (IdLabel _ Bitmap) = False
+needsCDecl (LargeBitmapLabel _) = False
needsCDecl (IdLabel _ _) = True
needsCDecl (DynIdLabel _ _) = True
needsCDecl (CaseLabel _ _) = True
labelType (CaseLabel _ _) = CodeLabel
labelType (ModuleInitLabel _ _ _) = CodeLabel
labelType (PlainModuleInitLabel _ _) = CodeLabel
+labelType (LargeSRTLabel _) = DataLabel
+labelType (LargeBitmapLabel _) = DataLabel
labelType (IdLabel _ info) = idInfoLabelType info
labelType (DynIdLabel _ info) = idInfoLabelType info
case info of
InfoTable -> DataLabel
Closure -> DataLabel
- Bitmap -> DataLabel
ConInfoTable -> DataLabel
StaticInfoTable -> DataLabel
ClosureTable -> DataLabel
= hcat [pprUnique u, ptext SLIT("_dflt")]
pprCLbl (LargeSRTLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("srtd")
+pprCLbl (LargeBitmapLabel u) = pprUnique u <> pp_cSEP <> ptext SLIT("btm")
pprCLbl (RtsLabel (RtsCode str)) = ptext str
pprCLbl (RtsLabel (RtsData str)) = ptext str
Entry -> ptext SLIT("entry")
Slow -> ptext SLIT("slow")
RednCounts -> ptext SLIT("ct")
- Bitmap -> ptext SLIT("btm")
ConEntry -> ptext SLIT("con_entry")
ConInfoTable -> ptext SLIT("con_info")
StaticConEntry -> ptext SLIT("static_entry")
-----------------------------------------------------------------------------
module Cmm (
- GenCmm(..), Cmm,
- GenCmmTop(..), CmmTop,
+ GenCmm(..), Cmm, RawCmm,
+ GenCmmTop(..), CmmTop, RawCmmTop,
+ CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..),
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
CmmCallTarget(..),
CmmExpr(..), cmmExprRep,
CmmReg(..), cmmRegRep,
CmmLit(..), cmmLitRep,
- LocalReg(..), localRegRep, Kind(..),
+ LocalReg(..), localRegRep, localRegGCFollow, Kind(..),
BlockId(..), BlockEnv,
GlobalReg(..), globalRegRep,
import MachOp
import CLabel
import ForeignCall
+import SMRep
import ClosureInfo
import Unique
import UniqFM
-- (a) Plain C--, i.e. populated with CmmLit and CmmExpr respectively,
-- (b) Native code, populated with instructions
--
-newtype GenCmm d i = Cmm [GenCmmTop d i]
+newtype GenCmm d h i = Cmm [GenCmmTop d h i]
-type Cmm = GenCmm CmmStatic CmmStmt
+-- | Cmm with the info table as a data type
+type Cmm = GenCmm CmmStatic CmmInfo CmmStmt
+
+-- | Cmm with the info tables converted to a list of 'CmmStatic'
+type RawCmm = GenCmm CmmStatic [CmmStatic] CmmStmt
-- A top-level chunk, abstracted over the type of the contents of
-- the basic blocks (Cmm or instructions are the likely instantiations).
-data GenCmmTop d i
+data GenCmmTop d h i
= CmmProc
- [d] -- Info table, may be empty
+ h -- Extra header such as the info table
CLabel -- Used to generate both info & entry labels
CmmFormals -- Argument locals live on entry (C-- procedure params)
[GenBasicBlock i] -- Code, may be empty. The first block is
-- some static data.
| CmmData Section [d] -- constant values only
-type CmmTop = GenCmmTop CmmStatic CmmStmt
+type CmmTop = GenCmmTop CmmStatic CmmInfo CmmStmt
+type RawCmmTop = GenCmmTop CmmStatic [CmmStatic] CmmStmt
-- A basic block containing a single label, at the beginning.
-- The list of basic blocks in a top-level code block may be re-ordered.
blockStmts :: GenBasicBlock i -> [i]
blockStmts (BasicBlock _ stmts) = stmts
+-----------------------------------------------------------------------------
+-- Info Tables
+-----------------------------------------------------------------------------
+
+-- Info table as a haskell data type
+data CmmInfo
+ = CmmInfo
+ ProfilingInfo
+ (Maybe BlockId) -- GC target
+ ClosureTypeTag -- Int
+ ClosureTypeInfo
+ | CmmNonInfo -- Procedure doesn't need an info table
+
+data ClosureTypeInfo
+ = ConstrInfo ClosureLayout ConstrTag ConstrDescription
+ | FunInfo ClosureLayout C_SRT FunType FunArity ArgDescr SlowEntry
+ | ThunkInfo ClosureLayout C_SRT
+ | ContInfo
+ [Maybe LocalReg] -- Forced stack parameters
+ C_SRT
+
+-- TODO: These types may need refinement
+data ProfilingInfo = ProfilingInfo CmmLit CmmLit -- closure_type, closure_desc
+type ClosureTypeTag = StgHalfWord
+type ClosureLayout = (StgHalfWord, StgHalfWord) -- pts, nptrs
+type ConstrTag = StgHalfWord
+type ConstrDescription = CLabel
+type FunType = StgHalfWord
+type FunArity = StgHalfWord
+type SlowEntry = CLabel
-----------------------------------------------------------------------------
-- CmmStmt
brokenBlockTargets :: [BlockId],
-- ^ Blocks that this block could
- -- branch to one either by conditional
+ -- branch to either by conditional
-- branches or via the last statement
brokenBlockExit :: FinalStmt
-- | How a block could be entered
data BlockEntryInfo
= FunctionEntry -- ^ Block is the beginning of a function
+ CmmInfo -- ^ Function header info
CLabel -- ^ The function name
CmmFormals -- ^ Aguments to function
import CmmLint
import PprCmm
-import Dataflow
import CmmLive
import CmmBrokenBlock
import CmmProcPoint
import CmmCallConv
+import CmmInfo
+import CmmUtils
+import Bitmap
+import ClosureInfo
import MachOp
import ForeignCall
import CLabel
-- |Top level driver for the CPS pass
-----------------------------------------------------------------------------
cmmCPS :: DynFlags -- ^ Dynamic flags: -dcmm-lint -ddump-cps-cmm
- -> [Cmm] -- ^ Input C-- with Proceedures
- -> IO [Cmm] -- ^ Output CPS transformed C--
+ -> [GenCmm CmmStatic CmmInfo CmmStmt] -- ^ Input C-- with Proceedures
+ -> IO [GenCmm CmmStatic [CmmStatic] CmmStmt] -- ^ Output CPS transformed C--
cmmCPS dflags abstractC = do
when (dopt Opt_DoCmmLinting dflags) $
do showPass dflags "CmmLint"
-----------------------------------------------------------------------------
cpsProc :: UniqSupply
- -> CmmTop -- ^Input proceedure
- -> [CmmTop] -- ^Output proceedure and continuations
-cpsProc uniqSupply x@(CmmData _ _) = [x]
-cpsProc uniqSupply x@(CmmProc info_table ident params blocks) = cps_procs
+ -> GenCmmTop CmmStatic CmmInfo CmmStmt -- ^Input proceedure
+ -> [GenCmmTop CmmStatic [CmmStatic] CmmStmt] -- ^Output proceedure and continuations
+cpsProc uniqSupply (CmmData sec dat) = [CmmData sec dat]
+cpsProc uniqSupply (CmmProc info ident params blocks) = info_procs
where
- uniqes :: [[Unique]]
- uniqes = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
+ uniques :: [[Unique]]
+ uniques = map uniqsFromSupply $ listSplitUniqSupply uniqSupply
+ info_uniques:block_uniques = uniques
-- Break the block at each function call.
-- The part after the function call will have to become a continuation.
broken_blocks :: [BrokenBlock]
broken_blocks =
- concat $ zipWith3 breakBlock uniqes blocks
- (FunctionEntry ident params:repeat ControlEntry)
+ concat $ zipWith3 breakBlock block_uniques blocks
+ (FunctionEntry info ident params:repeat ControlEntry)
-- Calculate live variables for each broken block.
--
block_env = blocksToBlockEnv broken_blocks
-- Group the blocks into continuations based on the set of proc-points.
- continuations :: [Continuation]
+ continuations :: [Continuation (Either C_SRT CmmInfo)]
continuations = map (gatherBlocksIntoContinuation proc_points block_env)
(uniqSetToList proc_points)
-- Select the stack format on entry to each continuation.
+ -- Return the max stack offset and an association list
--
-- This is an association list instead of a UniqFM because
-- CLabel's don't have a 'Uniqueable' instance.
- formats :: [(CLabel, StackFormat)]
+ formats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
formats = selectStackFormat live continuations
+ -- Do a little meta-processing on the stack formats such as
+ -- getting the individual frame sizes and the maximum frame size
+ formats' :: (WordOff, [(CLabel, StackFormat)])
+ formats' = processFormats formats
+
+ -- TODO FIXME NOW: calculate a real max stack (including function call args)
+ -- TODO: from the maximum frame size get the maximum stack size.
+ -- The difference is due to the size taken by function calls.
+
+ -- Update the info table data on the continuations with
+ -- the selected stack formats.
+ continuations' :: [Continuation CmmInfo]
+ continuations' = map (applyStackFormat (snd formats')) continuations
+
-- Do the actual CPS transform.
cps_procs :: [CmmTop]
- cps_procs = map (continuationToProc formats) continuations
+ cps_procs = map (continuationToProc formats') continuations'
+
+ -- Convert the info tables from CmmInfo to [CmmStatic]
+ -- We might want to put this in another pass eventually
+ info_procs :: [RawCmmTop]
+ info_procs = concat (zipWith mkInfoTable info_uniques cps_procs)
--------------------------------------------------------------------------------
-- and heap memory (not sure if that's usefull at all though, but it may
-- be worth exploring the design space).
-continuationLabel (Continuation _ _ l _ _) = l
-data Continuation =
+continuationLabel (Continuation _ l _ _) = l
+data Continuation info =
Continuation
- Bool -- True => Function entry, False => Continuation/return point
- [CmmStatic] -- Info table, may be empty
+ info --(Either C_SRT CmmInfo) -- Left <=> Continuation created by the CPS
+ -- Right <=> Function or Proc point
CLabel -- Used to generate both info & entry labels
CmmFormals -- Argument locals live on entry (C-- procedure params)
- [BrokenBlock] -- Code, may be empty. The first block is
+ [BrokenBlock] -- Code, may be empty. The first block is
-- the entry point. The order is otherwise initially
-- unimportant, but at some point the code gen will
-- fix the order.
-- to a label. To jump to the first block in a Proc,
-- use the appropriate CLabel.
--- Describes the layout of a stack frame for a continuation
data StackFormat
= StackFormat {
stack_label :: Maybe CLabel, -- The label occupying the top slot
stack_frame_size :: WordOff, -- Total frame size in words (not including arguments)
- stack_live :: [(LocalReg, WordOff)] -- local reg offsets from stack top
- -- TODO: see if the above can be LocalReg
+ stack_live :: [Maybe LocalReg] -- local reg offsets from stack top
}
-- A block can be a continuation of a call
gatherBlocksIntoContinuation ::
UniqSet BlockId -> BlockEnv BrokenBlock
- -> BlockId -> Continuation
+ -> BlockId -> Continuation (Either C_SRT CmmInfo)
gatherBlocksIntoContinuation proc_points blocks start =
- Continuation is_entry info_table clabel params body
+ Continuation info_table clabel params body
where
children = (collectNonProcPointTargets proc_points blocks (unitUniqSet start) start) `delOneFromUniqSet` start
start_block = lookupWithDefaultUFM blocks (panic "TODO") start
children_blocks = map (lookupWithDefaultUFM blocks (panic "TODO")) (uniqSetToList children)
body = start_block : children_blocks
- info_table = [] -- TODO
+
+ -- We can't properly annotate the continuation's stack parameters
+ -- at this point because this is before stack selection
+ -- but we want to keep the C_SRT around so we use 'Either'.
+ info_table = case start_block_entry of
+ FunctionEntry info _ _ -> Right info
+ ContinuationEntry _ srt -> Left srt
+ ControlEntry -> Right CmmNonInfo
+
start_block_entry = brokenBlockEntry start_block
- is_entry = case start_block_entry of
- FunctionEntry _ _ -> True
- _ -> False
clabel = case start_block_entry of
- FunctionEntry label _ -> label
+ FunctionEntry _ label _ -> label
_ -> mkReturnPtLabel $ getUnique start
params = case start_block_entry of
- FunctionEntry _ args -> args
+ FunctionEntry _ _ args -> args
ContinuationEntry args _ -> args
ControlEntry -> [] -- TODO: it's a proc-point, we could pass lives in parameter registers
--------------------------------------------------------------------------------
-- For now just select the continuation orders in the order they are in the set with no gaps
-selectStackFormat :: BlockEnv CmmLive -> [Continuation] -> [(CLabel, StackFormat)]
+selectStackFormat :: BlockEnv CmmLive
+ -> [Continuation (Either C_SRT CmmInfo)]
+ -> [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
selectStackFormat live continuations =
map (\c -> (continuationLabel c, selectStackFormat' c)) continuations
where
- selectStackFormat' (Continuation True info_table label formals blocks) =
- StackFormat (Just label) 0 []
- selectStackFormat' (Continuation False info_table label formals blocks) =
+ selectStackFormat' (Continuation
+ (Right (CmmInfo _ _ _ (ContInfo format srt)))
+ label _ _) = (Just label, format)
+ selectStackFormat' (Continuation (Right _) _ _ _) = (Nothing, [])
+ selectStackFormat' (Continuation (Left srt) label _ 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 live_to_format label formals $ lookupWithDefaultUFM live unknown_block ident
+ in (Just label,
+ map Just $ uniqSetToList $
+ lookupWithDefaultUFM live unknown_block ident)
- live_to_format :: CLabel -> CmmFormals -> CmmLive -> StackFormat
- live_to_format label formals live =
- foldl extend_format
- (StackFormat (Just label) retAddrSizeW [])
- (uniqSetToList (live `minusUniqSet` mkUniqSet formals))
+ unknown_block = panic "unknown BlockId in selectStackFormat"
- extend_format :: StackFormat -> LocalReg -> StackFormat
- extend_format (StackFormat label size offsets) reg =
- StackFormat label (slot_size reg + size) ((reg, size) : offsets)
+processFormats :: [(CLabel, (Maybe CLabel, [Maybe LocalReg]))]
+ -> (WordOff, [(CLabel, StackFormat)])
+processFormats formats = (max_size, formats')
+ where
+ max_size = foldl max 0 (map (stack_frame_size . snd) formats')
+ formats' = map make_format formats
+ make_format (label, format) =
+ (label,
+ StackFormat {
+ stack_label = fst format,
+ stack_frame_size = stack_size (snd format) +
+ if isJust (fst format)
+ then label_size
+ else 0,
+ stack_live = snd format })
+
+ -- TODO: get rid of "+ 1" etc.
+ label_size = 1 :: WordOff
+
+ stack_size [] = 0
+ 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
+ -- TODO: it would be better if we had a machRepWordWidth
- slot_size :: LocalReg -> Int
- slot_size reg = ((machRepByteWidth (localRegRep reg) - 1) `div` wORD_SIZE) + 1
+-----------------------------------------------------------------------------
+applyStackFormat :: [(CLabel, StackFormat)]
+ -> Continuation (Either C_SRT CmmInfo)
+ -> Continuation CmmInfo
+
+-- User written continuations
+applyStackFormat formats (Continuation
+ (Right (CmmInfo prof gc tag (ContInfo _ srt)))
+ label formals blocks) =
+ Continuation (CmmInfo prof gc tag (ContInfo format srt))
+ label formals blocks
+ where
+ format = stack_live $ maybe unknown_block id $ lookup label formats
+ unknown_block = panic "unknown BlockId in applyStackFormat"
- unknown_block = panic "unknown BlockId in selectStackFormat"
+-- User written non-continuation code
+applyStackFormat formats (Continuation (Right info) label formals blocks) =
+ Continuation info label formals blocks
-continuationToProc :: [(CLabel, StackFormat)] -> Continuation -> CmmTop
-continuationToProc formats (Continuation is_entry info label formals blocks) =
- CmmProc info label formals (map (continuationToProc' label formats) blocks)
+-- CPS generated continuations
+applyStackFormat formats (Continuation (Left srt) label formals blocks) =
+ Continuation (CmmInfo prof gc tag (ContInfo (stack_live $ format) srt))
+ label formals blocks
where
- continuationToProc' :: CLabel -> [(CLabel, StackFormat)] -> BrokenBlock
- -> CmmBasicBlock
- continuationToProc' curr_ident formats (BrokenBlock ident entry stmts _ exit) =
+ gc = Nothing -- Generated continuations never need a stack check
+ -- TODO prof: this is the same as the current implementation
+ -- but I think it could be improved
+ prof = ProfilingInfo zeroCLit zeroCLit
+ tag = if stack_frame_size format > mAX_SMALL_BITMAP_SIZE
+ then rET_BIG
+ else rET_SMALL
+ format = maybe unknown_block id $ lookup label formats
+ unknown_block = panic "unknown BlockId in applyStackFormat"
+
+-----------------------------------------------------------------------------
+continuationToProc :: (WordOff, [(CLabel, StackFormat)])
+ -> Continuation CmmInfo
+ -> CmmTop
+continuationToProc (max_stack, formats)
+ (Continuation info label formals blocks) =
+ CmmProc info label formals (map continuationToProc' blocks)
+ where
+ curr_format = maybe unknown_block id $ lookup label formats
+ unknown_block = panic "unknown BlockId in continuationToProc"
+
+ continuationToProc' :: BrokenBlock -> CmmBasicBlock
+ continuationToProc' (BrokenBlock ident entry stmts _ exit) =
BasicBlock ident (prefix++stmts++postfix)
where
- curr_format = maybe unknown_block id $ lookup curr_ident formats
- unknown_block = panic "unknown BlockId in continuationToProc"
prefix = case entry of
ControlEntry -> []
- FunctionEntry _ formals -> -- TODO: gc_stack_check
+ FunctionEntry (CmmInfo _ (Just gc_block) _ _) _ formals ->
+ gc_stack_check gc_block max_stack ++
+ function_entry formals curr_format
+ FunctionEntry (CmmInfo _ Nothing _ _) _ formals ->
+ panic "continuationToProc: TODO generate GC block" ++
+ function_entry formals curr_format
+ FunctionEntry CmmNonInfo _ formals ->
+ panic "TODO: gc_stack_check gc_block max_stack" ++
function_entry formals curr_format
ContinuationEntry formals _ ->
function_entry formals curr_format
lookup (mkReturnPtLabel $ getUnique next) formats
FinalCall next _ results arguments -> panic "unimplemented CmmCall"
---------------------------------------------------------------------------------
+-----------------------------------------------------------------------------
-- Functions that generate CmmStmt sequences
-- for packing/unpacking continuations
-- and entering/exiting functions
argument_formats = assignArguments (cmmExprRep . fst) arguments
-gc_stack_check :: WordOff -> [CmmStmt]
-gc_stack_check max_frame_size
+gc_stack_check :: BlockId -> WordOff -> [CmmStmt]
+gc_stack_check gc_block max_frame_size
= check_stack_limit where
check_stack_limit = [
CmmCondBranch
(CmmMachOp (MO_U_Lt $ cmmRegRep spReg)
[CmmRegOff spReg max_frame_size, CmmReg spLimReg])
gc_block]
- gc_block = panic "gc_check not implemented" -- TODO: get stack and heap checks to go to same
-- TODO: fix branches to proc point (we have to insert a new block to marshel the continuation)
pack_continuation :: StackFormat -> StackFormat -> [CmmStmt]
pack_continuation (StackFormat curr_id curr_frame_size _)
- (StackFormat cont_id cont_frame_size cont_offsets)
+ (StackFormat cont_id cont_frame_size live_regs)
= store_live_values ++ set_stack_header where
- -- TODO: only save variables when actually needed (may be handled by latter pass)
+ -- TODO: only save variables when actually needed
+ -- (may be handled by latter pass)
store_live_values =
[stack_put spRel (CmmReg (CmmLocal reg)) offset
| (reg, offset) <- cont_offsets]
set_stack_header =
- if not needs_header
- then []
- else [stack_put spRel continuation_function 0]
+ if needs_header_set
+ then [stack_put spRel continuation_function 0]
+ else []
+
+ -- TODO: factor with function_entry and CmmInfo.hs(?)
+ cont_offsets = mkOffsets label_size live_regs
+
+ label_size = 1 :: WordOff
+
+ mkOffsets size [] = []
+ mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
+ mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
+ where
+ width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
+ -- TODO: it would be better if we had a machRepWordWidth
spRel = curr_frame_size - cont_frame_size
continuation_function = CmmLit $ CmmLabel $ fromJust cont_id
- needs_header =
+ needs_header_set =
case (curr_id, cont_id) of
(Just x, Just y) -> x /= y
_ -> isJust cont_id
-- have the same stack format (this causes a problem
-- only for proc-point).
function_entry :: CmmFormals -> StackFormat -> [CmmStmt]
-function_entry formals (StackFormat _ _ curr_offsets)
+function_entry formals (StackFormat _ _ live_regs)
= load_live_values ++ load_args where
- -- TODO: only save variables when actually needed (may be handled by latter pass)
+ -- TODO: only save variables when actually needed
+ -- (may be handled by latter pass)
load_live_values =
[stack_get 0 reg offset
| (reg, offset) <- curr_offsets]
argument_formats = assignArguments (localRegRep) formals
+ -- TODO: eliminate copy/paste with pack_continuation
+ curr_offsets = mkOffsets label_size live_regs
+
+ label_size = 1 :: WordOff
+
+ mkOffsets size [] = []
+ mkOffsets size (Nothing:regs) = mkOffsets (size+1) regs
+ mkOffsets size (Just reg:regs) = (reg, size):mkOffsets (size + width) regs
+ where
+ width = machRepByteWidth (localRegRep reg) `quot` wORD_SIZE
+ -- TODO: it would be better if we had a machRepWordWidth
+
-----------------------------------------------------------------------------
-- Section: Stack and argument register puts and gets
-----------------------------------------------------------------------------
-> WordOff
-> CmmStmt
stack_get spRel reg offset =
- CmmAssign (CmmLocal reg) (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset))) (localRegRep reg))
+ CmmAssign (CmmLocal reg)
+ (CmmLoad (CmmRegOff spReg (wORD_SIZE*(spRel + offset)))
+ (localRegRep reg))
global_put :: CmmExpr -> GlobalReg -> CmmStmt
global_put expr global = CmmAssign (CmmGlobal global) expr
global_get :: LocalReg -> GlobalReg -> CmmStmt
-- -----------------------------------------------------------------------------
-- Exported entry points:
-cmmLint :: Cmm -> Maybe SDoc
+cmmLint :: GenCmm d h CmmStmt -> Maybe SDoc
cmmLint (Cmm tops) = runCmmLint $ mapM_ lintCmmTop tops
-cmmLintTop :: CmmTop -> Maybe SDoc
+cmmLintTop :: GenCmmTop d h CmmStmt -> Maybe SDoc
cmmLintTop top = runCmmLint $ lintCmmTop top
runCmmLint :: CmmLint a -> Maybe SDoc
Left err -> Just (ptext SLIT("Cmm lint error:") $$ nest 2 err)
Right _ -> Nothing
-lintCmmTop (CmmProc _info lbl _args blocks)
+lintCmmTop (CmmProc _ lbl _ blocks)
= addLintInfo (text "in proc " <> pprCLabel lbl) $
mapM_ lintCmmBlock blocks
lintCmmTop _other
except factorial, but what the hell.
-}
-cmmLoopifyForC :: CmmTop -> CmmTop
+cmmLoopifyForC :: RawCmmTop -> RawCmmTop
cmmLoopifyForC p@(CmmProc info entry_lbl [] blocks@(BasicBlock top_id _ : _))
| null info = p -- only if there's an info table, ignore case alts
| otherwise =
| ',' expr lits { $2 : $3 }
cmmproc :: { ExtCode }
- : info maybe_formals '{' body '}'
- { do (info_lbl, info1, info2) <- $1;
- formals <- sequence $2;
- stmts <- getCgStmtsEC (loopDecls $4)
- blks <- code (cgStmtsToBlocks stmts)
- code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
-
- | info maybe_formals ';'
- { do (info_lbl, info1, info2) <- $1;
- formals <- sequence $2;
- code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
-
- | NAME maybe_formals '{' body '}'
+-- TODO: add real SRT/info tables to parsed Cmm
+-- : info maybe_formals '{' body '}'
+-- { do (info_lbl, info1, info2) <- $1;
+-- formals <- sequence $2;
+-- stmts <- getCgStmtsEC (loopDecls $4)
+-- blks <- code (cgStmtsToBlocks stmts)
+-- code (emitInfoTableAndCode info_lbl info1 info2 formals blks) }
+--
+-- | info maybe_formals ';'
+-- { do (info_lbl, info1, info2) <- $1;
+-- formals <- sequence $2;
+-- code (emitInfoTableAndCode info_lbl info1 info2 formals []) }
+
+ : NAME maybe_formals '{' body '}'
{ do formals <- sequence $2;
stmts <- getCgStmtsEC (loopDecls $4);
blks <- code (cgStmtsToBlocks stmts);
- code (emitProc [] (mkRtsCodeLabelFS $1) formals blks) }
+ code (emitProc CmmNonInfo (mkRtsCodeLabelFS $1) formals blks) }
info :: { ExtFCode (CLabel, [CmmLit],[CmmLit]) }
: 'INFO_TABLE' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
| NAME ':'
{ do l <- newLabel $1; code (labelC l) }
--- HACK: this should just be lregs but that causes a shift/reduce conflict
--- with foreign calls
--- | hint_lregs '=' expr ';'
--- { do reg <- head $1; e <- $3; stmtEC (CmmAssign (fst reg) e) }
+ | lreg '=' expr ';'
+ { do reg <- $1; e <- $3; stmtEC (CmmAssign reg e) }
| type '[' expr ']' '=' expr ';'
{ doStore $1 $3 $6 }
--- TODO: add real SRT to parsed Cmm
+
+ -- Gah! We really want to say "maybe_results" but that causes
+ -- a shift/reduce conflict with assignment. We either
+ -- we expand out the no-result and single result cases or
+ -- we tweak the syntax to avoid the conflict. The later
+ -- option is taken here because the other way would require
+ -- multiple levels of expanding and get unwieldy.
| maybe_results 'foreign' STRING expr '(' hint_exprs0 ')' vols ';'
{% foreignCall $3 $1 $4 $6 $8 NoC_SRT }
| maybe_results 'prim' '%' NAME '(' hint_exprs0 ')' vols ';'
maybe_results :: { [ExtFCode (CmmFormal, MachHint)] }
: {- empty -} { [] }
- | hint_lregs '=' { $1 }
-
-hint_lregs0 :: { [ExtFCode (CmmFormal, MachHint)] }
- : {- empty -} { [] }
- | hint_lregs { $1 }
+ | '(' hint_lregs ')' '=' { $2 }
hint_lregs :: { [ExtFCode (CmmFormal, MachHint)] }
- : hint_lreg ',' { [$1] }
- | hint_lreg { [$1] }
+ : hint_lreg { [$1] }
+ | hint_lreg ',' { [$1] }
| hint_lreg ',' hint_lregs { $1 : $3 }
hint_lreg :: { ExtFCode (CmmFormal, MachHint) }
map brokenBlockId $
filter always_proc_point blocks
always_proc_point BrokenBlock {
- brokenBlockEntry = FunctionEntry _ _ } = True
+ brokenBlockEntry = FunctionEntry _ _ _ } = True
always_proc_point BrokenBlock {
brokenBlockEntry = ContinuationEntry _ _ } = True
always_proc_point _ = False
-- --------------------------------------------------------------------------
-- Top level
-pprCs :: DynFlags -> [Cmm] -> SDoc
+pprCs :: DynFlags -> [RawCmm] -> SDoc
pprCs dflags cmms
= pprCode CStyle (vcat $ map (\c -> split_marker $$ pprC c) cmms)
where
| dopt Opt_SplitObjs dflags = ptext SLIT("__STG_SPLIT_MARKER")
| otherwise = empty
-writeCs :: DynFlags -> Handle -> [Cmm] -> IO ()
+writeCs :: DynFlags -> Handle -> [RawCmm] -> IO ()
writeCs dflags handle cmms
= printForC handle (pprCs dflags cmms)
-- for fun, we could call cmmToCmm over the tops...
--
-pprC :: Cmm -> SDoc
+pprC :: RawCmm -> SDoc
pprC (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
--
-- top level procs
--
-pprTop :: CmmTop -> SDoc
+pprTop :: RawCmmTop -> SDoc
pprTop (CmmProc info clbl _params blocks) =
(if not (null info)
then pprDataExterns info $$
import System.IO
import Data.Maybe
-pprCmms :: [Cmm] -> SDoc
+pprCmms :: (Outputable info) => [GenCmm CmmStatic info CmmStmt] -> SDoc
pprCmms cmms = pprCode CStyle (vcat (intersperse separator $ map ppr cmms))
where
separator = space $$ ptext SLIT("-------------------") $$ space
-----------------------------------------------------------------------------
-instance Outputable Cmm where
+instance (Outputable info) => Outputable (GenCmm CmmStatic info CmmStmt) where
ppr c = pprCmm c
-instance Outputable CmmTop where
+instance (Outputable info) => Outputable (GenCmmTop CmmStatic info CmmStmt) where
ppr t = pprTop t
instance Outputable CmmBasicBlock where
instance Outputable GlobalReg where
ppr e = pprGlobalReg e
+instance Outputable CmmStatic where
+ ppr e = pprStatic e
+
+instance Outputable CmmInfo where
+ ppr e = pprInfo e
+
-----------------------------------------------------------------------------
-pprCmm :: Cmm -> SDoc
+pprCmm :: (Outputable info) => GenCmm CmmStatic info CmmStmt -> SDoc
pprCmm (Cmm tops) = vcat $ intersperse (text "") $ map pprTop tops
-- --------------------------------------------------------------------------
--- Top level `procedure' blocks. The info tables, if not null, are
--- printed in the style of C--'s 'stackdata' declaration, just inside
--- the proc body, and are labelled with the procedure name ++ "_info".
+-- Top level `procedure' blocks.
--
-pprTop :: CmmTop -> SDoc
+pprTop :: (Outputable info) => GenCmmTop CmmStatic info CmmStmt -> SDoc
pprTop (CmmProc info lbl params blocks )
= vcat [ pprCLabel lbl <> parens (commafy $ map ppr params) <+> lbrace
- , nest 8 $ pprInfo info lbl
+ , nest 8 $ lbrace <+> ppr info $$ rbrace
, nest 4 $ vcat (map ppr blocks)
, rbrace ]
- where
- pprInfo [] _ = empty
- pprInfo i label =
- (hang (pprCLabel (entryLblToInfoLbl label) <+> lbrace )
- 4 $ vcat (map pprStatic i))
- $$ rbrace
-
-- --------------------------------------------------------------------------
-- We follow [1], 4.5
--
$$ rbrace
+
+-- --------------------------------------------------------------------------
+-- Info tables. The current pretty printer needs refinement
+-- but will work for now.
+--
+-- For ideas on how to refine it, they used to be printed in the
+-- style of C--'s 'stackdata' declaration, just inside the proc body,
+-- and were labelled with the procedure name ++ "_info".
+pprInfo CmmNonInfo = empty
+pprInfo (CmmInfo (ProfilingInfo closure_type closure_desc)
+ gc_target tag info) =
+ vcat [ptext SLIT("type: ") <> pprLit closure_type,
+ ptext SLIT("desc: ") <> pprLit closure_desc,
+ ptext SLIT("gc_target: ") <>
+ maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+ ptext SLIT("tag: ") <> integer (toInteger tag),
+ pprTypeInfo info]
+
+pprTypeInfo (ConstrInfo layout constr descr) =
+ vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
+ ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
+ ptext SLIT("constructor: ") <> integer (toInteger constr),
+ ppr descr]
+pprTypeInfo (FunInfo layout srt fun_type arity args slow_entry) =
+ vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
+ ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
+ ptext SLIT("srt: ") <> ppr srt,
+ ptext SLIT("fun_type: ") <> integer (toInteger fun_type),
+ ptext SLIT("arity: ") <> integer (toInteger arity)
+ --ppr args, -- TODO: needs to be printed
+ --ppr slow_entry -- TODO: needs to be printed
+ ]
+pprTypeInfo (ThunkInfo layout srt) =
+ vcat [ptext SLIT("ptrs: ") <> integer (toInteger (fst layout)),
+ ptext SLIT("nptrs: ") <> integer (toInteger (snd layout)),
+ ptext SLIT("srt: ") <> ppr srt]
+pprTypeInfo (ContInfo stack srt) =
+ vcat [ptext SLIT("stack: ") <> ppr stack,
+ ptext SLIT("srt: ") <> ppr srt]
+
-- --------------------------------------------------------------------------
-- Basic blocks look like assembly blocks.
-- lbl: stmt ; stmt ; ..
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
CmmCall (CmmForeignCall fn cconv) results args srt ->
- hcat [ ptext SLIT("call"), space,
+ hcat [ if null results
+ then empty
+ else parens (commafy $ map ppr results) <>
+ ptext SLIT(" = "),
+ ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
- (if null results
- then empty
- else brackets( commafy $ map ppr results)),
brackets (ppr srt), semi ]
where
target (CmmLit lit) = pprLit lit
import StaticFlags
import FastString
import Outputable
+import Unique
import Data.Bits
mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
mkLiveness name size bits
| size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
- = do { let lbl = mkBitmapLabel name
+ = do { let lbl = mkBitmapLabel (getUnique name)
; emitRODataLits lbl ( mkWordCLit (fromIntegral size)
: map mkWordCLit bits)
; return (BigLiveness lbl) }
import Maybes
import Constants
+import Panic
-------------------------------------------------------------------------
--
return (makeRelativeRefTo info_lbl cstr)
else return (mkIntCLit 0)
- ; emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
+ ; panic "emitClosureCodeAndInfoTable" } --emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
where
info_lbl = infoTableLabelFromCI cl_info
mkRetInfoTable info_lbl liveness srt_info cl_type
; blks <- cgStmtsToBlocks stmts
- ; emitInfoTableAndCode info_lbl std_info extra_bits args blks
+ ; panic "emitReturnTarget" --emitInfoTableAndCode info_lbl std_info extra_bits args blks
; return info_lbl }
where
args = {- trace "emitReturnTarget: missing args" -} []
:: CLabel -- info label
-> Liveness -- liveness
-> C_SRT -- SRT Info
- -> Int -- type (eg. rET_SMALL)
+ -> StgHalfWord -- type (eg. rET_SMALL)
-> ([CmmLit],[CmmLit])
mkRetInfoTable info_lbl liveness srt_info cl_type
= (std_info, srt_slot)
mkStdInfoTable
:: CmmLit -- closure type descr (profiling)
-> CmmLit -- closure descr (profiling)
- -> Int -- closure type
+ -> StgHalfWord -- closure type
-> StgHalfWord -- SRT length
-> CmmLit -- layout field
-> [CmmLit]
emitInfoTableAndCode
:: CLabel -- Label of info table
+ -> CmmInfo -- ...the info table
+ -> CmmFormals -- ...args
+ -> [CmmBasicBlock] -- ...and body
+ -> Code
+
+emitInfoTableAndCode info_lbl info args blocks
+ = emitProc info entry_lbl args blocks
+ where
+ entry_lbl = infoLblToEntryLbl info_lbl
+
+{-
+emitInfoTableAndCode
+ :: CLabel -- Label of info table
-> [CmmLit] -- ...its invariant part
-> [CmmLit] -- ...and its variant part
-> CmmFormals -- ...args
where
entry_lbl = infoLblToEntryLbl info_lbl
+-}
-------------------------------------------------------------------------
--
where
data_block = CmmData sect lits
-emitProc :: [CmmLit] -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
-emitProc lits lbl args blocks
- = do { let proc_block = CmmProc (map CmmStaticLit lits) lbl args blocks
+emitProc :: CmmInfo -> CLabel -> CmmFormals -> [CmmBasicBlock] -> Code
+emitProc info lbl args blocks
+ = do { let proc_block = CmmProc info lbl args blocks
; state <- getState
; setState $ state { cgs_tops = cgs_tops state `snocOL` proc_block } }
emitSimpleProc lbl code
= do { stmts <- getCgStmts code
; blks <- cgStmtsToBlocks stmts
- ; emitProc [] lbl [] blks }
+ ; emitProc CmmNonInfo lbl [] blks }
getCmm :: Code -> FCode Cmm
-- Get all the CmmTops (there should be no stmts)
module CgUtils (
addIdReps,
cgLit,
- emitDataLits, emitRODataLits, emitIf, emitIfThenElse,
+ emitDataLits, mkDataLits,
+ emitRODataLits, mkRODataLits,
+ emitIf, emitIfThenElse,
emitRtsCall, emitRtsCallWithVols, emitRtsCallWithResult,
assignNonPtrTemp, newNonPtrTemp,
assignPtrTemp, newPtrTemp,
emitDataLits lbl lits
= emitData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+mkDataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+-- Emit a data-segment data block
+mkDataLits lbl lits
+ = CmmData Data (CmmDataLabel lbl : map CmmStaticLit lits)
+
emitRODataLits :: CLabel -> [CmmLit] -> Code
-- Emit a read-only data block
emitRODataLits lbl lits
needsRelocation (CmmLabelOff _ _) = True
needsRelocation _ = False
+mkRODataLits :: CLabel -> [CmmLit] -> GenCmmTop CmmStatic info stmt
+mkRODataLits lbl lits
+ = CmmData section (CmmDataLabel lbl : map CmmStaticLit lits)
+ where section | any needsRelocation lits = RelocatableReadOnlyData
+ | otherwise = ReadOnlyData
+ needsRelocation (CmmLabel _) = True
+ needsRelocation (CmmLabelOff _ _) = True
+ needsRelocation _ = False
+
mkStringCLit :: String -> FCode CmmLit
-- Make a global definition for the string,
-- and return its label
smRepClosureType (GenericRep _ _ _ ty) = Just ty
smRepClosureType BlackHoleRep = Nothing
-smRepClosureTypeInt :: SMRep -> Int
+smRepClosureTypeInt :: SMRep -> StgHalfWord
smRepClosureTypeInt (GenericRep False 1 0 Constr) = CONSTR_1_0
smRepClosureTypeInt (GenericRep False 0 1 Constr) = CONSTR_0_1
smRepClosureTypeInt (GenericRep False 2 0 Constr) = CONSTR_2_0
-- We export these ones
-rET_SMALL = (RET_SMALL :: Int)
-rET_BIG = (RET_BIG :: Int)
+rET_SMALL = (RET_SMALL :: StgHalfWord)
+rET_BIG = (RET_BIG :: StgHalfWord)
\end{code}
import PackageConfig ( rtsPackageId )
import Util
import FastString ( unpackFS )
-import Cmm ( Cmm )
+import Cmm ( RawCmm )
import HscTypes
import DynFlags
-> ModLocation
-> ForeignStubs
-> [PackageId]
- -> [Cmm] -- Compiled C--
+ -> [RawCmm] -- Compiled C--
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
codeOutput dflags this_mod location foreign_stubs pkg_deps flat_abstractC
foreign_stubs dir_imps cost_centre_info
stg_binds hpc_info
------------------ Convert to CPS --------------------
- continuationC <- cmmCPS dflags abstractC
+ continuationC <- {-return abstractC-} cmmCPS dflags abstractC
------------------ Code output -----------------------
(stub_h_exists,stub_c_exists)
<- codeOutput dflags this_mod location foreign_stubs
case maybe_cmm of
Nothing -> return False
Just cmm -> do
- continuationC <- cmmCPS dflags [cmm]
+ continuationC <- {-return [cmm]-} cmmCPS dflags [cmm]
codeOutput dflags no_mod no_loc NoStubs [] continuationC
return True
where
-- NB. We *lazilly* compile each block of code for space reasons.
-nativeCodeGen :: DynFlags -> [Cmm] -> UniqSupply -> IO Pretty.Doc
+nativeCodeGen :: DynFlags -> [RawCmm] -> UniqSupply -> IO Pretty.Doc
nativeCodeGen dflags cmms us
= let (res, _) = initUs us $
cgCmm (concat (map add_split cmms))
- cgCmm :: [CmmTop] -> UniqSM (Cmm, Pretty.Doc, [CLabel])
+ cgCmm :: [RawCmmTop] -> UniqSM (RawCmm, Pretty.Doc, [CLabel])
cgCmm tops =
lazyMapUs (cmmNativeGen dflags) tops `thenUs` \ results ->
case unzip3 results of { (cmms,docs,imps) ->
-- Complete native code generation phase for a single top-level chunk
-- of Cmm.
-cmmNativeGen :: DynFlags -> CmmTop -> UniqSM (CmmTop, Pretty.Doc, [CLabel])
+cmmNativeGen :: DynFlags -> RawCmmTop -> UniqSM (RawCmmTop, Pretty.Doc, [CLabel])
cmmNativeGen dflags cmm
= {-# SCC "fixAssigns" #-}
fixAssignsTop cmm `thenUs` \ fixed_cmm ->
-- Switching between the two monads whilst carrying along the same
-- Unique supply breaks abstraction. Is that bad?
-genMachCode :: CmmTop -> UniqSM ([NatCmmTop], [CLabel])
+genMachCode :: RawCmmTop -> UniqSM ([NatCmmTop], [CLabel])
genMachCode cmm_top
= do { initial_us <- getUs
-- the generic optimiser below, to avoid having two separate passes
-- over the Cmm.
-fixAssignsTop :: CmmTop -> UniqSM CmmTop
+fixAssignsTop :: RawCmmTop -> UniqSM RawCmmTop
fixAssignsTop top@(CmmData _ _) = returnUs top
fixAssignsTop (CmmProc info lbl params blocks) =
mapUs fixAssignsBlock blocks `thenUs` \ blocks' ->
temp assignments, and certain assigns to mem...)
-}
-cmmToCmm :: CmmTop -> (CmmTop, [CLabel])
+cmmToCmm :: RawCmmTop -> (RawCmmTop, [CLabel])
cmmToCmm top@(CmmData _ _) = (top, [])
cmmToCmm (CmmProc info lbl params blocks) = runCmmOpt $ do
blocks' <- mapM cmmBlockConFold (cmmMiniInline blocks)
type InstrBlock = OrdList Instr
-cmmTopCodeGen :: CmmTop -> NatM [NatCmmTop]
+cmmTopCodeGen :: RawCmmTop -> NatM [NatCmmTop]
cmmTopCodeGen (CmmProc info lab params blocks) = do
(nat_blocks,statics) <- mapAndUnzipM basicBlockCodeGen blocks
picBaseMb <- getPicBaseMaybeNat
-- Our flavours of the Cmm types
-- Type synonyms for Cmm populated with native code
-type NatCmm = GenCmm CmmStatic Instr
-type NatCmmTop = GenCmmTop CmmStatic Instr
+type NatCmm = GenCmm CmmStatic [CmmStatic] Instr
+type NatCmmTop = GenCmmTop CmmStatic [CmmStatic] Instr
type NatBasicBlock = GenBasicBlock Instr
-- -----------------------------------------------------------------------------