Skip to content

GitLab

Commit d31dfb32 authored by Michael D. Adams's avatar Michael D. Adams
Browse files
Options

Implemented and fixed bugs in CmmInfo handling

parent c9c4951c
Hide whitespace changes
Inline Side-by-side
Showing with 607 additions and 617 deletions
compiler/cmm/CLabel.hs
View file @ d31dfb32
......@@ -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
......
compiler/cmm/Cmm.hs
View file @ d31dfb32
......@@ -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
......
compiler/cmm/CmmCPS.hs
View file @ d31dfb32
......@@ -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"
......
compiler/cmm/CmmInfo.hs
View file @ d31dfb32
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
compiler/cmm/CmmParse.y
View file @ d31dfb32
......@@ -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
......
compiler/cmm/PprC.hs
View file @ d31dfb32
......@@ -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 _
......
compiler/cmm/PprCmm.hs
View file @ d31dfb32
......@@ -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)
......
compiler/codeGen/CgBindery.lhs
View file @ d31dfb32
......@@ -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}
compiler/codeGen/CgCallConv.hs
View file @ d31dfb32
......@@ -15,7 +15,7 @@ module CgCallConv (
mkArgDescr, argDescrType,