Commit 190d8e13 authored by Simon Marlow's avatar Simon Marlow

fix type tags for RTS-defined info tables

parent 493c12ff
......@@ -77,7 +77,7 @@ mkInfoTable (CmmProc (CmmInfo _ _ info) entry_label blocks)
= return [CmmProc Nothing entry_label blocks]
| CmmInfoTable { cit_lbl = info_lbl } <- info
= do { (top_decls, info_cts) <- mkInfoTableContents info
= do { (top_decls, info_cts) <- mkInfoTableContents info Nothing
; return (top_decls ++
mkInfoTableAndCode info_lbl info_cts
entry_label blocks) }
......@@ -89,30 +89,37 @@ type InfoTableContents = ( [CmmLit] -- The standard part
-- These Lits have *not* had mkRelativeTo applied to them
mkInfoTableContents :: CmmInfoTable
-> UniqSM ([RawCmmTop], -- Auxiliary top decls
-> Maybe StgHalfWord -- override default RTS type tag?
-> UniqSM ([RawCmmTop], -- Auxiliary top decls
InfoTableContents) -- Info tbl + extra bits
mkInfoTableContents info@(CmmInfoTable { cit_rep = RTSRep ty rep }) _
= mkInfoTableContents info{cit_rep = rep} (Just ty)
mkInfoTableContents (CmmInfoTable { cit_lbl = info_lbl
, cit_rep = smrep
, cit_prof = prof, cit_srt = srt })
, cit_prof = prof
, cit_srt = srt }) mb_rts_tag
| StackRep frame <- smrep
= do { (prof_lits, prof_data) <- mkProfLits prof
= do { (prof_lits, prof_data) <- mkProfLits prof
; let (srt_label, srt_bitmap) = mkSRTLit srt
; (liveness_lit, liveness_data) <- mkLivenessBits frame
; let (extra_bits, srt_bitmap) = mkSRTLit srt
; let
std_info = mkStdInfoTable prof_lits rts_tag srt_bitmap liveness_lit
rts_tag | null liveness_data = rET_SMALL -- Fits in extra_bits
| otherwise = rET_BIG -- Does not; extra_bits is
-- a label
; return (prof_data ++ liveness_data, (std_info, extra_bits)) }
rts_tag | Just tag <- mb_rts_tag = tag
| null liveness_data = rET_SMALL -- Fits in extra_bits
| otherwise = rET_BIG -- Does not; extra_bits is
-- a label
; return (prof_data ++ liveness_data, (std_info, srt_label)) }
| HeapRep _ ptrs nonptrs closure_type <- smrep
= do { let rts_tag = rtsClosureType smrep
layout = packHalfWordsCLit ptrs nonptrs
(srt_label, srt_bitmap) = mkSRTLit srt
= do { let layout = packHalfWordsCLit ptrs nonptrs
; (prof_lits, prof_data) <- mkProfLits prof
; (mb_srt_field, mb_layout, extra_bits, ct_data)
; let (srt_label, srt_bitmap) = mkSRTLit srt
; (mb_srt_field, mb_layout, extra_bits, ct_data)
<- mk_pieces closure_type srt_label
; let std_info = mkStdInfoTable prof_lits rts_tag
; let std_info = mkStdInfoTable prof_lits
(mb_rts_tag `orElse` rtsClosureType smrep)
(mb_srt_field `orElse` srt_bitmap)
(mb_layout `orElse` layout)
; return (prof_data ++ ct_data, (std_info, extra_bits)) }
......@@ -152,7 +159,8 @@ mkInfoTableContents (CmmInfoTable { cit_lbl = info_lbl
mk_pieces BlackHole _ = panic "mk_pieces: BlackHole"
mkInfoTableContents _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
mkInfoTableContents _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier
mkSRTLit :: C_SRT
-> ([CmmLit], -- srt_label, if any
......
......@@ -265,9 +265,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- ptrs, nptrs, closure type, description, type
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $11 $13
rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) Thunk
-- ToDo: Type tag $9 redundant
return (mkCmmEntryLabel pkg $3,
rep = mkRTSRep (fromIntegral $9) $
mkHeapRep False (fromIntegral $5)
(fromIntegral $7) Thunk
-- not really Thunk, but that makes the info table
-- we want.
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
, cit_prof = prof, cit_srt = NoC_SRT },
......@@ -277,11 +280,12 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- ptrs, nptrs, closure type, description, type, fun type
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $11 $13
rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
ty = Fun 0 -- Arity zero
(ArgSpec (fromIntegral $15))
-- ToDo: Type tag $9 redundant
return (mkCmmEntryLabel pkg $3,
ty = Fun 0 (ArgSpec (fromIntegral $15))
-- Arity zero, arg_type $15
rep = mkRTSRep (fromIntegral $9) $
mkHeapRep False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
, cit_prof = prof, cit_srt = NoC_SRT },
......@@ -289,32 +293,16 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
-- A variant with a non-zero arity (needed to write Main_main in Cmm)
| 'INFO_TABLE_FUN' '(' NAME ',' INT ',' INT ',' INT ',' STRING ',' STRING ',' INT ',' INT ')'
-- ptrs, nptrs, closure type, description, type, fun type, arity
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $11 $13
rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
ty = Fun (fromIntegral $17) -- Arity
(ArgSpec (fromIntegral $15))
-- ToDo: Type tag $9 redundant
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
, cit_prof = prof, cit_srt = NoC_SRT },
[]) }
-- we leave most of the fields zero here. This is only used
-- to generate the BCO info table in the RTS at the moment.
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
| 'INFO_TABLE_CONSTR' '(' NAME ',' INT ',' INT ',' INT ',' INT ',' STRING ',' STRING ')'
-- ptrs, nptrs, tag, closure type, description, type
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $13 $15
rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
ty = Constr (fromIntegral $9) -- Tag
ty = Constr (fromIntegral $9) -- Tag
(stringToWord8s $13)
-- ToDo: Type tag $11 redundant
return (mkCmmEntryLabel pkg $3,
rep = mkRTSRep (fromIntegral $11) $
mkHeapRep False (fromIntegral $5)
(fromIntegral $7) ty
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
, cit_prof = prof, cit_srt = NoC_SRT },
......@@ -327,10 +315,10 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- selector, closure type, description, type
{% withThisPackage $ \pkg ->
do let prof = profilingInfo $9 $11
rep = mkHeapRep False (fromIntegral $5) (fromIntegral $7) ty
ty = ThunkSelector (fromIntegral $5)
-- ToDo: Type tag $7 redundant
return (mkCmmEntryLabel pkg $3,
rep = mkRTSRep (fromIntegral $7) $
mkHeapRep False 0 0 ty
return (mkCmmEntryLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
, cit_prof = prof, cit_srt = NoC_SRT },
......@@ -340,9 +328,8 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
-- closure type (no live regs)
{% withThisPackage $ \pkg ->
do let prof = NoProfilingInfo
rep = mkStackRep []
-- ToDo: Type tag $5 redundant
return (mkCmmRetLabel pkg $3,
rep = mkRTSRep (fromIntegral $5) $ mkStackRep []
return (mkCmmRetLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
, cit_prof = prof, cit_srt = NoC_SRT },
......@@ -353,9 +340,9 @@ info :: { ExtFCode (CLabel, CmmInfoTable, [Maybe LocalReg]) }
{% withThisPackage $ \pkg ->
do live <- sequence (map (liftM Just) $7)
let prof = NoProfilingInfo
rep = mkStackRep []
-- ToDo: Type tag $5 redundant
return (mkCmmRetLabel pkg $3,
bitmap = mkLiveness live
rep = mkRTSRep (fromIntegral $5) $ mkStackRep bitmap
return (mkCmmRetLabel pkg $3,
CmmInfoTable { cit_lbl = mkCmmInfoLabel pkg $3
, cit_rep = rep
, cit_prof = prof, cit_srt = NoC_SRT },
......
......@@ -20,7 +20,7 @@ module SMRep (
IsStatic,
ClosureTypeInfo(..), ArgDescr(..), Liveness,
ConstrDescription,
mkHeapRep, blackHoleRep, mkStackRep,
mkHeapRep, blackHoleRep, mkStackRep, mkRTSRep,
isStaticRep, isStaticNoCafCon,
heapClosureSize,
......@@ -99,6 +99,10 @@ data SMRep
| StackRep -- Stack frame (RET_SMALL or RET_BIG)
Liveness
| RTSRep -- The RTS needs to declare info tables with specific
StgHalfWord -- type tags, so this form lets us override the default
SMRep -- tag for an SMRep.
-- | True <=> This is a static closure. Affects how we garbage-collect it.
-- Static closure have an extra static link field at the end.
type IsStatic = Bool
......@@ -159,9 +163,11 @@ mkHeapRep is_static ptr_wds nonptr_wds cl_type_info
hdr_size = closureTypeHdrSize cl_type_info
payload_size = ptr_wds + nonptr_wds
mkRTSRep :: StgHalfWord -> SMRep -> SMRep
mkRTSRep = RTSRep
mkStackRep :: [Bool] -> SMRep
mkStackRep = StackRep
mkStackRep liveness = StackRep liveness
blackHoleRep :: SMRep
blackHoleRep = HeapRep False 0 0 BlackHole
......@@ -198,11 +204,13 @@ thunkHdrSize = fixedHdrSize + smp_hdr
isStaticRep :: SMRep -> IsStatic
isStaticRep (HeapRep is_static _ _ _) = is_static
isStaticRep (StackRep {}) = False
isStaticRep (StackRep {}) = False
isStaticRep (RTSRep _ rep) = isStaticRep rep
nonHdrSize :: SMRep -> WordOff
nonHdrSize (HeapRep _ p np _) = p + np
nonHdrSize (StackRep bs) = length bs
nonHdrSize (RTSRep _ rep) = nonHdrSize rep
heapClosureSize :: SMRep -> WordOff
heapClosureSize (HeapRep _ p np ty) = closureTypeHdrSize ty + p + np
......@@ -229,6 +237,8 @@ closureTypeHdrSize ty = case ty of
-- | Derives the RTS closure type from an 'SMRep'
rtsClosureType :: SMRep -> StgHalfWord
rtsClosureType (RTSRep ty _) = ty
rtsClosureType (HeapRep False 1 0 Constr{}) = CONSTR_1_0
rtsClosureType (HeapRep False 0 1 Constr{}) = CONSTR_0_1
rtsClosureType (HeapRep False 2 0 Constr{}) = CONSTR_2_0
......@@ -312,6 +322,8 @@ instance Outputable SMRep where
ppr (StackRep bs) = ptext (sLit "StackRep") <+> ppr bs
ppr (RTSRep ty rep) = ptext (sLit "tag:") <> ppr ty <+> ppr rep
instance Outputable ArgDescr where
ppr (ArgSpec n) = ptext (sLit "ArgSpec") <+> integer (toInteger n)
ppr (ArgGen ls) = ptext (sLit "ArgGen") <+> ppr ls
......@@ -333,7 +345,6 @@ pprTypeInfo (ThunkSelector offset)
pprTypeInfo Thunk = ptext (sLit "Thunk")
pprTypeInfo BlackHole = ptext (sLit "BlackHole")
stringToWord8s :: String -> [Word8]
stringToWord8s s = map (fromIntegral . ord) s
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment