diff options
Diffstat (limited to 'compiler/cmm/CmmInfo.hs')
| -rw-r--r-- | compiler/cmm/CmmInfo.hs | 46 |
1 files changed, 25 insertions, 21 deletions
diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 6aa4d6cbfa..dec6b5d09d 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -155,7 +155,7 @@ type InfoTableContents = ( [CmmLit] -- The standard part mkInfoTableContents :: DynFlags -> CmmInfoTable - -> Maybe StgHalfWord -- Override default RTS type tag? + -> Maybe Int -- Override default RTS type tag? -> UniqSM ([RawCmmDecl], -- Auxiliary top decls InfoTableContents) -- Info tbl + extra bits @@ -178,22 +178,19 @@ mkInfoTableContents dflags ; let std_info = mkStdInfoTable dflags prof_lits rts_tag srt_bitmap liveness_lit rts_tag | Just tag <- mb_rts_tag = tag - | null liveness_data = rET_SMALL dflags -- Fits in extra_bits - | otherwise = rET_BIG dflags -- Does not; extra_bits is - -- a label + | 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 layout = packHalfWordsCLit - dflags - (toStgHalfWord dflags (toInteger ptrs)) - (toStgHalfWord dflags (toInteger nonptrs)) + = do { let layout = packIntsCLit dflags ptrs nonptrs ; (prof_lits, prof_data) <- mkProfLits dflags prof ; let (srt_label, srt_bitmap) = mkSRTLit dflags srt ; (mb_srt_field, mb_layout, extra_bits, ct_data) <- mk_pieces closure_type srt_label ; let std_info = mkStdInfoTable dflags prof_lits - (mb_rts_tag `orElse` rtsClosureType dflags smrep) + (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)) } @@ -205,24 +202,25 @@ mkInfoTableContents dflags , [RawCmmDecl]) -- Auxiliary data decls mk_pieces (Constr con_tag con_descr) _no_srt -- A data constructor = do { (descr_lit, decl) <- newStringLit con_descr - ; return (Just con_tag, Nothing, [descr_lit], [decl]) } + ; return ( Just (toStgHalfWord dflags (fromIntegral con_tag)) + , Nothing, [descr_lit], [decl]) } mk_pieces Thunk srt_label = return (Nothing, Nothing, srt_label, []) mk_pieces (ThunkSelector offset) _no_srt - = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags offset), [], []) + = return (Just (toStgHalfWord dflags 0), Just (mkWordCLit dflags (fromIntegral offset)), [], []) -- Layout known (one free var); we use the layout field for offset mk_pieces (Fun arity (ArgSpec fun_type)) srt_label - = do { let extra_bits = packHalfWordsCLit dflags fun_type arity : srt_label + = do { let extra_bits = packIntsCLit dflags fun_type arity : srt_label ; return (Nothing, Nothing, extra_bits, []) } mk_pieces (Fun arity (ArgGen arg_bits)) srt_label = do { (liveness_lit, liveness_data) <- mkLivenessBits dflags arg_bits - ; let fun_type | null liveness_data = aRG_GEN dflags - | otherwise = aRG_GEN_BIG dflags - extra_bits = [ packHalfWordsCLit dflags fun_type arity + ; let fun_type | null liveness_data = aRG_GEN + | otherwise = aRG_GEN_BIG + extra_bits = [ packIntsCLit dflags fun_type arity , srt_lit, liveness_lit, slow_entry ] ; return (Nothing, Nothing, extra_bits, liveness_data) } where @@ -233,9 +231,14 @@ mkInfoTableContents dflags mk_pieces BlackHole _ = panic "mk_pieces: BlackHole" - mkInfoTableContents _ _ _ = panic "mkInfoTableContents" -- NonInfoTable dealt with earlier +packIntsCLit :: DynFlags -> Int -> Int -> CmmLit +packIntsCLit dflags a b = packHalfWordsCLit dflags + (toStgHalfWord dflags (fromIntegral a)) + (toStgHalfWord dflags (fromIntegral b)) + + mkSRTLit :: DynFlags -> C_SRT -> ([CmmLit], -- srt_label, if any @@ -314,7 +317,7 @@ mkLivenessBits dflags liveness [mkRODataLits bitmap_lbl lits]) } | otherwise -- Fits in one word - = return (mkWordCLit dflags bitmap_word, []) + = return (mkStgWordCLit dflags bitmap_word, []) where n_bits = length liveness @@ -328,7 +331,8 @@ mkLivenessBits dflags liveness bitmap_word = toStgWord dflags (fromIntegral n_bits) .|. (small_bitmap `shiftL` bITMAP_BITS_SHIFT dflags) - lits = mkWordCLit dflags (toStgWord dflags (fromIntegral n_bits)) : map (mkWordCLit dflags) bitmap + lits = mkWordCLit dflags (fromIntegral n_bits) + : map (mkStgWordCLit dflags) bitmap -- The first word is the size. The structure must match -- StgLargeBitmap in includes/rts/storage/InfoTable.h @@ -348,8 +352,8 @@ mkLivenessBits dflags liveness mkStdInfoTable :: DynFlags -> (CmmLit,CmmLit) -- Closure type descr and closure descr (profiling) - -> StgHalfWord -- Closure RTS tag - -> StgHalfWord -- SRT length + -> Int -- Closure RTS tag + -> StgHalfWord -- SRT length -> CmmLit -- layout field -> [CmmLit] @@ -365,7 +369,7 @@ mkStdInfoTable dflags (type_descr, closure_descr) cl_type srt_len layout_lit | dopt Opt_SccProfilingOn dflags = [type_descr, closure_descr] | otherwise = [] - type_lit = packHalfWordsCLit dflags cl_type srt_len + type_lit = packHalfWordsCLit dflags (toStgHalfWord dflags (fromIntegral cl_type)) srt_len ------------------------------------------------------------------------- -- |