externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel HpcModuleNameLabel = False
+externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (LargeSRTLabel _) = False
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
= 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 (LargeBitmapLabel u) = text "b" <> pprUnique u <> pp_cSEP <> ptext SLIT("btm")
+-- Some bitsmaps for tuple constructors have a numeric tag (e.g. '7')
+-- until that gets resolved we'll just force them to start
+-- with a letter so the label will be legal assmbly code.
+
pprCLbl (RtsLabel (RtsCode str)) = ptext str
pprCLbl (RtsLabel (RtsData str)) = ptext str
module Cmm (
GenCmm(..), Cmm, RawCmm,
GenCmmTop(..), CmmTop, RawCmmTop,
- CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..),
+ CmmInfo(..), ClosureTypeInfo(..), ProfilingInfo(..), ClosureTypeTag,
GenBasicBlock(..), CmmBasicBlock, blockId, blockStmts,
CmmStmt(..), CmmActuals, CmmFormal, CmmFormals, CmmHintFormals,
+ CmmSafety(..),
CmmCallTarget(..),
CmmStatic(..), Section(..),
CmmExpr(..), cmmExprRep,
-- 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 ClosureLayout = (StgHalfWord, StgHalfWord) -- ptrs, nptrs
type ConstrTag = StgHalfWord
type ConstrDescription = CmmLit
type FunType = StgHalfWord
type FunArity = StgHalfWord
-type SlowEntry = CLabel
+type SlowEntry = CmmLit
+ -- ^We would like this to be a CLabel but
+ -- for now the parser sets this to zero on an INFO_TABLE_FUN.
type SelectorOffset = StgWord
-----------------------------------------------------------------------------
CmmCallTarget
CmmHintFormals -- zero or more results
CmmActuals -- zero or more arguments
- C_SRT -- SRT for the continuation of the call
+ CmmSafety -- whether to build a continuation
| CmmBranch BlockId -- branch to another BB in this fn
type CmmFormal = LocalReg
type CmmHintFormals = [(CmmFormal,MachHint)]
type CmmFormals = [CmmFormal]
+data CmmSafety = CmmUnsafe | CmmSafe C_SRT
{-
Discussion
return continuationC
stg_gc_gen = mkRtsApFastLabel SLIT("gen_cg_TODO") --panic "Need the label for gc"
-make_gc_block block_id fun_label formals srt = BasicBlock block_id stmts
+make_gc_block block_id fun_label formals safety = BasicBlock block_id stmts
where
- stmts = [CmmCall stg_gc_gen_target [] [] srt,
+ stmts = [CmmCall stg_gc_gen_target [] [] safety,
CmmJump fun_expr actuals]
stg_gc_gen_target =
CmmForeignCall (CmmLit (CmmLabel stg_gc_gen)) CmmCallConv
CmmInfo _ (Just _) _ _ -> (old_info, [])
CmmNonInfo Nothing
-> (CmmNonInfo (Just block_id),
- [make_gc_block block_id fun_label formals NoC_SRT])
+ [make_gc_block block_id fun_label formals (CmmSafe NoC_SRT)])
CmmInfo prof Nothing type_tag type_info
-> (CmmInfo prof (Just block_id) type_tag type_info,
- [make_gc_block block_id fun_label formals srt])
+ [make_gc_block block_id fun_label formals (CmmSafe srt)])
where
srt = case type_info of
ConstrInfo _ _ _ -> NoC_SRT
-- 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
+ tag = rET_SMALL -- cmmToRawCmm will convert this to rET_BIG if needed
format = maybe unknown_block id $ lookup label formats
unknown_block = panic "unknown BlockId in applyStackFormat"
module CmmInfo (
+ cmmToRawCmm,
mkInfoTable
) where
import Cmm
import CmmUtils
+import PprCmm
import CLabel
+import MachOp
import Bitmap
import ClosureInfo
import CgInfoTbls
import CgCallConv
import CgUtils
+import SMRep
import Constants
import StaticFlags
+import DynFlags
import Unique
+import UniqSupply
import Panic
import Data.Bits
+cmmToRawCmm :: [Cmm] -> IO [RawCmm]
+cmmToRawCmm cmm = do
+ info_tbl_uniques <- mkSplitUniqSupply 'i'
+ return $ zipWith raw_cmm (listSplitUniqSupply info_tbl_uniques) cmm
+ where
+ raw_cmm uniq_supply (Cmm procs) =
+ Cmm $ concat $ zipWith mkInfoTable (uniqsFromSupply uniq_supply) procs
+
+-- Make a concrete info table, represented as a list of CmmStatic
+-- (it can't be simply a list of Word, because the SRT field is
+-- represented by a label+offset expression).
+--
+-- With tablesNextToCode, the layout is
+-- <reversed variable part>
+-- <normal forward StgInfoTable, but without
+-- an entry point at the front>
+-- <code>
+--
+-- Without tablesNextToCode, the layout of an info table is
+-- <entry label>
+-- <normal forward rest of StgInfoTable>
+-- <forward variable part>
+--
+-- See includes/InfoTables.h
+--
+-- For return-points these are as follows
+--
+-- Tables next to code:
+--
+-- <srt slot>
+-- <standard info table>
+-- ret-addr --> <entry code (if any)>
+--
+-- Not tables-next-to-code:
+--
+-- ret-addr --> <ptr to entry code>
+-- <standard info table>
+-- <srt slot>
+--
+-- * The SRT slot is only there if there is SRT info to record
+
mkInfoTable :: Unique -> CmmTop -> [RawCmmTop]
mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat]
mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
case info of
+ -- | Code without an info table. Easy.
CmmNonInfo _ -> [CmmProc [] entry_label arguments blocks]
+
+ -- | A function entry point.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
- (FunInfo (ptrs, nptrs) srt fun_type fun_arity pap_bitmap slow_entry) ->
- mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks
+ (FunInfo (ptrs, nptrs) srt fun_type fun_arity
+ pap_bitmap slow_entry) ->
+ mkInfoTableAndCode info_label std_info fun_extra_bits entry_label
+ arguments blocks
where
fun_extra_bits =
[packHalfWordsCLit fun_type fun_arity] ++
case pap_bitmap of
ArgGen liveness ->
[makeRelativeRefTo info_label $ mkLivenessCLit liveness,
- makeRelativeRefTo info_label (CmmLabel slow_entry)]
+ makeRelativeRefTo info_label slow_entry]
_ -> []
std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
info_label = entryLblToInfoLbl entry_label
- (srt_label, srt_bitmap) =
- case srt of
- NoC_SRT -> ([], 0)
- (C_SRT lbl off bitmap) ->
- ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
- bitmap)
+ (srt_label, srt_bitmap) = mkSRTLit info_label srt
layout = packHalfWordsCLit ptrs nptrs
+ -- | A constructor.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ConstrInfo (ptrs, nptrs) con_tag descr) ->
- mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks
+ mkInfoTableAndCode info_label std_info [con_name] entry_label
+ arguments blocks
where
std_info = mkStdInfoTable ty_prof cl_prof type_tag con_tag layout
info_label = entryLblToInfoLbl entry_label
con_name = makeRelativeRefTo info_label descr
layout = packHalfWordsCLit ptrs nptrs
+ -- | A thunk.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ThunkInfo (ptrs, nptrs) srt) ->
- mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+ mkInfoTableAndCode info_label std_info srt_label entry_label
+ arguments blocks
where
std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout
info_label = entryLblToInfoLbl entry_label
- (srt_label, srt_bitmap) =
- case srt of
- NoC_SRT -> ([], 0)
- (C_SRT lbl off bitmap) ->
- ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
- bitmap)
+ (srt_label, srt_bitmap) = mkSRTLit info_label srt
layout = packHalfWordsCLit ptrs nptrs
+ -- | A selector thunk.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag
(ThunkSelectorInfo offset srt) ->
- mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+ mkInfoTableAndCode info_label std_info srt_label entry_label
+ arguments blocks
where
std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap (mkWordCLit offset)
info_label = entryLblToInfoLbl entry_label
- (srt_label, srt_bitmap) =
- case srt of
- NoC_SRT -> ([], 0)
- (C_SRT lbl off bitmap) ->
- ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
- bitmap)
+ (srt_label, srt_bitmap) = mkSRTLit info_label srt
+ -- A continuation/return-point.
CmmInfo (ProfilingInfo ty_prof cl_prof) _ type_tag (ContInfo stack_layout srt) ->
liveness_data ++
- mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks
+ mkInfoTableAndCode info_label std_info srt_label entry_label
+ arguments blocks
where
- std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap liveness_lit
+ std_info = mkStdInfoTable ty_prof cl_prof maybe_big_type_tag srt_bitmap
+ (makeRelativeRefTo info_label liveness_lit)
info_label = entryLblToInfoLbl entry_label
- (liveness_lit, liveness_data) = mkLiveness uniq stack_layout
- (srt_label, srt_bitmap) =
- case srt of
- NoC_SRT -> ([], 0)
- (C_SRT lbl off bitmap) ->
- ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)],
- bitmap)
+ (liveness_lit, liveness_data, liveness_tag) =
+ mkLiveness uniq stack_layout
+ maybe_big_type_tag = if type_tag == rET_SMALL
+ then liveness_tag
+ else type_tag
+ (srt_label, srt_bitmap) = mkSRTLit info_label srt
+-- Handle the differences between tables-next-to-code
+-- and not tables-next-to-code
+mkInfoTableAndCode :: CLabel
+ -> [CmmLit]
+ -> [CmmLit]
+ -> CLabel
+ -> CmmFormals
+ -> [CmmBasicBlock]
+ -> [RawCmmTop]
mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
| tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
- = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info)) entry_lbl args blocks]
+ = [CmmProc (map CmmStaticLit (reverse extra_bits ++ std_info))
+ entry_lbl args blocks]
| null blocks -- No actual code; only the info table is significant
= -- Use a zero place-holder in place of the
[mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits),
CmmProc [] entry_lbl args blocks]
+mkSRTLit :: CLabel
+ -> C_SRT
+ -> ([CmmLit], -- srt_label
+ StgHalfWord) -- srt_bitmap
+mkSRTLit info_label NoC_SRT = ([], 0)
+mkSRTLit info_label (C_SRT lbl off bitmap) =
+ ([makeRelativeRefTo info_label (cmmLabelOffW lbl off)], bitmap)
+
+-------------------------------------------------------------------------
+--
+-- Build a liveness mask for the stack layout
+--
+-------------------------------------------------------------------------
+
+-- There are four kinds of things on the stack:
+--
+-- - pointer variables (bound in the environment)
+-- - non-pointer variables (bound in the environment)
+-- - free slots (recorded in the stack free list)
+-- - non-pointer data slots (recorded in the stack free list)
+--
+-- The first two are represented with a 'Just' of a 'LocalReg'.
+-- The last two with one or more 'Nothing' constructors.
+-- Each 'Nothing' represents one used word.
+--
+-- The head of the stack layout is the top of the stack and
+-- the least-significant bit.
+
-- TODO: refactor to use utility functions
-mkLiveness :: Unique -> [Maybe LocalReg] -> (CmmLit, [GenCmmTop CmmStatic [CmmStatic] CmmStmt])
-mkLiveness uniq live
- = if length live > mAX_SMALL_BITMAP_SIZE
- then (CmmLabel big_liveness, [data_lits]) -- does not fit in one word
- else (mkWordCLit small_liveness, []) -- fits in one word
+-- TODO: combine with CgCallConv.mkLiveness (see comment there)
+mkLiveness :: Unique
+ -> [Maybe LocalReg]
+ -> (CmmLit, -- ^ The bitmap (literal value or label)
+ [RawCmmTop], -- ^ Large bitmap CmmData if needed
+ ClosureTypeTag) -- ^ rET_SMALL or rET_BIG
+mkLiveness uniq live =
+ if length bits > mAX_SMALL_BITMAP_SIZE
+ -- does not fit in one word
+ then (CmmLabel big_liveness, [data_lits], rET_BIG)
+ -- fits in one word
+ else (mkWordCLit small_liveness, [], rET_SMALL)
where
- size = length live
+ mkBits [] = []
+ mkBits (reg:regs) = take sizeW bits ++ mkBits regs where
+ sizeW = case reg of
+ Nothing -> 1
+ Just r -> machRepByteWidth (localRegRep r) `quot` wORD_SIZE
+ bits = repeat $ is_non_ptr reg -- True <=> Non Ptr
- bits = mkBitmap (map is_non_ptr live)
is_non_ptr Nothing = True
- is_non_ptr (Just reg) | localRegGCFollow reg == KindNonPtr = True
- is_non_ptr (Just reg) | localRegGCFollow reg == KindPtr = False
+ is_non_ptr (Just reg) =
+ case localRegGCFollow reg of
+ KindNonPtr -> True
+ KindPtr -> False
- big_liveness = mkBitmapLabel uniq
- data_lits = mkRODataLits big_liveness lits
- lits = mkWordCLit (fromIntegral size) : map mkWordCLit bits
-
- small_liveness =
- fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)
- small_bits = case bits of
+ bits :: [Bool]
+ bits = mkBits live
+
+ bitmap :: Bitmap
+ bitmap = mkBitmap bits
+
+ small_bitmap = case bitmap of
[] -> 0
[b] -> fromIntegral b
_ -> panic "mkLiveness"
+ small_liveness =
+ fromIntegral (length bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT)
+
+ big_liveness = mkBitmapLabel uniq
+ lits = mkWordCLit (fromIntegral (length bits)) : map mkWordCLit bitmap
+ data_lits = mkRODataLits big_liveness lits
+
+-------------------------------------------------------------------------
+--
+-- Generating a standard info table
+--
+-------------------------------------------------------------------------
+
+-- The standard bits of an info table. This part of the info table
+-- corresponds to the StgInfoTable type defined in InfoTables.h.
+--
+-- Its shape varies with ticky/profiling/tables next to code etc
+-- so we can't use constant offsets from Constants
+
+mkStdInfoTable
+ :: CmmLit -- closure type descr (profiling)
+ -> CmmLit -- closure descr (profiling)
+ -> StgHalfWord -- closure type
+ -> StgHalfWord -- SRT length
+ -> CmmLit -- layout field
+ -> [CmmLit]
+
+mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
+ = -- Parallel revertible-black hole field
+ prof_info
+ -- Ticky info (none at present)
+ -- Debug info (none at present)
+ ++ [layout_lit, type_lit]
+
+ where
+ prof_info
+ | opt_SccProfilingOn = [type_descr, closure_descr]
+ | otherwise = []
+
+ type_lit = packHalfWordsCLit cl_type srt_len
{ do prof <- profilingInfo $11 $13
return (mkRtsInfoLabelFS $3,
CmmInfo prof Nothing (fromIntegral $9)
- (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0 (panic "INFO_TABLE_FUN:ArgDesr") (panic "INFO_TABLE_FUN:SlowEntry"))) }
+ (FunInfo (fromIntegral $5, fromIntegral $7) NoC_SRT (fromIntegral $15) 0
+ (ArgSpec 0)
+ zeroCLit)) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
CmmInfo (ProfilingInfo zeroCLit zeroCLit) Nothing (fromIntegral $5)
(ContInfo [] NoC_SRT)) }
- | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals ')'
+ | 'INFO_TABLE_RET' '(' NAME ',' INT ',' formals0 ')'
-- closure type, live regs
{ do live <- sequence (map (liftM Just) $7)
return (mkRtsInfoLabelFS $3,
stmts <- getCgStmtsEC ec
code (forkCgStmts stmts)
-retInfo name size live_bits cl_type = do
- let liveness = smallLiveness (fromIntegral size) (fromIntegral live_bits)
- info_lbl = mkRtsRetInfoLabelFS name
- (info1,info2) = mkRetInfoTable info_lbl liveness NoC_SRT
- (fromIntegral cl_type)
- return (info_lbl, info1, info2)
-
-stdInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str =
- basicInfo name (packHalfWordsCLit ptrs nptrs)
- srt_bitmap cl_type desc_str ty_str
-
-conInfo name ptrs nptrs srt_bitmap cl_type desc_str ty_str = do
- (lbl, info1, _) <- basicInfo name (packHalfWordsCLit ptrs nptrs)
- srt_bitmap cl_type desc_str ty_str
- desc_lit <- code $ mkStringCLit desc_str
- let desc_field = makeRelativeRefTo lbl desc_lit
- return (lbl, info1, [desc_field])
-
-basicInfo name layout srt_bitmap cl_type desc_str ty_str = do
- let info_lbl = mkRtsInfoLabelFS name
- lit1 <- if opt_SccProfilingOn
- then code $ do lit <- mkStringCLit desc_str
- return (makeRelativeRefTo info_lbl lit)
- else return (mkIntCLit 0)
- lit2 <- if opt_SccProfilingOn
- then code $ do lit <- mkStringCLit ty_str
- return (makeRelativeRefTo info_lbl lit)
- else return (mkIntCLit 0)
- let info1 = mkStdInfoTable lit1 lit2 (fromIntegral cl_type)
- (fromIntegral srt_bitmap)
- layout
- return (info_lbl, info1, [])
-
-funInfo name ptrs nptrs cl_type desc_str ty_str fun_type = do
- (label,info1,_) <- stdInfo name ptrs nptrs 0{-srt_bitmap-}
- cl_type desc_str ty_str
- let info2 = mkFunGenInfoExtraBits (fromIntegral fun_type) 0 zero zero zero
- -- we leave most of the fields zero here. This is only used
- -- to generate the BCO info table in the RTS at the moment.
- return (label,info1,info2)
- where
- zero = mkIntCLit 0
profilingInfo desc_str ty_str = do
lit1 <- if opt_SccProfilingOn
emitStmts stmts
when (sp /= 0) $ stmtC (CmmAssign spReg (cmmRegOffW spReg (-sp)))
stmtC (CmmJump (entryCode (CmmLoad (cmmRegOffW spReg sp) wordRep)) [])
+ -- TODO (when using CPS): emitStmt (CmmReturn (map snd args))
-- -----------------------------------------------------------------------------
-- If-then-else and boolean expressions
where
rep = cmmExprRep src
- CmmCall (CmmForeignCall fn cconv) results args srt ->
+ CmmCall (CmmForeignCall fn cconv) results args safety ->
-- Controversial: leave this out for now.
-- pprUndef fn $$
- pprCall ppr_fn cconv results args srt
+ pprCall ppr_fn cconv results args safety
where
ppr_fn = case fn of
CmmLit (CmmLabel lbl) -> pprCLabel lbl
ptext SLIT("#undef") <+> pprCLabel lbl
pprUndef _ = empty
- CmmCall (CmmPrim op) results args srt ->
- pprCall ppr_fn CCallConv results args srt
+ CmmCall (CmmPrim op) results args safety ->
+ pprCall ppr_fn CCallConv results args safety
where
ppr_fn = pprCallishMachOp_for_C op
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> C_SRT
+pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety
-> SDoc
pprCall ppr_fn cconv results args _
(hang (pprSection section <+> lbrace) 4 (vcat (map pprStatic ds)))
$$ rbrace
-
+-- --------------------------------------------------------------------------
+instance Outputable CmmSafety where
+ ppr CmmUnsafe = ptext SLIT("_unsafe_call_")
+ ppr (CmmSafe srt) = ppr srt
-- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement
-- and were labelled with the procedure name ++ "_info".
pprInfo (CmmNonInfo gc_target) =
ptext SLIT("gc_target: ") <>
- maybe (ptext SLIT("<none>")) pprBlockId gc_target
+ ptext SLIT("TODO") --maybe (ptext SLIT("<none>")) pprBlockId gc_target
+ -- ^ gc_target is currently unused and wired to a panic
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("TODO"), --maybe (ptext SLIT("<none>")) pprBlockId gc_target,
+ -- ^ gc_target is currently unused and wired to a panic
ptext SLIT("tag: ") <> integer (toInteger tag),
pprTypeInfo info]
-- call "ccall" foo(x, y)[r1, r2];
-- ToDo ppr volatile
- CmmCall (CmmForeignCall fn cconv) results args srt ->
+ CmmCall (CmmForeignCall fn cconv) results args safety ->
hcat [ if null results
then empty
else parens (commafy $ map ppr results) <>
ptext SLIT("call"), space,
doubleQuotes(ppr cconv), space,
target fn, parens ( commafy $ map ppr args ),
- brackets (ppr srt), semi ]
+ brackets (ppr safety), semi ]
where
target (CmmLit lit) = pprLit lit
target fn' = parens (ppr fn')
- CmmCall (CmmPrim op) results args srt ->
+ CmmCall (CmmPrim op) results args safety ->
pprStmt (CmmCall (CmmForeignCall (CmmLit lbl) CCallConv)
- results args srt)
+ results args safety)
where
lbl = CmmLabel (mkForeignLabel (mkFastString (show op)) Nothing False)
nukeVolatileBinds,
nukeDeadBindings,
getLiveStackSlots,
+ getLiveStackBindings,
bindArgsToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
cg_rep = rep } <- varEnvElts binds,
isFollowableArg rep] }
\end{code}
+
+\begin{code}
+getLiveStackBindings :: FCode [(VirtualSpOffset, CgIdInfo)]
+getLiveStackBindings
+ = do { binds <- getBinds
+ ; return [(off, bind) |
+ bind <- varEnvElts binds,
+ CgIdInfo { cg_stb = VirStkLoc off,
+ cg_rep = rep} <- [bind],
+ isFollowableArg rep] }
+\end{code}
mkArgDescr, argDescrType,
-- Liveness
- isBigLiveness, buildContLiveness, mkRegLiveness,
+ isBigLiveness, mkRegLiveness,
smallLiveness, mkLivenessCLit,
-- Register assignment
#include "../includes/StgFun.h"
-------------------------
-argDescrType :: ArgDescr -> Int
+argDescrType :: ArgDescr -> StgHalfWord
-- The "argument type" RTS field type
argDescrType (ArgSpec n) = n
argDescrType (ArgGen liveness)
argBits (PtrArg : args) = False : argBits args
argBits (arg : args) = take (cgRepSizeW arg) (repeat True) ++ argBits args
-stdPattern :: [CgRep] -> Maybe Int
+stdPattern :: [CgRep] -> Maybe StgHalfWord
stdPattern [] = Just ARG_NONE -- just void args, probably
stdPattern [PtrArg] = Just ARG_P
--
-------------------------------------------------------------------------
+-- TODO: This along with 'mkArgDescr' should be unified
+-- with 'CmmInfo.mkLiveness'. However that would require
+-- potentially invasive changes to the 'ClosureInfo' type.
+-- For now, 'CmmInfo.mkLiveness' handles only continuations and
+-- this one handles liveness everything else. Another distinction
+-- between these two is that 'CmmInfo.mkLiveness' information
+-- about the stack layout, and this one is information about
+-- the heap layout of PAPs.
mkLiveness :: Name -> Int -> Bitmap -> FCode Liveness
mkLiveness name size bits
| size > mAX_SMALL_BITMAP_SIZE -- Bitmap does not fit in one word
-------------------------------------------------------------------------
--
--- Build a liveness mask for the current stack
---
--------------------------------------------------------------------------
-
--- There are four kinds of things on the stack:
---
--- - pointer variables (bound in the environment)
--- - non-pointer variables (bound in the environment)
--- - free slots (recorded in the stack free list)
--- - non-pointer data slots (recorded in the stack free list)
---
--- We build up a bitmap of non-pointer slots by searching the environment
--- for all the pointer variables, and subtracting these from a bitmap
--- with initially all bits set (up to the size of the stack frame).
-
-buildContLiveness :: Name -- Basis for label (only)
- -> [VirtualSpOffset] -- Live stack slots
- -> FCode Liveness
-buildContLiveness name live_slots
- = do { stk_usg <- getStkUsage
- ; let StackUsage { realSp = real_sp,
- frameSp = frame_sp } = stk_usg
-
- start_sp :: VirtualSpOffset
- start_sp = real_sp - retAddrSizeW
- -- In a continuation, we want a liveness mask that
- -- starts from just after the return address, which is
- -- on the stack at real_sp.
-
- frame_size :: WordOff
- frame_size = start_sp - frame_sp
- -- real_sp points to the frame-header for the current
- -- stack frame, and the end of this frame is frame_sp.
- -- The size is therefore real_sp - frame_sp - retAddrSizeW
- -- (subtract one for the frame-header = return address).
-
- rel_slots :: [WordOff]
- rel_slots = sortLe (<=)
- [ start_sp - ofs -- Get slots relative to top of frame
- | ofs <- live_slots ]
-
- bitmap = intsToReverseBitmap frame_size rel_slots
-
- ; WARN( not (all (>=0) rel_slots),
- ppr name $$ ppr live_slots $$ ppr frame_size $$ ppr start_sp $$ ppr rel_slots )
- mkLiveness name frame_size bitmap }
-
-
--------------------------------------------------------------------------
---
-- Register assignment
--
-------------------------------------------------------------------------
-- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
- ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
+ ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection
temp_args <- load_args_into_temps args
let (caller_save, caller_load) = callerSaveVolatileRegs vols
stmtsC caller_save
- stmtC (CmmCall target results temp_args srt)
+ stmtC (CmmCall target results temp_args CmmUnsafe)
stmtsC caller_load
| otherwise = do
let (caller_save, caller_load) = callerSaveVolatileRegs vols
emitSaveThreadState
stmtsC caller_save
- -- Using the same SRT for each of these is a little bit conservative
- -- but it should work for now.
+ -- The CmmUnsafe arguments are only correct because this part
+ -- of the code hasn't been moved into the CPS pass yet.
+ -- Once that happens, this function will just emit a (CmmSafe srt) call,
+ -- and the CPS will will be the one to convert that
+ -- to this sequence of three CmmUnsafe calls.
stmtC (CmmCall (CmmForeignCall suspendThread CCallConv)
[ (id,PtrHint) ]
[ (CmmReg (CmmGlobal BaseReg), PtrHint) ]
- srt)
- stmtC (CmmCall temp_target results temp_args srt)
+ CmmUnsafe)
+ stmtC (CmmCall temp_target results temp_args CmmUnsafe)
stmtC (CmmCall (CmmForeignCall resumeThread CCallConv)
[ (new_base, PtrHint) ]
[ (CmmReg (CmmLocal id), PtrHint) ]
- srt)
+ CmmUnsafe)
-- Assign the result to BaseReg: we
-- might now have a different Capability!
stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
dataConTagZ,
emitReturnTarget, emitAlgReturnTarget,
emitReturnInstr,
- mkRetInfoTable,
- mkStdInfoTable,
stdInfoTableSizeB,
- mkFunGenInfoExtraBits,
entryCode, closureInfoPtr,
getConstrTag,
infoTable, infoTableClosureType,
import Maybes
import Constants
import Panic
+import Util
+import Outputable
-------------------------------------------------------------------------
--
--
-------------------------------------------------------------------------
--- Here we make a concrete info table, represented as a list of CmmAddr
--- (it can't be simply a list of Word, because the SRT field is
--- represented by a label+offset expression).
-
--- With tablesNextToCode, the layout is
--- <reversed variable part>
--- <normal forward StgInfoTable, but without
--- an entry point at the front>
--- <code>
---
--- Without tablesNextToCode, the layout of an info table is
--- <entry label>
--- <normal forward rest of StgInfoTable>
--- <forward variable part>
---
--- See includes/InfoTables.h
+-- Here we make an info table of type 'CmmInfo'. The concrete
+-- representation as a list of 'CmmAddr' is handled later
+-- in the pipeline by 'cmmToRawCmm'.
emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code
emitClosureCodeAndInfoTable cl_info args body
- = do { ty_descr_lit <-
- if opt_SccProfilingOn
- then do lit <- mkStringCLit (closureTypeDescr cl_info)
- return (makeRelativeRefTo info_lbl lit)
- else return (mkIntCLit 0)
- ; cl_descr_lit <-
- if opt_SccProfilingOn
- then do lit <- mkStringCLit cl_descr_string
- return (makeRelativeRefTo info_lbl lit)
- else return (mkIntCLit 0)
- ; let std_info = mkStdInfoTable ty_descr_lit cl_descr_lit
- cl_type srt_len layout_lit
-
- ; blks <- cgStmtsToBlocks body
-
- ; conName <-
- if is_con
- then do cstr <- mkByteStringCLit $ fromJust conIdentity
- return (makeRelativeRefTo info_lbl cstr)
- else return (mkIntCLit 0)
-
- ; panic "emitClosureCodeAndInfoTable" } --emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
+ = do { blks <- cgStmtsToBlocks body
+ ; info <- mkCmmInfo cl_info
+ ; emitInfoTableAndCode info_lbl info args blks }
where
info_lbl = infoTableLabelFromCI cl_info
- cl_descr_string = closureValDescr cl_info
- cl_type = smRepClosureTypeInt (closureSMRep cl_info)
-
- srt = closureSRT cl_info
- needs_srt = needsSRT srt
-
- mb_con = isConstrClosure_maybe cl_info
- is_con = isJust mb_con
-
- (srt_label,srt_len,conIdentity)
- = case mb_con of
- Just con -> -- Constructors don't have an SRT
- -- We keep the *zero-indexed* tag in the srt_len
- -- field of the info table.
- (mkIntCLit 0, fromIntegral (dataConTagZ con),
- Just $ dataConIdentity con)
-
- Nothing -> -- Not a constructor
- let (label, len) = srtLabelAndLength srt info_lbl
- in (label, len, Nothing)
-
- ptrs = closurePtrsSize cl_info
- nptrs = size - ptrs
- size = closureNonHdrSize cl_info
- layout_lit = packHalfWordsCLit ptrs nptrs
-
- extra_bits conName
- | is_fun = fun_extra_bits
- | is_con = [conName]
- | needs_srt = [srt_label]
- | otherwise = []
-
- maybe_fun_stuff = closureFunInfo cl_info
- is_fun = isJust maybe_fun_stuff
- (Just (arity, arg_descr)) = maybe_fun_stuff
-
- fun_extra_bits
- | ArgGen liveness <- arg_descr
- = [ fun_amode,
- srt_label,
- makeRelativeRefTo info_lbl $ mkLivenessCLit liveness,
- slow_entry ]
- | needs_srt = [fun_amode, srt_label]
- | otherwise = [fun_amode]
-
- slow_entry = makeRelativeRefTo info_lbl (CmmLabel slow_entry_label)
- slow_entry_label = mkSlowEntryLabel (closureName cl_info)
-
- fun_amode = packHalfWordsCLit fun_type arity
- fun_type = argDescrType arg_descr
-
-- We keep the *zero-indexed* tag in the srt_len field of the info
-- table of a data constructor.
dataConTagZ :: DataCon -> ConTagZ
dataConTagZ con = dataConTag con - fIRST_TAG
--- A low-level way to generate the variable part of a fun-style info table.
--- (must match fun_extra_bits above). Used by the C-- parser.
-mkFunGenInfoExtraBits :: Int -> Int -> CmmLit -> CmmLit -> CmmLit -> [CmmLit]
-mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry
- = [ packHalfWordsCLit fun_type arity,
- srt_label,
- liveness,
- slow_entry ]
+-- Convert from 'ClosureInfo' to 'CmmInfo'.
+-- Not used for return points. (The 'smRepClosureTypeInt' call would panic.)
+mkCmmInfo :: ClosureInfo -> FCode CmmInfo
+mkCmmInfo cl_info = do
+ prof <-
+ if opt_SccProfilingOn
+ then do ty_descr_lit <- mkStringCLit (closureTypeDescr cl_info)
+ cl_descr_lit <- mkStringCLit (closureValDescr cl_info)
+ return $ ProfilingInfo
+ (makeRelativeRefTo info_lbl ty_descr_lit)
+ (makeRelativeRefTo info_lbl cl_descr_lit)
+ else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
+
+ case cl_info of
+ ConInfo { closureCon = con } -> do
+ cstr <- mkByteStringCLit $ dataConIdentity con
+ let conName = makeRelativeRefTo info_lbl cstr
+ info = ConstrInfo (ptrs, nptrs)
+ (fromIntegral (dataConTagZ con))
+ conName
+ return $ CmmInfo prof gc_target cl_type info
+
+ ClosureInfo { closureName = name,
+ closureLFInfo = lf_info,
+ closureSRT = srt } ->
+ return $ CmmInfo prof gc_target cl_type info
+ where
+ info =
+ case lf_info of
+ LFReEntrant _ arity _ arg_descr ->
+ FunInfo (ptrs, nptrs)
+ srt
+ (argDescrType arg_descr)
+ (fromIntegral arity)
+ arg_descr
+ (CmmLabel (mkSlowEntryLabel name))
+ LFThunk _ _ _ (SelectorThunk offset) _ ->
+ ThunkSelectorInfo (fromIntegral offset) srt
+ LFThunk _ _ _ _ _ ->
+ ThunkInfo (ptrs, nptrs) srt
+ _ -> panic "unexpected lambda form in mkCmmInfo"
+ where
+ info_lbl = infoTableLabelFromCI cl_info
+
+ cl_type = smRepClosureTypeInt (closureSMRep cl_info)
+
+ ptrs = fromIntegral $ closurePtrsSize cl_info
+ size = fromIntegral $ closureNonHdrSize cl_info
+ nptrs = size - ptrs
+
+ -- The gc_target is to inform the CPS pass when it inserts a stack check.
+ -- Since that pass isn't used yet we'll punt for now.
+ -- When the CPS pass is fully integrated, this should
+ -- be replaced by the label that any heap check jumped to,
+ -- so that branch can be shared by both the heap (from codeGen)
+ -- and stack checks (from the CPS pass).
+ gc_target = panic "TODO: gc_target"
-------------------------------------------------------------------------
--
--
-------------------------------------------------------------------------
--- Here's the layout of a return-point info table
---
--- Tables next to code:
---
--- <srt slot>
--- <standard info table>
--- ret-addr --> <entry code (if any)>
---
--- Not tables-next-to-code:
---
--- ret-addr --> <ptr to entry code>
--- <standard info table>
--- <srt slot>
---
--- * The SRT slot is only there is SRT info to record
+-- The concrete representation as a list of 'CmmAddr' is handled later
+-- in the pipeline by 'cmmToRawCmm'.
emitReturnTarget
:: Name
-> CgStmts -- The direct-return code (if any)
-> FCode CLabel
emitReturnTarget name stmts
- = do { live_slots <- getLiveStackSlots
- ; liveness <- buildContLiveness name live_slots
- ; srt_info <- getSRTInfo
-
- ; let
- cl_type | isBigLiveness liveness = rET_BIG
- | otherwise = rET_SMALL
-
- (std_info, extra_bits) =
- mkRetInfoTable info_lbl liveness srt_info cl_type
-
+ = do { srt_info <- getSRTInfo
; blks <- cgStmtsToBlocks stmts
- ; panic "emitReturnTarget" --emitInfoTableAndCode info_lbl std_info extra_bits args blks
+ ; frame <- mkStackLayout
+ ; let info = CmmInfo
+ (ProfilingInfo zeroCLit zeroCLit)
+ gc_target
+ rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
+ (ContInfo frame srt_info)
+ ; emitInfoTableAndCode info_lbl info args blks
; return info_lbl }
where
args = {- trace "emitReturnTarget: missing args" -} []
uniq = getUnique name
info_lbl = mkReturnInfoLabel uniq
+ -- The gc_target is to inform the CPS pass when it inserts a stack check.
+ -- Since that pass isn't used yet we'll punt for now.
+ -- When the CPS pass is fully integrated, this should
+ -- be replaced by the label that any heap check jumped to,
+ -- so that branch can be shared by both the heap (from codeGen)
+ -- and stack checks (from the CPS pass).
+ gc_target = panic "TODO: gc_target"
+
-mkRetInfoTable
- :: CLabel -- info label
- -> Liveness -- liveness
- -> C_SRT -- SRT Info
- -> StgHalfWord -- type (eg. rET_SMALL)
- -> ([CmmLit],[CmmLit])
-mkRetInfoTable info_lbl liveness srt_info cl_type
- = (std_info, srt_slot)
+-- Build stack layout information from the state of the 'FCode' monad.
+-- Should go away once 'codeGen' starts using the CPS conversion
+-- pass to handle the stack. Until then, this is really just
+-- here to convert from the 'codeGen' representation of the stack
+-- to the 'CmmInfo' representation of the stack.
+--
+-- See 'CmmInfo.mkLiveness' for where this is converted to a bitmap.
+
+{-
+This seems to be a very error prone part of the code.
+It is surprisingly prone to off-by-one errors, because
+it converts between offset form (codeGen) and list form (CmmInfo).
+Thus a bit of explanation is in order.
+Fortunately, this code should go away once the code generator
+starts using the CPS conversion pass to handle the stack.
+
+The stack looks like this:
+
+ | |
+ |-------------|
+frame_sp --> | return addr |
+ |-------------|
+ | dead slot |
+ |-------------|
+ | live ptr b |
+ |-------------|
+ | live ptr a |
+ |-------------|
+real_sp --> | return addr |
+ +-------------+
+
+Both 'frame_sp' and 'real_sp' are measured downwards
+(i.e. larger frame_sp means smaller memory address).
+
+For that frame we want a result like: [Just a, Just b, Nothing]
+Note that the 'head' of the list is the top
+of the stack, and that the return address
+is not present in the list (it is always assumed).
+-}
+mkStackLayout :: FCode [Maybe LocalReg]
+mkStackLayout = do
+ StackUsage { realSp = real_sp,
+ frameSp = frame_sp } <- getStkUsage
+ binds <- getLiveStackBindings
+ let frame_size = real_sp - frame_sp - retAddrSizeW
+ rel_binds = reverse $ sortWith fst
+ [(offset - frame_sp - retAddrSizeW, b)
+ | (offset, b) <- binds]
+
+ WARN( not (all (\bind -> fst bind >= 0) rel_binds),
+ ppr binds $$ ppr rel_binds $$
+ ppr frame_size $$ ppr real_sp $$ ppr frame_sp )
+ return $ stack_layout rel_binds frame_size
+
+stack_layout :: [(VirtualSpOffset, CgIdInfo)]
+ -> WordOff
+ -> [Maybe LocalReg]
+stack_layout [] sizeW = replicate sizeW Nothing
+stack_layout ((off, bind):binds) sizeW | off == sizeW - 1 =
+ (Just stack_bind) : (stack_layout binds (sizeW - rep_size))
+ where
+ rep_size = cgRepSizeW (cgIdInfoArgRep bind)
+ stack_bind = LocalReg unique machRep kind
+ unique = getUnique (cgIdInfoId bind)
+ machRep = argMachRep (cgIdInfoArgRep bind)
+ kind = if isFollowableArg (cgIdInfoArgRep bind)
+ then KindPtr
+ else KindNonPtr
+stack_layout binds@((off, _):_) sizeW | otherwise =
+ Nothing : (stack_layout binds (sizeW - 1))
+
+{- Another way to write the function that might be less error prone (untested)
+stack_layout offsets sizeW = result
where
- (srt_label, srt_len) = srtLabelAndLength srt_info info_lbl
-
- srt_slot | needsSRT srt_info = [srt_label]
- | otherwise = []
-
- liveness_lit = makeRelativeRefTo info_lbl $ mkLivenessCLit liveness
- std_info = mkStdInfoTable zeroCLit zeroCLit cl_type srt_len liveness_lit
+ y = map (flip lookup offsets) [0..]
+ -- offsets -> nothing and just (each slot is one word)
+ x = take sizeW y -- set the frame size
+ z = clip x -- account for multi-word slots
+ result = map mk_reg z
+
+ clip [] = []
+ clip list@(x : _) = x : clip (drop count list)
+ ASSERT(all isNothing (tail (take count list)))
+
+ count Nothing = 1
+ count (Just x) = cgRepSizeW (cgIdInfoArgRep x)
+
+ mk_reg Nothing = Nothing
+ mk_reg (Just x) = LocalReg unique machRep kind
+ where
+ unique = getUnique (cgIdInfoId x)
+ machRep = argMachrep (cgIdInfoArgRep bind)
+ kind = if isFollowableArg (cgIdInfoArgRep bind)
+ then KindPtr
+ else KindNonPtr
+-}
emitAlgReturnTarget
:: Name -- Just for its unique
= do { info_amode <- getSequelAmode
; stmtC (CmmJump (entryCode info_amode) []) }
--------------------------------------------------------------------------
---
--- Generating a standard info table
+-----------------------------------------------------------------------------
--
--------------------------------------------------------------------------
-
--- The standard bits of an info table. This part of the info table
--- corresponds to the StgInfoTable type defined in InfoTables.h.
+-- Info table offsets
--
--- Its shape varies with ticky/profiling/tables next to code etc
--- so we can't use constant offsets from Constants
-
-mkStdInfoTable
- :: CmmLit -- closure type descr (profiling)
- -> CmmLit -- closure descr (profiling)
- -> StgHalfWord -- closure type
- -> StgHalfWord -- SRT length
- -> CmmLit -- layout field
- -> [CmmLit]
-
-mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit
- = -- Parallel revertible-black hole field
- prof_info
- -- Ticky info (none at present)
- -- Debug info (none at present)
- ++ [layout_lit, type_lit]
-
- where
- prof_info
- | opt_SccProfilingOn = [type_descr, closure_descr]
- | otherwise = []
-
- type_lit = packHalfWordsCLit cl_type srt_len
+-----------------------------------------------------------------------------
stdInfoTableSizeW :: WordOff
-- The size of a standard info table varies with profiling/ticky etc,
where
entry_lbl = infoLblToEntryLbl info_lbl
-{-
-emitInfoTableAndCode
- :: CLabel -- Label of info table
- -> [CmmLit] -- ...its invariant part
- -> [CmmLit] -- ...and its variant part
- -> CmmFormals -- ...args
- -> [CmmBasicBlock] -- ...and body
- -> Code
-
-emitInfoTableAndCode info_lbl std_info extra_bits args blocks
- | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc
- = emitProc (reverse extra_bits ++ std_info)
- entry_lbl args blocks
- -- NB: the info_lbl is discarded
-
- | null blocks -- No actual code; only the info table is significant
- = -- Use a zero place-holder in place of the
- -- entry-label in the info table
- emitRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)
-
- | otherwise -- Separately emit info table (with the function entry
- = -- point as first entry) and the entry code
- do { emitDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)
- ; emitProc [] entry_lbl args blocks }
-
- where
- entry_lbl = infoLblToEntryLbl info_lbl
--}
-
-------------------------------------------------------------------------
--
-- Static reference tables
ifProfiling $ do
stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
-enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
+enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] False
-- ToDo: vols
enter_ccs_fsub = enteringPAP 0
= emitRtsCallWithResult result PtrHint
SLIT("PushCostCentre") [(ccs,PtrHint),
(CmmLit (mkCCostCentre cc), PtrHint)]
+ False
bumpSccCount :: CmmExpr -> CmmStmt
bumpSccCount ccs
; labelC join_id
}
-emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Code
-emitRtsCall fun args = emitRtsCall' [] fun args Nothing
+emitRtsCall :: LitString -> [(CmmExpr,MachHint)] -> Bool -> Code
+emitRtsCall fun args safe = emitRtsCall' [] fun args Nothing safe
-- The 'Nothing' says "save all global registers"
-emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Code
-emitRtsCallWithVols fun args vols
- = emitRtsCall' [] fun args (Just vols)
+emitRtsCallWithVols :: LitString -> [(CmmExpr,MachHint)] -> [GlobalReg] -> Bool -> Code
+emitRtsCallWithVols fun args vols safe
+ = emitRtsCall' [] fun args (Just vols) safe
emitRtsCallWithResult :: LocalReg -> MachHint -> LitString
- -> [(CmmExpr,MachHint)] -> Code
-emitRtsCallWithResult res hint fun args
- = emitRtsCall' [(res,hint)] fun args Nothing
+ -> [(CmmExpr,MachHint)] -> Bool -> Code
+emitRtsCallWithResult res hint fun args safe
+ = emitRtsCall' [(res,hint)] fun args Nothing safe
-- Make a call to an RTS C procedure
emitRtsCall'
-> LitString
-> [(CmmExpr,MachHint)]
-> Maybe [GlobalReg]
+ -> Bool -- True <=> CmmSafe call
-> Code
-emitRtsCall' res fun args vols = do
- srt <- getSRTInfo
- stmtsC caller_save
- stmtC (CmmCall target res args srt)
- stmtsC caller_load
+emitRtsCall' res fun args vols safe = do
+ safety <- if safe
+ then getSRTInfo >>= (return . CmmSafe)
+ else return CmmUnsafe
+ stmtsC caller_save
+ stmtC (CmmCall target res args safety)
+ stmtsC caller_load
where
(caller_save, caller_load) = callerSaveVolatileRegs vols
target = CmmForeignCall fun_expr CCallConv
\begin{code}
module ClosureInfo (
- ClosureInfo, LambdaFormInfo, SMRep, -- all abstract
- StandardFormInfo,
+ ClosureInfo(..), LambdaFormInfo(..), -- would be abstract but
+ StandardFormInfo(..), -- mkCmmInfo looks inside
+ SMRep,
ArgDescr(..), Liveness(..),
C_SRT(..), needsSRT,
data ArgDescr
= ArgSpec -- Fits one of the standard patterns
- !Int -- RTS type identifier ARG_P, ARG_N, ...
+ !StgHalfWord -- RTS type identifier ARG_P, ARG_N, ...
| ArgGen -- General case
Liveness -- Details about the arguments
getPredTyDescription (ClassP cl tys) = getOccString cl
getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
-
-
import CodeGen ( codeGen )
import CmmParse ( parseCmmFile )
import CmmCPS
+import CmmInfo
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
foreign_stubs dir_imps cost_centre_info
stg_binds hpc_info
------------------ Convert to CPS --------------------
- continuationC <- {-return abstractC-} cmmCPS dflags abstractC
+ --continuationC <- cmmCPS dflags abstractC
+ continuationC <- cmmToRawCmm 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 <- {-return [cmm]-} cmmCPS dflags [cmm]
+ --continuationC <- cmmCPS dflags [cmm]
+ continuationC <- cmmToRawCmm [cmm]
codeOutput dflags no_mod no_loc NoStubs [] continuationC
return True
where
returnUs (concat stmtss)
fixAssign :: CmmStmt -> UniqSM [CmmStmt]
-fixAssign (CmmAssign (CmmGlobal BaseReg) src)
- = panic "cmmStmtConFold: assignment to BaseReg";
-
fixAssign (CmmAssign (CmmGlobal reg) src)
| Left realreg <- reg_or_addr
= returnUs [CmmAssign (CmmGlobal reg) src]
where
reg_or_addr = get_GlobalReg_reg_or_addr reg
-{-
-fixAssign (CmmCall target results args)
- = mapAndUnzipUs fixResult results `thenUs` \ (results',stores) ->
- returnUs (CmmCall target results' args :
- concat stores)
- where
- fixResult g@(CmmGlobal reg,hint) =
- case get_GlobalReg_reg_or_addr reg of
- Left realreg -> returnUs (g, [])
- Right baseRegAddr ->
- getUniqueUs `thenUs` \ uq ->
- let local = CmmLocal (LocalReg uq (globalRegRep reg)) in
- returnUs ((local,hint),
- [CmmStore baseRegAddr (CmmReg local)])
- fixResult other =
- returnUs (other,[])
--}
-
fixAssign other_stmt = returnUs [other_stmt]
-- -----------------------------------------------------------------------------
if localRegRep res == F64
then
- stmtToInstrs (CmmCall target [(res,FloatHint)] args NoC_SRT)
+ stmtToInstrs (CmmCall target [(res,FloatHint)] args CmmUnsafe)
else do
uq <- getUniqueNat
let
tmp = LocalReg uq F64 KindNonPtr
-- in
- code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args NoC_SRT)
+ code1 <- stmtToInstrs (CmmCall target [(tmp,FloatHint)] args CmmUnsafe)
code2 <- stmtToInstrs (CmmAssign (CmmLocal res) (CmmReg (CmmLocal tmp)))
return (code1 `appOL` code2)
where
__bd = W_[mut_list]; \
if (bdescr_free(__bd) >= bdescr_start(__bd) + BLOCK_SIZE) { \
W_ __new_bd; \
- "ptr" __new_bd = foreign "C" allocBlock_lock() [regs]; \
+ ("ptr" __new_bd) = foreign "C" allocBlock_lock() [regs]; \
bdescr_link(__new_bd) = __bd; \
__bd = __new_bd; \
W_[mut_list] = __bd; \
-------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
- 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret, RET_SMALL )
{
CInt r;
Sp_adj(1);
#endif
SAVE_THREAD_STATE();
- r = foreign "C" maybePerformBlockedException (MyCapability() "ptr",
+ (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr",
CurrentTSO "ptr") [R1];
if (r != 0::CInt) {
#endif
}
-INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret,
- 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_blockAsyncExceptionszh_ret, RET_SMALL )
{
StgTSO_flags(CurrentTSO) =
StgTSO_flags(CurrentTSO) | TSO_BLOCKEX::I32 | TSO_INTERRUPTIBLE::I32;
* thread, which might result in the thread being killed.
*/
SAVE_THREAD_STATE();
- r = foreign "C" maybePerformBlockedException (MyCapability() "ptr",
+ (r) = foreign "C" maybePerformBlockedException (MyCapability() "ptr",
CurrentTSO "ptr") [R1];
if (r != 0::CInt) {
W_ retcode;
out = BaseReg + OFFSET_StgRegTable_rmp_tmp_w;
- retcode = foreign "C" throwTo(MyCapability() "ptr",
+ (retcode) = foreign "C" throwTo(MyCapability() "ptr",
CurrentTSO "ptr",
target "ptr",
exception "ptr",
#define SP_OFF 1
#endif
-#if defined(PROFILING)
-#define CATCH_FRAME_BITMAP 7
-#define CATCH_FRAME_WORDS 4
-#else
-#define CATCH_FRAME_BITMAP 1
-#define CATCH_FRAME_WORDS 2
-#endif
-
/* Catch frames are very similar to update frames, but when entering
* one we just pop the frame off the stack and perform the correct
* kind of return to the activation record underneath us on the stack.
*/
-INFO_TABLE_RET(stg_catch_frame,
- CATCH_FRAME_WORDS, CATCH_FRAME_BITMAP,
- CATCH_FRAME)
+INFO_TABLE_RET(stg_catch_frame, CATCH_FRAME,
+#if defined(PROFILING)
+ W_ unused1, W_ unused2,
+#endif
+ W_ unused3, "ptr" W_ unused4)
#ifdef REG_R1
{
Sp = Sp + SIZEOF_StgCatchFrame;
no_break_on_exception: W_[1];
}
-INFO_TABLE_RET(stg_raise_ret, 1, 0, RET_SMALL)
+INFO_TABLE_RET(stg_raise_ret, RET_SMALL, "ptr" W_ arg1)
{
R1 = Sp(1);
Sp = Sp + WDS(2);
retry_pop_stack:
StgTSO_sp(CurrentTSO) = Sp;
- frame_type = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
+ (frame_type) = foreign "C" raiseExceptionHelper(BaseReg "ptr", CurrentTSO "ptr", exception "ptr") [];
Sp = StgTSO_sp(CurrentTSO);
if (frame_type == ATOMICALLY_FRAME) {
/* The exception has reached the edge of a memory transaction. Check that
W_ trec, outer;
W_ r;
trec = StgTSO_trec(CurrentTSO);
- r = foreign "C" stmValidateNestOfTransactions(trec "ptr") [];
- "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ (r) = foreign "C" stmValidateNestOfTransactions(trec "ptr") [];
+ ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
} else {
// Transaction was not valid: we retry the exception (otherwise continue
// with a further call to raiseExceptionHelper)
- "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
+ ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
StgTSO_trec(CurrentTSO) = trec;
R1 = StgAtomicallyFrame_code(Sp);
jump stg_ap_v_fast;
// for exmplae. Perhaps the stop_on_exception flag should
// be per-thread.
W_[rts_stop_on_exception] = 0;
- "ptr" ioAction = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") [];
+ ("ptr" ioAction) = foreign "C" deRefStablePtr (W_[rts_breakpoint_io_action] "ptr") [];
Sp = Sp - WDS(6);
Sp(5) = exception;
Sp(4) = stg_raise_ret_info;
} else {
W_ trec, outer;
trec = StgTSO_trec(CurrentTSO);
- "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
StgTSO_trec(CurrentTSO) = outer;
There are canned sequences for 'n' pointer values in registers.
-------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_enter, 1/*framesize*/, 0/*bitmap*/, RET_SMALL)
+INFO_TABLE_RET( stg_enter, RET_SMALL, "ptr" W_ unused)
{
R1 = Sp(1);
Sp_adj(2);
/*-- void return ------------------------------------------------------------ */
-INFO_TABLE_RET( stg_gc_void, 0/*framesize*/, 0/*bitmap*/, RET_SMALL)
+INFO_TABLE_RET( stg_gc_void, RET_SMALL)
{
Sp_adj(1);
jump %ENTRY_CODE(Sp(0));
/*-- R1 is boxed/unpointed -------------------------------------------------- */
-INFO_TABLE_RET( stg_gc_unpt_r1, 1/*framesize*/, 0/*bitmap*/, RET_SMALL)
+INFO_TABLE_RET( stg_gc_unpt_r1, RET_SMALL, "ptr" W_ unused)
{
R1 = Sp(1);
Sp_adj(2);
/*-- R1 is unboxed -------------------------------------------------- */
/* the 1 is a bitmap - i.e. 1 non-pointer word on the stack. */
-INFO_TABLE_RET( stg_gc_unbx_r1, 1/*framesize*/, 1/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_gc_unbx_r1, RET_SMALL, W_ unused )
{
R1 = Sp(1);
Sp_adj(2);
/*-- F1 contains a float ------------------------------------------------- */
-INFO_TABLE_RET( stg_gc_f1, 1/*framesize*/, 1/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_gc_f1, RET_SMALL, F_ unused )
{
F1 = F_[Sp+WDS(1)];
Sp_adj(2);
/*-- D1 contains a double ------------------------------------------------- */
-/* we support doubles of either 1 or 2 words in size */
-
-#if SIZEOF_DOUBLE == SIZEOF_VOID_P
-# define DBL_BITMAP 1
-# define DBL_WORDS 1
-#else
-# define DBL_BITMAP 3
-# define DBL_WORDS 2
-#endif
-
-INFO_TABLE_RET( stg_gc_d1, DBL_WORDS/*framesize*/, DBL_BITMAP/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_gc_d1, RET_SMALL, D_ unused )
{
D1 = D_[Sp + WDS(1)];
Sp = Sp + WDS(1) + SIZEOF_StgDouble;
/*-- L1 contains an int64 ------------------------------------------------- */
-/* we support int64s of either 1 or 2 words in size */
-
-#if SIZEOF_VOID_P == 8
-# define LLI_BITMAP 1
-# define LLI_WORDS 1
-#else
-# define LLI_BITMAP 3
-# define LLI_WORDS 2
-#endif
-
-INFO_TABLE_RET( stg_gc_l1, LLI_WORDS/*framesize*/, LLI_BITMAP/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_gc_l1, RET_SMALL, L_ unused )
{
L1 = L_[Sp + WDS(1)];
Sp_adj(1) + SIZEOF_StgWord64;
/*-- Unboxed tuple return, one pointer (unregisterised build only) ---------- */
-INFO_TABLE_RET( stg_ut_1_0_unreg, 1/*size*/, 0/*BITMAP*/, RET_SMALL )
+INFO_TABLE_RET( stg_ut_1_0_unreg, RET_SMALL, "ptr" W_ unused )
{
Sp_adj(1);
// one ptr is on the stack (Sp(0))
appropriately. The stack layout is given above.
-------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_gc_fun, 0/*framesize*/, 0/*bitmap*/, RET_FUN )
+INFO_TABLE_RET( stg_gc_fun, RET_FUN )
{
R1 = Sp(2);
Sp_adj(3);
Sp(1) = R9; /* liveness mask */ \
Sp(0) = stg_gc_gen_info;
-INFO_TABLE_RET( stg_gc_gen, 0/*framesize*/, 0/*bitmap*/, RET_DYN )
+INFO_TABLE_RET( stg_gc_gen, RET_DYN )
/* bitmap in the above info table is unused, the real one is on the stack. */
{
RESTORE_EVERYTHING;
*
* -------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_block_takemvar, 1/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_block_takemvar, RET_SMALL, "ptr" W_ unused )
{
R1 = Sp(1);
Sp_adj(2);
BLOCK_BUT_FIRST(stg_block_takemvar_finally);
}
-INFO_TABLE_RET( stg_block_putmvar, 2/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_block_putmvar, RET_SMALL, "ptr" W_ unused1, "ptr" W_ unused2 )
{
R2 = Sp(2);
R1 = Sp(1);
BLOCK_BUT_FIRST(stg_block_blackhole_finally);
}
-INFO_TABLE_RET( stg_block_throwto, 2/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_block_throwto, RET_SMALL, "ptr" W_ unused, "ptr" W_ unused )
{
R2 = Sp(2);
R1 = Sp(1);
}
#ifdef mingw32_HOST_OS
-INFO_TABLE_RET( stg_block_async, 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_block_async, RET_SMALL )
{
W_ ares;
W_ len, errC;
n = R1;
payload_words = ROUNDUP_BYTES_TO_WDS(n);
words = BYTES_TO_WDS(SIZEOF_StgArrWords) + payload_words;
- "ptr" p = foreign "C" allocateLocal(MyCapability() "ptr",words) [];
+ ("ptr" p) = foreign "C" allocateLocal(MyCapability() "ptr",words) [];
TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
SET_HDR(p, stg_ARR_WORDS_info, W_[CCCS]);
StgArrWords_words(p) = payload_words;
words = words + 1;
}
- "ptr" p = foreign "C" allocatePinned(words) [];
+ ("ptr" p) = foreign "C" allocatePinned(words) [];
TICK_ALLOC_PRIM(SIZEOF_StgArrWords,WDS(payload_words),0);
// Again, if the ArrWords header isn't a multiple of 8 bytes, we
MAYBE_GC(R2_PTR,newArrayzh_fast);
words = BYTES_TO_WDS(SIZEOF_StgMutArrPtrs) + n;
- "ptr" arr = foreign "C" allocateLocal(MyCapability() "ptr",words) [R2];
+ ("ptr" arr) = foreign "C" allocateLocal(MyCapability() "ptr",words) [R2];
TICK_ALLOC_PRIM(SIZEOF_StgMutArrPtrs, WDS(n), 0);
SET_HDR(arr, stg_MUT_ARR_PTRS_DIRTY_info, W_[CCCS]);
FETCH_MP_TEMP(mp_tmp_w);
W_[mp_tmp_w] = R1;
- r = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) [];
+ (r) = foreign "C" __gmpn_gcd_1(mp_tmp_w "ptr", 1, R2) [];
R1 = r;
/* Result parked in R1, return via info-pointer at TOS */
gcdIntegerIntzh_fast
{
/* R1 = s1; R2 = d1; R3 = the int */
- R1 = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) [];
+ W_ s1;
+ (s1) = foreign "C" __gmpn_gcd_1( BYTE_ARR_CTS(R2) "ptr", R1, R3) [];
+ R1 = s1;
/* Result parked in R1, return via info-pointer at TOS */
jump %ENTRY_CODE(Sp(0));
up = BYTE_ARR_CTS(R2);
vp = BYTE_ARR_CTS(R4);
- cmp = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) [];
+ (cmp) = foreign "C" __gmpn_cmp(up "ptr", vp "ptr", size) [];
if (cmp == 0 :: CInt) {
R1 = 0;
W_ threadid;
closure = R1;
- "ptr" threadid = foreign "C" createIOThread( MyCapability() "ptr",
+ ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr",
RtsFlags_GcFlags_initialStkSize(RtsFlags),
closure "ptr") [];
foreign "C" scheduleThread(MyCapability() "ptr", threadid "ptr") [];
cpu = R1;
closure = R2;
- "ptr" threadid = foreign "C" createIOThread( MyCapability() "ptr",
+ ("ptr" threadid) = foreign "C" createIOThread( MyCapability() "ptr",
RtsFlags_GcFlags_initialStkSize(RtsFlags),
closure "ptr") [];
foreign "C" scheduleThreadOn(MyCapability() "ptr", cpu, threadid "ptr") [];
{
/* no args */
W_ r;
- r = foreign "C" isThreadBound(CurrentTSO) [];
+ (r) = foreign "C" isThreadBound(CurrentTSO) [];
RET_N(r);
}
// Catch retry frame ------------------------------------------------------------
+INFO_TABLE_RET(stg_catch_retry_frame, CATCH_RETRY_FRAME,
#if defined(PROFILING)
-#define CATCH_RETRY_FRAME_BITMAP 7
-#define CATCH_RETRY_FRAME_WORDS 5
-#else
-#define CATCH_RETRY_FRAME_BITMAP 1
-#define CATCH_RETRY_FRAME_WORDS 3
+ W_ unused1, W_ unused2,
#endif
-
-INFO_TABLE_RET(stg_catch_retry_frame,
- CATCH_RETRY_FRAME_WORDS, CATCH_RETRY_FRAME_BITMAP,
- CATCH_RETRY_FRAME)
+ W_ unused3, "ptr" W_ unused4, "ptr" W_ unused5)
{
W_ r, frame, trec, outer;
IF_NOT_REG_R1(W_ rval; rval = Sp(0); Sp_adj(1); )
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
- "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
- r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
+ ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
if (r != 0) {
/* Succeeded (either first branch or second branch) */
StgTSO_trec(CurrentTSO) = outer;
} else {
/* Did not commit: re-execute */
W_ new_trec;
- "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
+ ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
StgTSO_trec(CurrentTSO) = new_trec;
if (StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
R1 = StgCatchRetryFrame_alt_code(frame);
// Atomically frame ------------------------------------------------------------
+INFO_TABLE_RET(stg_atomically_frame, ATOMICALLY_FRAME,
#if defined(PROFILING)
-#define ATOMICALLY_FRAME_BITMAP 3
-#define ATOMICALLY_FRAME_WORDS 4
-#else
-#define ATOMICALLY_FRAME_BITMAP 0
-#define ATOMICALLY_FRAME_WORDS 2
+ W_ unused1, W_ unused2,
#endif
-
-INFO_TABLE_RET(stg_atomically_frame,
- ATOMICALLY_FRAME_WORDS, ATOMICALLY_FRAME_BITMAP,
- ATOMICALLY_FRAME)
+ "ptr" W_ unused3, "ptr" W_ unused4)
{
W_ frame, trec, valid, next_invariant, q, outer;
IF_NOT_REG_R1(W_ rval; rval = Sp(0); Sp_adj(1); )
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
- "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
if (outer == NO_TREC) {
/* First time back at the atomically frame -- pick up invariants */
- "ptr" q = foreign "C" stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr") [];
+ ("ptr" q) = foreign "C" stmGetInvariantsToCheck(MyCapability() "ptr", trec "ptr") [];
StgAtomicallyFrame_next_invariant_to_check(frame) = q;
} else {
if (q != END_INVARIANT_CHECK_QUEUE) {
/* We can't commit yet: another invariant to check */
- "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [];
+ ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [];
StgTSO_trec(CurrentTSO) = trec;
next_invariant = StgInvariantCheckQueue_invariant(q);
} else {
/* We've got no more invariants to check, try to commit */
- valid = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr") [];
+ (valid) = foreign "C" stmCommitTransaction(MyCapability() "ptr", trec "ptr") [];
if (valid != 0) {
/* Transaction was valid: commit succeeded */
StgTSO_trec(CurrentTSO) = NO_TREC;
jump %ENTRY_CODE(Sp(SP_OFF));
} else {
/* Transaction was not valid: try again */
- "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
+ ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
StgTSO_trec(CurrentTSO) = trec;
StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE;
R1 = StgAtomicallyFrame_code(frame);
}
}
-INFO_TABLE_RET(stg_atomically_waiting_frame,
- ATOMICALLY_FRAME_WORDS, ATOMICALLY_FRAME_BITMAP,
- ATOMICALLY_FRAME)
+INFO_TABLE_RET(stg_atomically_waiting_frame, ATOMICALLY_FRAME,
+#if defined(PROFILING)
+ W_ unused1, W_ unused2,
+#endif
+ "ptr" W_ unused3, "ptr" W_ unused4)
{
W_ frame, trec, valid;
IF_NOT_REG_R1(W_ rval; rval = Sp(0); Sp_adj(1); )
frame = Sp;
/* The TSO is currently waiting: should we stop waiting? */
- valid = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr") [];
+ (valid) = foreign "C" stmReWait(MyCapability() "ptr", CurrentTSO "ptr") [];
if (valid != 0) {
/* Previous attempt is still valid: no point trying again yet */
IF_NOT_REG_R1(Sp_adj(-2);
jump stg_block_noregs;
} else {
/* Previous attempt is no longer valid: try again */
- "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
+ ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", NO_TREC "ptr") [];
StgTSO_trec(CurrentTSO) = trec;
StgHeader_info(frame) = stg_atomically_frame_info;
R1 = StgAtomicallyFrame_code(frame);
#define SP_OFF 1
#endif
-#if defined(PROFILING)
-#define CATCH_STM_FRAME_BITMAP 3
-#define CATCH_STM_FRAME_WORDS 4
-#else
-#define CATCH_STM_FRAME_BITMAP 0
-#define CATCH_STM_FRAME_WORDS 2
-#endif
-
/* Catch frames are very similar to update frames, but when entering
* one we just pop the frame off the stack and perform the correct
* kind of return to the activation record underneath us on the stack.
*/
-INFO_TABLE_RET(stg_catch_stm_frame,
- CATCH_STM_FRAME_WORDS, CATCH_STM_FRAME_BITMAP,
- CATCH_STM_FRAME)
+INFO_TABLE_RET(stg_catch_stm_frame, CATCH_STM_FRAME,
+#if defined(PROFILING)
+ W_ unused1, W_ unused2,
+#endif
+ "ptr" W_ unused3, "ptr" W_ unused4)
{
IF_NOT_REG_R1(W_ rval; rval = Sp(0); Sp_adj(1); )
W_ r, frame, trec, outer;
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
- "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
- r = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
+ ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ (r) = foreign "C" stmCommitNestedTransaction(MyCapability() "ptr", trec "ptr") [];
if (r != 0) {
/* Commit succeeded */
StgTSO_trec(CurrentTSO) = outer;
} else {
/* Commit failed */
W_ new_trec;
- "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
+ ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
StgTSO_trec(CurrentTSO) = new_trec;
R1 = StgCatchSTMFrame_code(frame);
jump stg_ap_v_fast;
StgAtomicallyFrame_next_invariant_to_check(frame) = END_INVARIANT_CHECK_QUEUE;
/* Start the memory transcation */
- "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr") [R1];
+ ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", old_trec "ptr") [R1];
StgTSO_trec(CurrentTSO) = new_trec;
/* Apply R1 to the realworld token */
W_ cur_trec;
W_ new_trec;
cur_trec = StgTSO_trec(CurrentTSO);
- "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", cur_trec "ptr");
+ ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", cur_trec "ptr");
StgTSO_trec(CurrentTSO) = new_trec;
/* Apply R1 to the realworld token */
/* Start a nested transaction within which to run the first code */
trec = StgTSO_trec(CurrentTSO);
- "ptr" new_trec = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [R1,R2];
+ ("ptr" new_trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", trec "ptr") [R1,R2];
StgTSO_trec(CurrentTSO) = new_trec;
/* Set up the catch-retry frame */
// Find the enclosing ATOMICALLY_FRAME or CATCH_RETRY_FRAME
retry_pop_stack:
StgTSO_sp(CurrentTSO) = Sp;
- frame_type = foreign "C" findRetryFrameHelper(CurrentTSO "ptr") [];
+ (frame_type) = foreign "C" findRetryFrameHelper(CurrentTSO "ptr") [];
Sp = StgTSO_sp(CurrentTSO);
frame = Sp;
trec = StgTSO_trec(CurrentTSO);
- "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
if (frame_type == CATCH_RETRY_FRAME) {
// The retry reaches a CATCH_RETRY_FRAME before the atomic frame
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
if (!StgCatchRetryFrame_running_alt_code(frame) != 0::I32) {
// Retry in the first branch: try the alternative
- "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
+ ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
StgTSO_trec(CurrentTSO) = trec;
StgCatchRetryFrame_running_alt_code(frame) = 1 :: CInt; // true;
R1 = StgCatchRetryFrame_alt_code(frame);
foreign "C" stmAbortTransaction(MyCapability() "ptr", trec "ptr") [];
foreign "C" stmFreeAbortedTRec(MyCapability() "ptr", trec "ptr") [];
trec = outer;
- StgTSO_trec(CurrentTSO) = trec;
- "ptr" outer = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
+ StgTSO_trec(CurrentTSO) = trec;
+ ("ptr" outer) = foreign "C" stmGetEnclosingTRec(trec "ptr") [];
}
ASSERT(outer == NO_TREC);
- r = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr") [];
+ (r) = foreign "C" stmWait(MyCapability() "ptr", CurrentTSO "ptr", trec "ptr") [];
if (r != 0) {
// Transaction was valid: stmWait put us on the TVars' queues, we now block
StgHeader_info(frame) = stg_atomically_waiting_frame_info;
jump stg_block_stmwait;
} else {
// Transaction was not valid: retry immediately
- "ptr" trec = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
+ ("ptr" trec) = foreign "C" stmStartTransaction(MyCapability() "ptr", outer "ptr") [];
StgTSO_trec(CurrentTSO) = trec;
R1 = StgAtomicallyFrame_code(frame);
Sp = frame;
MAYBE_GC (R1_PTR, newTVarzh_fast);
new_value = R1;
- "ptr" tv = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr") [];
+ ("ptr" tv) = foreign "C" stmNewTVar(MyCapability() "ptr", new_value "ptr") [];
RET_P(tv);
}
MAYBE_GC (R1_PTR, readTVarzh_fast); // Call to stmReadTVar may allocate
trec = StgTSO_trec(CurrentTSO);
tvar = R1;
- "ptr" result = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
+ ("ptr" result) = foreign "C" stmReadTVar(MyCapability() "ptr", trec "ptr", tvar "ptr") [];
RET_P(result);
}
mvar = R1;
#if defined(THREADED_RTS)
- "ptr" info = foreign "C" lockClosure(mvar "ptr") [];
+ ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
#else
info = GET_INFO(mvar);
#endif
#if defined(GRAN) || defined(PAR)
/* ToDo: check 2nd arg (mvar) is right */
- "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar),mvar) [];
+ ("ptr" tso) = foreign "C" unblockOne(StgMVar_head(mvar),mvar) [];
StgMVar_head(mvar) = tso;
#else
- "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr",
+ ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr",
StgMVar_head(mvar) "ptr") [];
StgMVar_head(mvar) = tso;
#endif
mvar = R1;
#if defined(THREADED_RTS)
- "ptr" info = foreign "C" lockClosure(mvar "ptr") [];
+ ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [];
#else
info = GET_INFO(mvar);
#endif
#if defined(GRAN) || defined(PAR)
/* ToDo: check 2nd arg (mvar) is right */
- "ptr" tso = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr") [];
+ ("ptr" tso) = foreign "C" unblockOne(StgMVar_head(mvar) "ptr", mvar "ptr") [];
StgMVar_head(mvar) = tso;
#else
- "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr",
+ ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr",
StgMVar_head(mvar) "ptr") [];
StgMVar_head(mvar) = tso;
#endif
mvar = R1;
#if defined(THREADED_RTS)
- "ptr" info = foreign "C" lockClosure(mvar "ptr") [R2];
+ ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [R2];
#else
info = GET_INFO(mvar);
#endif
#if defined(GRAN) || defined(PAR)
/* ToDo: check 2nd arg (mvar) is right */
- "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
+ ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
StgMVar_head(mvar) = tso;
#else
- "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
+ ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
StgMVar_head(mvar) = tso;
#endif
mvar = R1;
#if defined(THREADED_RTS)
- "ptr" info = foreign "C" lockClosure(mvar "ptr") [R2];
+ ("ptr" info) = foreign "C" lockClosure(mvar "ptr") [R2];
#else
info = GET_INFO(mvar);
#endif
#if defined(GRAN) || defined(PAR)
/* ToDo: check 2nd arg (mvar) is right */
- "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
+ ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr",mvar "ptr") [];
StgMVar_head(mvar) = tso;
#else
- "ptr" tso = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
+ ("ptr" tso) = foreign "C" unblockOne(MyCapability() "ptr", StgMVar_head(mvar) "ptr") [];
StgMVar_head(mvar) = tso;
#endif
ALLOC_PRIM( SIZEOF_StgStableName, R1_PTR, makeStableNamezh_fast );
- index = foreign "C" lookupStableName(R1 "ptr") [];
+ (index) = foreign "C" lookupStableName(R1 "ptr") [];
/* Is there already a StableName for this heap object?
* stable_ptr_table is a pointer to an array of snEntry structs.
/* Args: R1 = a */
W_ sp;
MAYBE_GC(R1_PTR, makeStablePtrzh_fast);
- "ptr" sp = foreign "C" getStablePtr(R1 "ptr") [];
+ ("ptr" sp) = foreign "C" getStablePtr(R1 "ptr") [];
RET_N(sp);
}
#ifdef mingw32_HOST_OS
/* could probably allocate this on the heap instead */
- "ptr" ares = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
+ ("ptr" ares) = foreign "C" stgMallocBytes(SIZEOF_StgAsyncIOResult,
stg_delayzh_malloc_str);
reqID = foreign "C" addDelayRequest(R1);
StgAsyncIOResult_reqID(ares) = reqID;
W_ time;
W_ divisor;
- time = foreign "C" getourtimeofday() [R1];
+ (time) = foreign "C" getourtimeofday() [R1];
divisor = TO_W_(RtsFlags_MiscFlags_tickInterval(RtsFlags))*1000;
target = ((R1 + divisor - 1) / divisor) /* divide rounding up */
+ time + 1; /* Add 1 as getourtimeofday rounds down */
haven't got a good story about that yet.
*/
-INFO_TABLE_RET( stg_ctoi_R1p,
- 0/*size*/, 0/*bitmap*/, /* special layout! */
- RET_BCO)
+INFO_TABLE_RET( stg_ctoi_R1p, RET_BCO)
{
Sp_adj(-2);
Sp(1) = R1;
/*
* When the returned value is a pointer, but unlifted, in R1 ...
*/
-INFO_TABLE_RET( stg_ctoi_R1unpt,
- 0/*size*/, 0/*bitmap*/, /* special layout! */
- RET_BCO )
+INFO_TABLE_RET( stg_ctoi_R1unpt, RET_BCO )
{
Sp_adj(-2);
Sp(1) = R1;
/*
* When the returned value is a non-pointer in R1 ...
*/
-INFO_TABLE_RET( stg_ctoi_R1n,
- 0/*size*/, 0/*bitmap*/, /* special layout! */
- RET_BCO )
+INFO_TABLE_RET( stg_ctoi_R1n, RET_BCO )
{
Sp_adj(-2);
Sp(1) = R1;
/*
* When the returned value is in F1
*/
-INFO_TABLE_RET( stg_ctoi_F1,
- 0/*size*/, 0/*bitmap*/, /* special layout! */
- RET_BCO )
+INFO_TABLE_RET( stg_ctoi_F1, RET_BCO )
{
Sp_adj(-2);
F_[Sp + WDS(1)] = F1;
/*
* When the returned value is in D1
*/
-INFO_TABLE_RET( stg_ctoi_D1,
- 0/*size*/, 0/*bitmap*/, /* special layout! */
- RET_BCO )
+INFO_TABLE_RET( stg_ctoi_D1, RET_BCO )
{
Sp_adj(-1) - SIZEOF_DOUBLE;
D_[Sp + WDS(1)] = D1;
/*
* When the returned value is in L1
*/
-INFO_TABLE_RET( stg_ctoi_L1,
- 0/*size*/, 0/*bitmap*/, /* special layout! */
- RET_BCO )
+INFO_TABLE_RET( stg_ctoi_L1, RET_BCO )
{
Sp_adj(-1) - 8;
L_[Sp + WDS(1)] = L1;
/*
* When the returned value is a void
*/
-INFO_TABLE_RET( stg_ctoi_V,
- 0/*size*/, 0/*bitmap*/, /* special layout! */
- RET_BCO )
+INFO_TABLE_RET( stg_ctoi_V, RET_BCO )
{
Sp_adj(-1);
Sp(0) = stg_gc_void_info;
* should apply the BCO on the stack to its arguments, also on the
* stack.
*/
-INFO_TABLE_RET( stg_apply_interp,
- 0/*size*/, 0/*bitmap*/, /* special layout! */
- RET_BCO )
+INFO_TABLE_RET( stg_apply_interp, RET_BCO )
{
/* Just in case we end up in here... (we shouldn't) */
jump stg_yield_to_interpreter;
Returning from the STG world.
-------------------------------------------------------------------------- */
+INFO_TABLE_RET( stg_stop_thread, STOP_FRAME,
#if defined(PROFILING)
-#define STOP_THREAD_BITMAP 3
-#define STOP_THREAD_WORDS 2
-#else
-#define STOP_THREAD_BITMAP 0
-#define STOP_THREAD_WORDS 0
+ W_ unused,
+ W_ unused
#endif
-
-INFO_TABLE_RET( stg_stop_thread, STOP_THREAD_WORDS, STOP_THREAD_BITMAP,
- STOP_FRAME)
+)
{
/*
The final exit.
results that comes back.
------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_forceIO, 0/*size*/, 0/*bitmap*/, RET_SMALL)
+INFO_TABLE_RET( stg_forceIO, RET_SMALL)
#ifdef REG_R1
{
is a register or not.
------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_noforceIO, 0/*size*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_noforceIO, RET_SMALL )
#ifdef REG_R1
{
#ifdef PROFILING
#define SAVE_CCCS(fs) StgHeader_ccs(Sp-fs) = W_[CCCS]
#define GET_SAVED_CCCS W_[CCCS] = StgHeader_ccs(Sp)
-#define RET_BITMAP 3
-#define RET_FRAMESIZE 2
+#define RET_PARAMS W_ unused1, W_ unused2
#else
#define SAVE_CCCS(fs) /* empty */
#define GET_SAVED_CCCS /* empty */
-#define RET_BITMAP 0
-#define RET_FRAMESIZE 0
+#define RET_PARAMS
#endif
#define SELECTOR_CODE_UPD(offset) \
- INFO_TABLE_RET(stg_sel_ret_##offset##_upd, RET_FRAMESIZE, RET_BITMAP, RET_SMALL) \
+ INFO_TABLE_RET(stg_sel_ret_##offset##_upd, RET_SMALL, RET_PARAMS) \
{ \
R1 = StgClosure_payload(R1,offset); \
GET_SAVED_CCCS; \
SELECTOR_CODE_UPD(15)
#define SELECTOR_CODE_NOUPD(offset) \
- INFO_TABLE_RET(stg_sel_ret_##offset##_noupd, RET_FRAMESIZE, RET_BITMAP, RET_SMALL) \
+ INFO_TABLE_RET(stg_sel_ret_##offset##_noupd, RET_SMALL, RET_PARAMS) \
{ \
R1 = StgClosure_payload(R1,offset); \
GET_SAVED_CCCS; \
}
#if defined(PROFILING)
-#define UPD_FRAME_BITMAP 3
-#define UPD_FRAME_WORDS 3
+#define UPD_FRAME_PARAMS W_ unused1, W_ unused2, "ptr" W_ unused3
#else
-#define UPD_FRAME_BITMAP 0
-#define UPD_FRAME_WORDS 1
+#define UPD_FRAME_PARAMS "ptr" W_ unused1
#endif
/* this bitmap indicates that the first word of an update frame is a
* there's a cost-centre-stack in there too).
*/
-INFO_TABLE_RET( stg_upd_frame,
- UPD_FRAME_WORDS, UPD_FRAME_BITMAP, UPDATE_FRAME)
+INFO_TABLE_RET( stg_upd_frame, UPDATE_FRAME, UPD_FRAME_PARAMS)
UPD_FRAME_ENTRY_TEMPLATE
-INFO_TABLE_RET( stg_marked_upd_frame,
- UPD_FRAME_WORDS, UPD_FRAME_BITMAP, UPDATE_FRAME)
+INFO_TABLE_RET( stg_marked_upd_frame, UPDATE_FRAME, UPD_FRAME_PARAMS)
UPD_FRAME_ENTRY_TEMPLATE
-- generate an apply function
-- args is a list of 'p', 'n', 'f', 'd' or 'l'
+formalParam :: ArgRep -> Int -> Doc
+formalParam V _ = empty
+formalParam arg n =
+ formalParamType arg <> space <>
+ text "arg" <> int n <> text ", "
+formalParamType arg | isPtr arg = text "\"ptr\"" <> space <> argRep arg
+ | otherwise = argRep arg
+
+argRep F = text "F_"
+argRep D = text "D_"
+argRep L = text "L_"
+argRep _ = text "W_"
genApply regstatus args =
let
in
vcat [
text "INFO_TABLE_RET(" <> mkApplyName args <> text ", " <>
- int all_args_size <> text "/*framsize*/," <>
- int (fromIntegral (mkBitmap args)) <> text "/*bitmap*/, " <>
- text "RET_SMALL)\n{",
+ text "RET_SMALL, " <> (cat $ zipWith formalParam args [1..]) <>
+ text ")\n{",
nest 4 (vcat [
text "W_ info;",
text "W_ arity;",
projects / ghc-hetmet.git / commitdiff