diff options
| -rw-r--r-- | compiler/cmm/CmmInfo.hs | 40 | ||||
| -rw-r--r-- | compiler/cmm/CmmParse.y | 65 | ||||
| -rw-r--r-- | compiler/cmm/SMRep.lhs | 19 |
3 files changed, 65 insertions, 59 deletions
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 4e2d976826..bea613e507 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -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 diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y index cd0c021db6..6f72388cd5 100644 --- a/compiler/cmm/CmmParse.y +++ b/compiler/cmm/CmmParse.y @@ -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 }, diff --git a/compiler/cmm/SMRep.lhs b/compiler/cmm/SMRep.lhs index 8ed35ec605..fd60544869 100644 --- a/compiler/cmm/SMRep.lhs +++ b/compiler/cmm/SMRep.lhs @@ -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 |