summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorMichael D. Adams <t-madams@microsoft.com>2007-06-27 15:21:30 +0000
committerMichael D. Adams <t-madams@microsoft.com>2007-06-27 15:21:30 +0000
commitd31dfb32ea936c22628b508c28a36c12e631430a (patch)
tree76bc1a29b3c5646a8f552af820a81abff49aa492
parentc9c4951cc1d76273be541fc4791e131e418956aa (diff)
downloadhaskell-d31dfb32ea936c22628b508c28a36c12e631430a.tar.gz
Implemented and fixed bugs in CmmInfo handling
Diffstat
-rw-r--r--compiler/cmm/CLabel.hs8
-rw-r--r--compiler/cmm/Cmm.hs12
-rw-r--r--compiler/cmm/CmmCPS.hs12
-rw-r--r--compiler/cmm/CmmInfo.hs236
-rw-r--r--compiler/cmm/CmmParse.y49
-rw-r--r--compiler/cmm/PprC.hs10
-rw-r--r--compiler/cmm/PprCmm.hs19
-rw-r--r--compiler/codeGen/CgBindery.lhs12
-rw-r--r--compiler/codeGen/CgCallConv.hs64
-rw-r--r--compiler/codeGen/CgClosure.lhs2
-rw-r--r--compiler/codeGen/CgForeignCall.hs15
-rw-r--r--compiler/codeGen/CgInfoTbls.hs383
-rw-r--r--compiler/codeGen/CgProf.hs3
-rw-r--r--compiler/codeGen/CgUtils.hs29
-rw-r--r--compiler/codeGen/ClosureInfo.lhs9
-rw-r--r--compiler/main/HscMain.lhs7
-rw-r--r--compiler/nativeGen/AsmCodeGen.lhs21
-rw-r--r--compiler/nativeGen/MachCodeGen.hs4
-rw-r--r--includes/Cmm.h2
-rw-r--r--rts/Exception.cmm42
-rw-r--r--rts/HeapStackCheck.cmm48
-rw-r--r--rts/PrimOps.cmm150
-rw-r--r--rts/StgMiscClosures.cmm32
-rw-r--r--rts/StgStartup.cmm16
-rw-r--r--rts/StgStdThunks.cmm10
-rw-r--r--rts/Updates.cmm12
-rw-r--r--utils/genapply/GenApply.hs17
27 files changed, 607 insertions, 617 deletions
diff --git a/compiler/cmm/CLabel.hs b/compiler/cmm/CLabel.hs
index 94ae64af55..ffca61d0a0 100644
--- a/compiler/cmm/CLabel.hs
+++ b/compiler/cmm/CLabel.hs
@@ -521,6 +521,8 @@ externallyVisibleCLabel (CCS_Label _) = True
externallyVisibleCLabel (DynamicLinkerLabel _ _) = False
externallyVisibleCLabel (HpcTicksLabel _) = True
externallyVisibleCLabel HpcModuleNameLabel = False
+externallyVisibleCLabel (LargeBitmapLabel _) = False
+externallyVisibleCLabel (LargeSRTLabel _) = False
-- -----------------------------------------------------------------------------
-- Finding the "type" of a CLabel
@@ -702,7 +704,11 @@ pprCLbl (CaseLabel u CaseDefault)
= 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
diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 903853489f..530fab570d 100644
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -9,9 +9,10 @@
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,
@@ -133,12 +134,14 @@ data ClosureTypeInfo
-- 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
-----------------------------------------------------------------------------
@@ -161,7 +164,7 @@ data CmmStmt
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
@@ -184,6 +187,7 @@ type CmmActuals = [(CmmActual,MachHint)]
type CmmFormal = LocalReg
type CmmHintFormals = [(CmmFormal,MachHint)]
type CmmFormals = [CmmFormal]
+data CmmSafety = CmmUnsafe | CmmSafe C_SRT
{-
Discussion
diff --git a/compiler/cmm/CmmCPS.hs b/compiler/cmm/CmmCPS.hs
index be9f474cbe..b6c57eea9d 100644
--- a/compiler/cmm/CmmCPS.hs
+++ b/compiler/cmm/CmmCPS.hs
@@ -70,9 +70,9 @@ cmmCPS dflags abstractC = do
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
@@ -85,10 +85,10 @@ force_gc_block old_info block_id fun_label formals blocks =
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
@@ -361,9 +361,7 @@ applyStackFormat formats (Continuation (Left srt) label formals blocks) =
-- 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"
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs
index ab46f1e58d..5937dd4fb9 100644
--- a/compiler/cmm/CmmInfo.hs
+++ b/compiler/cmm/CmmInfo.hs
@@ -1,4 +1,5 @@
module CmmInfo (
+ cmmToRawCmm,
mkInfoTable
) where
@@ -6,30 +7,81 @@ module CmmInfo (
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] ++
@@ -37,71 +89,74 @@ mkInfoTable uniq (CmmProc info entry_label arguments blocks) =
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
@@ -113,27 +168,108 @@ mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks
[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
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index 7fc4c430f9..840b564a83 100644
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -231,7 +231,9 @@ info :: { ExtFCode (CLabel, CmmInfo) }
{ 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.
@@ -258,7 +260,7 @@ info :: { ExtFCode (CLabel, CmmInfo) }
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,
@@ -792,48 +794,6 @@ forkLabelledCodeEC ec = do
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
@@ -907,6 +867,7 @@ emitRetUT args = do
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
diff --git a/compiler/cmm/PprC.hs b/compiler/cmm/PprC.hs
index 8726547ae9..1a909f26d3 100644
--- a/compiler/cmm/PprC.hs
+++ b/compiler/cmm/PprC.hs
@@ -199,11 +199,11 @@ pprStmt stmt = case stmt of
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
@@ -220,8 +220,8 @@ pprStmt stmt = case stmt of
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
@@ -719,7 +719,7 @@ pprLocalReg (LocalReg uniq _ _) = char '_' <> ppr uniq
-- -----------------------------------------------------------------------------
-- Foreign Calls
-pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> C_SRT
+pprCall :: SDoc -> CCallConv -> CmmHintFormals -> CmmActuals -> CmmSafety
-> SDoc
pprCall ppr_fn cconv results args _
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index 97170a1c33..163c86bcc7 100644
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -117,7 +117,10 @@ pprTop (CmmData section ds) =
(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
@@ -128,13 +131,15 @@ pprTop (CmmData section ds) =
-- 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]
@@ -192,7 +197,7 @@ pprStmt stmt = case stmt of
-- 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) <>
@@ -200,14 +205,14 @@ pprStmt stmt = case stmt of
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)
diff --git a/compiler/codeGen/CgBindery.lhs b/compiler/codeGen/CgBindery.lhs
index 66ac9bf491..d5a2c69d60 100644
--- a/compiler/codeGen/CgBindery.lhs
+++ b/compiler/codeGen/CgBindery.lhs
@@ -19,6 +19,7 @@ module CgBindery (
nukeVolatileBinds,
nukeDeadBindings,
getLiveStackSlots,
+ getLiveStackBindings,
bindArgsToStack, rebindToStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
@@ -494,3 +495,14 @@ getLiveStackSlots
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}
diff --git a/compiler/codeGen/CgCallConv.hs b/compiler/codeGen/CgCallConv.hs
index b0fab89f82..34c9bee026 100644
--- a/compiler/codeGen/CgCallConv.hs
+++ b/compiler/codeGen/CgCallConv.hs
@@ -15,7 +15,7 @@ module CgCallConv (
mkArgDescr, argDescrType,
-- Liveness
- isBigLiveness, buildContLiveness, mkRegLiveness,
+ isBigLiveness, mkRegLiveness,
smallLiveness, mkLivenessCLit,
-- Register assignment
@@ -71,7 +71,7 @@ import Data.Bits
#include "../includes/StgFun.h"
-------------------------
-argDescrType :: ArgDescr -> Int
+argDescrType :: ArgDescr -> StgHalfWord
-- The "argument type" RTS field type
argDescrType (ArgSpec n) = n
argDescrType (ArgGen liveness)
@@ -98,7 +98,7 @@ argBits [] = []
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
@@ -133,6 +133,14 @@ stdPattern other = Nothing
--
-------------------------------------------------------------------------
+-- 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
@@ -284,56 +292,6 @@ getSequelAmode
-------------------------------------------------------------------------
--
--- 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
--
-------------------------------------------------------------------------
diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 2c72860a29..98e5b0d0f2 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -533,7 +533,7 @@ link_caf cl_info is_upd = do
-- 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
diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index b2ca5b166a..5d84da773c 100644
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -116,7 +116,7 @@ emitForeignCall' safety results target args vols srt
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
@@ -129,17 +129,20 @@ emitForeignCall' safety results target args vols srt
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)))
diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs
index 6b7fcd563e..6d270aef16 100644
--- a/compiler/codeGen/CgInfoTbls.hs
+++ b/compiler/codeGen/CgInfoTbls.hs
@@ -12,10 +12,7 @@ module CgInfoTbls (
dataConTagZ,
emitReturnTarget, emitAlgReturnTarget,
emitReturnInstr,
- mkRetInfoTable,
- mkStdInfoTable,
stdInfoTableSizeB,
- mkFunGenInfoExtraBits,
entryCode, closureInfoPtr,
getConstrTag,
infoTable, infoTableClosureType,
@@ -46,6 +43,8 @@ import StaticFlags
import Maybes
import Constants
import Panic
+import Util
+import Outputable
-------------------------------------------------------------------------
--
@@ -53,114 +52,80 @@ import Panic
--
-------------------------------------------------------------------------
--- 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"
-------------------------------------------------------------------------
--
@@ -168,63 +133,134 @@ mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry
--
-------------------------------------------------------------------------
--- 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
@@ -250,39 +286,11 @@ emitReturnInstr
= 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,
@@ -402,35 +410,6 @@ emitInfoTableAndCode info_lbl info 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
- -> [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
diff --git a/compiler/codeGen/CgProf.hs b/compiler/codeGen/CgProf.hs
index 3ba9d059fe..27ee54c50d 100644
--- a/compiler/codeGen/CgProf.hs
+++ b/compiler/codeGen/CgProf.hs
@@ -257,7 +257,7 @@ enterCostCentreThunk closure =
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
@@ -407,6 +407,7 @@ pushCostCentre result ccs cc
= emitRtsCallWithResult result PtrHint
SLIT("PushCostCentre") [(ccs,PtrHint),
(CmmLit (mkCCostCentre cc), PtrHint)]
+ False
bumpSccCount :: CmmExpr -> CmmStmt
bumpSccCount ccs
diff --git a/compiler/codeGen/CgUtils.hs b/compiler/codeGen/CgUtils.hs
index 13de2136f5..c48b584fda 100644
--- a/compiler/codeGen/CgUtils.hs
+++ b/compiler/codeGen/CgUtils.hs
@@ -269,18 +269,18 @@ emitIfThenElse cond then_part else_part
; 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'
@@ -288,12 +288,15 @@ 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
diff --git a/compiler/codeGen/ClosureInfo.lhs b/compiler/codeGen/ClosureInfo.lhs
index ad26b2ec7c..db4636866d 100644
--- a/compiler/codeGen/ClosureInfo.lhs
+++ b/compiler/codeGen/ClosureInfo.lhs
@@ -13,8 +13,9 @@ the STG paper.
\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,
@@ -188,7 +189,7 @@ data LambdaFormInfo
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
@@ -957,5 +958,3 @@ getTyDescription ty
getPredTyDescription (ClassP cl tys) = getOccString cl
getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
-
-
diff --git a/compiler/main/HscMain.lhs b/compiler/main/HscMain.lhs
index 0ae942cafa..f0fd95da23 100644
--- a/compiler/main/HscMain.lhs
+++ b/compiler/main/HscMain.lhs
@@ -76,6 +76,7 @@ import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import CmmParse ( parseCmmFile )
import CmmCPS
+import CmmInfo
import CodeOutput ( codeOutput )
import NameEnv ( emptyNameEnv )
@@ -605,7 +606,8 @@ hscCompile cgguts
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
@@ -721,7 +723,8 @@ hscCmmFile dflags filename = do
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
diff --git a/compiler/nativeGen/AsmCodeGen.lhs b/compiler/nativeGen/AsmCodeGen.lhs
index f954d524c9..a04c5c7527 100644
--- a/compiler/nativeGen/AsmCodeGen.lhs
+++ b/compiler/nativeGen/AsmCodeGen.lhs
@@ -429,9 +429,6 @@ fixAssigns stmts =
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]
@@ -444,24 +441,6 @@ fixAssign (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]
-- -----------------------------------------------------------------------------
diff --git a/compiler/nativeGen/MachCodeGen.hs b/compiler/nativeGen/MachCodeGen.hs
index 154eed866e..1d1cfa1596 100644
--- a/compiler/nativeGen/MachCodeGen.hs
+++ b/compiler/nativeGen/MachCodeGen.hs
@@ -3182,13 +3182,13 @@ outOfLineFloatOp mop res args
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
diff --git a/includes/Cmm.h b/includes/Cmm.h
index c238a84238..b23a37be04 100644
--- a/includes/Cmm.h
+++ b/includes/Cmm.h
@@ -524,7 +524,7 @@
__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; \
diff --git a/rts/Exception.cmm b/rts/Exception.cmm
index 346c9499eb..a0a6db4fc7 100644
--- a/rts/Exception.cmm
+++ b/rts/Exception.cmm
@@ -47,8 +47,7 @@
-------------------------------------------------------------------------- */
-INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
- 0/*framesize*/, 0/*bitmap*/, RET_SMALL )
+INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret, RET_SMALL )
{
CInt r;
@@ -73,7 +72,7 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
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) {
@@ -106,8 +105,7 @@ INFO_TABLE_RET( stg_unblockAsyncExceptionszh_ret,
#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;
@@ -165,7 +163,7 @@ unblockAsyncExceptionszh_fast
* 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) {
@@ -229,7 +227,7 @@ killThreadzh_fast
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",
@@ -260,22 +258,16 @@ killThreadzh_fast
#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;
@@ -347,7 +339,7 @@ section "data" {
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);
@@ -377,7 +369,7 @@ raisezh_fast
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
@@ -391,8 +383,8 @@ retry_pop_stack:
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") [];
@@ -409,7 +401,7 @@ retry_pop_stack:
} 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;
@@ -433,7 +425,7 @@ retry_pop_stack:
// 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;
@@ -491,7 +483,7 @@ retry_pop_stack:
} 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;
diff --git a/rts/HeapStackCheck.cmm b/rts/HeapStackCheck.cmm
index e9ddf5b69e..75f14184a9 100644
--- a/rts/HeapStackCheck.cmm
+++ b/rts/HeapStackCheck.cmm
@@ -108,7 +108,7 @@
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);
@@ -430,7 +430,7 @@ stg_gc_noregs
/*-- 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));
@@ -438,7 +438,7 @@ INFO_TABLE_RET( stg_gc_void, 0/*framesize*/, 0/*bitmap*/, RET_SMALL)
/*-- 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);
@@ -456,7 +456,7 @@ stg_gc_unpt_r1
/*-- 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);
@@ -473,7 +473,7 @@ stg_gc_unbx_r1
/*-- 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);
@@ -490,17 +490,7 @@ stg_gc_f1
/*-- 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;
@@ -518,17 +508,7 @@ stg_gc_d1
/*-- 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;
@@ -545,7 +525,7 @@ stg_gc_l1
/*-- 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))
@@ -642,7 +622,7 @@ __stg_gc_fun
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);
@@ -729,7 +709,7 @@ INFO_TABLE_RET( stg_gc_fun, 0/*framesize*/, 0/*bitmap*/, RET_FUN )
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;
@@ -830,7 +810,7 @@ stg_block_1
*
* -------------------------------------------------------------------------- */
-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);
@@ -855,7 +835,7 @@ stg_block_takemvar
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);
@@ -902,7 +882,7 @@ stg_block_blackhole
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);
@@ -928,7 +908,7 @@ stg_block_throwto
}
#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;
diff --git a/rts/PrimOps.cmm b/rts/PrimOps.cmm
index 800f93ed89..ad761ab2e4 100644
--- a/rts/PrimOps.cmm
+++ b/rts/PrimOps.cmm
@@ -49,7 +49,7 @@ newByteArrayzh_fast
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;
@@ -73,7 +73,7 @@ newPinnedByteArrayzh_fast
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
@@ -97,7 +97,7 @@ newArrayzh_fast
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]);
@@ -676,7 +676,7 @@ gcdIntzh_fast
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 */
@@ -687,7 +687,9 @@ gcdIntzh_fast
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));
@@ -768,7 +770,7 @@ cmpIntegerzh_fast
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;
@@ -891,7 +893,7 @@ forkzh_fast
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") [];
@@ -914,7 +916,7 @@ forkOnzh_fast
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") [];
@@ -951,7 +953,7 @@ isCurrentThreadBoundzh_fast
{
/* no args */
W_ r;
- r = foreign "C" isThreadBound(CurrentTSO) [];
+ (r) = foreign "C" isThreadBound(CurrentTSO) [];
RET_N(r);
}
@@ -970,25 +972,19 @@ isCurrentThreadBoundzh_fast
// 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;
@@ -998,7 +994,7 @@ INFO_TABLE_RET(stg_catch_retry_frame,
} 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);
@@ -1012,28 +1008,22 @@ INFO_TABLE_RET(stg_catch_retry_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 {
@@ -1054,7 +1044,7 @@ INFO_TABLE_RET(stg_atomically_frame,
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);
@@ -1064,7 +1054,7 @@ INFO_TABLE_RET(stg_atomically_frame,
} 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;
@@ -1073,7 +1063,7 @@ INFO_TABLE_RET(stg_atomically_frame,
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);
@@ -1082,9 +1072,11 @@ INFO_TABLE_RET(stg_atomically_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); )
@@ -1092,7 +1084,7 @@ INFO_TABLE_RET(stg_atomically_waiting_frame,
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);
@@ -1101,7 +1093,7 @@ INFO_TABLE_RET(stg_atomically_waiting_frame,
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);
@@ -1117,29 +1109,23 @@ INFO_TABLE_RET(stg_atomically_waiting_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;
@@ -1149,7 +1135,7 @@ INFO_TABLE_RET(stg_catch_stm_frame,
} 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;
@@ -1188,7 +1174,7 @@ atomicallyzh_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 */
@@ -1216,7 +1202,7 @@ catchSTMzh_fast
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 */
@@ -1239,7 +1225,7 @@ catchRetryzh_fast
/* 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 */
@@ -1269,11 +1255,11 @@ retryzh_fast
// 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
@@ -1283,7 +1269,7 @@ retry_pop_stack:
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);
@@ -1305,12 +1291,12 @@ retry_pop_stack:
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;
@@ -1323,7 +1309,7 @@ retry_pop_stack:
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;
@@ -1358,7 +1344,7 @@ newTVarzh_fast
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);
}
@@ -1374,7 +1360,7 @@ readTVarzh_fast
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);
}
@@ -1481,7 +1467,7 @@ takeMVarzh_fast
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
@@ -1520,10 +1506,10 @@ takeMVarzh_fast
#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
@@ -1562,7 +1548,7 @@ tryTakeMVarzh_fast
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
@@ -1594,10 +1580,10 @@ tryTakeMVarzh_fast
#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
@@ -1632,7 +1618,7 @@ putMVarzh_fast
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
@@ -1664,10 +1650,10 @@ putMVarzh_fast
#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
@@ -1705,7 +1691,7 @@ tryPutMVarzh_fast
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
@@ -1730,10 +1716,10 @@ tryPutMVarzh_fast
#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
@@ -1772,7 +1758,7 @@ makeStableNamezh_fast
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.
@@ -1795,7 +1781,7 @@ makeStablePtrzh_fast
/* 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);
}
@@ -2010,7 +1996,7 @@ delayzh_fast
#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;
@@ -2030,7 +2016,7 @@ delayzh_fast
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 */
diff --git a/rts/StgMiscClosures.cmm b/rts/StgMiscClosures.cmm
index e532e51a53..e092e3fdc0 100644
--- a/rts/StgMiscClosures.cmm
+++ b/rts/StgMiscClosures.cmm
@@ -57,9 +57,7 @@ stg_interp_constr_entry
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;
@@ -70,9 +68,7 @@ INFO_TABLE_RET( stg_ctoi_R1p,
/*
* 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;
@@ -83,9 +79,7 @@ INFO_TABLE_RET( stg_ctoi_R1unpt,
/*
* 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;
@@ -96,9 +90,7 @@ INFO_TABLE_RET( stg_ctoi_R1n,
/*
* 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;
@@ -109,9 +101,7 @@ INFO_TABLE_RET( stg_ctoi_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;
@@ -122,9 +112,7 @@ INFO_TABLE_RET( stg_ctoi_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;
@@ -135,9 +123,7 @@ INFO_TABLE_RET( stg_ctoi_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;
@@ -149,9 +135,7 @@ INFO_TABLE_RET( stg_ctoi_V,
* 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;
diff --git a/rts/StgStartup.cmm b/rts/StgStartup.cmm
index 2d83a676c0..5b0f7e2a5f 100644
--- a/rts/StgStartup.cmm
+++ b/rts/StgStartup.cmm
@@ -36,16 +36,12 @@
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.
@@ -148,7 +144,7 @@ stg_threadFinished
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
{
@@ -172,7 +168,7 @@ INFO_TABLE_RET( stg_forceIO, 0/*size*/, 0/*bitmap*/, RET_SMALL)
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
{
diff --git a/rts/StgStdThunks.cmm b/rts/StgStdThunks.cmm
index 342a6eb164..db9c254233 100644
--- a/rts/StgStdThunks.cmm
+++ b/rts/StgStdThunks.cmm
@@ -32,17 +32,15 @@
#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; \
@@ -85,7 +83,7 @@ SELECTOR_CODE_UPD(14)
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; \
diff --git a/rts/Updates.cmm b/rts/Updates.cmm
index a9f25b76fb..7ebade0aea 100644
--- a/rts/Updates.cmm
+++ b/rts/Updates.cmm
@@ -45,11 +45,9 @@
}
#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
@@ -57,11 +55,9 @@
* 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
diff --git a/utils/genapply/GenApply.hs b/utils/genapply/GenApply.hs
index 1a03140521..b7cc6dd53c 100644
--- a/utils/genapply/GenApply.hs
+++ b/utils/genapply/GenApply.hs
@@ -336,6 +336,18 @@ genMkPAP regstatus macro jump ticker disamb
-- 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
@@ -345,9 +357,8 @@ genApply regstatus args =
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;",
View Lorry Controller Status