X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmInfo.hs;h=438f1227349c7009e76904ae672784c8e935c8a7;hb=df54e4b621b1d2a8e30b01b3e93494a515d09f48;hp=49a77e29fd348ea8ebf18a7e48329a2c7aee71c9;hpb=fd8d04119e849f9c713d3e697228846d93c5ca69;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 49a77e2..438f122 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -6,8 +6,10 @@ -- for details module CmmInfo ( + emptyContInfoTable, cmmToRawCmm, - mkInfoTable + mkInfoTable, + mkBareInfoTable ) where #include "HsVersions.h" @@ -16,7 +18,6 @@ import Cmm import CmmUtils import CLabel -import MachOp import Bitmap import ClosureInfo @@ -24,8 +25,10 @@ import CgInfoTbls import CgCallConv import CgUtils import SMRep +import ZipCfgCmmRep import Constants +import Outputable import StaticFlags import Unique import UniqSupply @@ -33,6 +36,13 @@ import Panic import Data.Bits +-- When we split at proc points, we need an empty info table. +emptyContInfoTable :: CmmInfo +emptyContInfoTable = + CmmInfo Nothing Nothing (CmmInfoTable False (ProfilingInfo zero zero) rET_SMALL + (ContInfo [] NoC_SRT)) + where zero = CmmInt 0 wordWidth + cmmToRawCmm :: [Cmm] -> IO [RawCmm] cmmToRawCmm cmm = do info_tbl_uniques <- mkSplitUniqSupply 'i' @@ -78,19 +88,20 @@ mkInfoTable :: Unique -> CmmTop -> [RawCmmTop] mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat] mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = case info of - -- | Code without an info table. Easy. + -- Code without an info table. Easy. CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks] - CmmInfoTable (ProfilingInfo ty_prof cl_prof) type_tag type_info -> + CmmInfoTable _ (ProfilingInfo ty_prof cl_prof) type_tag type_info -> let info_label = entryLblToInfoLbl entry_label - ty_prof' = makeRelativeRefTo info_label ty_prof - cl_prof' = makeRelativeRefTo info_label cl_prof + ty_prof' = makeRelativeRefTo info_label ty_prof + cl_prof' = makeRelativeRefTo info_label cl_prof in case type_info of - -- | A function entry point. - FunInfo (ptrs, nptrs) srt fun_type fun_arity pap_bitmap slow_entry -> + -- A function entry point. + FunInfo (ptrs, nptrs) srt fun_arity pap_bitmap slow_entry -> mkInfoTableAndCode info_label std_info fun_extra_bits entry_label arguments blocks where + fun_type = argDescrType pap_bitmap fun_extra_bits = [packHalfWordsCLit fun_type fun_arity] ++ case pap_bitmap of @@ -104,7 +115,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = (srt_label, srt_bitmap) = mkSRTLit info_label srt layout = packHalfWordsCLit ptrs nptrs - -- | A constructor. + -- A constructor. ConstrInfo (ptrs, nptrs) con_tag descr -> mkInfoTableAndCode info_label std_info [con_name] entry_label arguments blocks @@ -112,8 +123,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout con_name = makeRelativeRefTo info_label descr layout = packHalfWordsCLit ptrs nptrs - - -- | A thunk. + -- A thunk. ThunkInfo (ptrs, nptrs) srt -> mkInfoTableAndCode info_label std_info srt_label entry_label arguments blocks @@ -122,7 +132,7 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = (srt_label, srt_bitmap) = mkSRTLit info_label srt layout = packHalfWordsCLit ptrs nptrs - -- | A selector thunk. + -- A selector thunk. ThunkSelectorInfo offset srt -> mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label arguments blocks @@ -144,13 +154,24 @@ mkInfoTable uniq (CmmProc (CmmInfo _ _ info) entry_label arguments blocks) = else type_tag (srt_label, srt_bitmap) = mkSRTLit info_label srt +-- Generate a bare info table, not attached to any procedure. +mkBareInfoTable :: CLabel -> Unique -> CmmInfoTable -> [CmmTopZ] +mkBareInfoTable lbl uniq info = + case mkInfoTable uniq (CmmProc (CmmInfo Nothing Nothing info) lbl [] (ListGraph [])) of + [CmmProc d _ _ _] -> + ASSERT (tablesNextToCode) + [CmmData Data (d ++ [CmmDataLabel (entryLblToInfoLbl lbl)])] + [CmmData d s] -> [CmmData d s] + _ -> panic "mkBareInfoTable expected to produce only data" + + -- Handle the differences between tables-next-to-code -- and not tables-next-to-code mkInfoTableAndCode :: CLabel -> [CmmLit] -> [CmmLit] -> CLabel - -> CmmFormalsWithoutKinds + -> CmmFormals -> ListGraph CmmStmt -> [RawCmmTop] mkInfoTableAndCode info_lbl std_info extra_bits entry_lbl args blocks @@ -200,30 +221,29 @@ mkSRTLit info_label (C_SRT lbl off bitmap) = -- 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 + -> (CmmLit, [RawCmmTop], ClosureTypeTag) + -- ^ Returns: + -- 1. The bitmap (literal value or label) + -- 2. Large bitmap CmmData if needed + -- 3. 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) + else (mkWordCLit small_liveness, [], rET_SMALL) where mkBits [] = [] mkBits (reg:regs) = take sizeW bits ++ mkBits regs where sizeW = case reg of Nothing -> 1 - Just r -> (machRepByteWidth (localRegRep r) + wORD_SIZE - 1) + Just r -> (widthInBytes (typeWidth (localRegType r)) + wORD_SIZE - 1) `quot` wORD_SIZE -- number of words, rounded up bits = repeat $ is_non_ptr reg -- True <=> Non Ptr - is_non_ptr Nothing = True - is_non_ptr (Just reg) = - case localRegGCFollow reg of - GCKindNonPtr -> True - GCKindPtr -> False + is_non_ptr Nothing = True + is_non_ptr (Just reg) = not $ isGcPtrType (localRegType reg) bits :: [Bool] bits = mkBits live @@ -276,6 +296,3 @@ mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit type_lit = packHalfWordsCLit cl_type srt_len - -_unused :: FS.FastString -- stops a warning -_unused = undefined