X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Fcmm%2FCmmInfo.hs;h=314a9ad77e29ec1517443d2e616f494838aeacad;hb=649d5ed52989f429d10283940793a06111aa8468;hp=5937dd4fb9debf2acb72124bc6bc8e61829693ff;hpb=d31dfb32ea936c22628b508c28a36c12e631430a;p=ghc-hetmet.git diff --git a/compiler/cmm/CmmInfo.hs b/compiler/cmm/CmmInfo.hs index 5937dd4..314a9ad 100644 --- a/compiler/cmm/CmmInfo.hs +++ b/compiler/cmm/CmmInfo.hs @@ -1,3 +1,10 @@ +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module CmmInfo ( cmmToRawCmm, mkInfoTable @@ -7,7 +14,6 @@ module CmmInfo ( import Cmm import CmmUtils -import PprCmm import CLabel import MachOp @@ -21,7 +27,6 @@ import SMRep import Constants import StaticFlags -import DynFlags import Unique import UniqSupply import Panic @@ -71,78 +76,73 @@ cmmToRawCmm cmm = do mkInfoTable :: Unique -> CmmTop -> [RawCmmTop] mkInfoTable uniq (CmmData sec dat) = [CmmData sec dat] -mkInfoTable uniq (CmmProc info entry_label arguments blocks) = +mkInfoTable uniq (CmmProc (CmmInfo _ _ 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 - where - fun_extra_bits = - [packHalfWordsCLit fun_type fun_arity] ++ - srt_label ++ - case pap_bitmap of + -- Code without an info table. Easy. + CmmNonInfoTable -> [CmmProc [] entry_label arguments blocks] + + 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 + in case type_info of + -- A function entry point. + 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] ++ + case pap_bitmap of ArgGen liveness -> + (if null srt_label then [mkIntCLit 0] else srt_label) ++ [makeRelativeRefTo info_label $ mkLivenessCLit liveness, 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) = 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 - 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 - where - std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap layout - info_label = entryLblToInfoLbl entry_label - (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 - where - std_info = mkStdInfoTable ty_prof cl_prof type_tag srt_bitmap (mkWordCLit offset) - info_label = entryLblToInfoLbl entry_label - (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 - where - 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, 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 + _ -> srt_label + std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap + layout + (srt_label, srt_bitmap) = mkSRTLit info_label srt + layout = packHalfWordsCLit ptrs nptrs + + -- A constructor. + ConstrInfo (ptrs, nptrs) con_tag descr -> + mkInfoTableAndCode info_label std_info [con_name] entry_label + arguments blocks + where + std_info = mkStdInfoTable ty_prof' cl_prof' type_tag con_tag layout + con_name = makeRelativeRefTo info_label descr + layout = packHalfWordsCLit ptrs nptrs + + -- A thunk. + ThunkInfo (ptrs, nptrs) srt -> + mkInfoTableAndCode info_label std_info srt_label entry_label + arguments blocks + where + std_info = mkStdInfoTable ty_prof' cl_prof' type_tag srt_bitmap layout + (srt_label, srt_bitmap) = mkSRTLit info_label srt + layout = packHalfWordsCLit ptrs nptrs + + -- A selector thunk. + ThunkSelectorInfo offset srt -> + mkInfoTableAndCode info_label std_info [{- no SRT -}] entry_label + arguments blocks + where + std_info = mkStdInfoTable ty_prof' cl_prof' type_tag 0 (mkWordCLit offset) + + -- A continuation/return-point. + ContInfo stack_layout srt -> + liveness_data ++ + mkInfoTableAndCode info_label std_info srt_label entry_label + arguments blocks + where + std_info = mkStdInfoTable ty_prof' cl_prof' maybe_big_type_tag srt_bitmap + (makeRelativeRefTo info_label liveness_lit) + (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 @@ -150,23 +150,23 @@ mkInfoTableAndCode :: CLabel -> [CmmLit] -> [CmmLit] -> CLabel - -> CmmFormals - -> [CmmBasicBlock] + -> CmmFormalsWithoutKinds + -> ListGraph CmmStmt -> [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] - | null blocks -- No actual code; only the info table is significant + | ListGraph [] <- blocks -- No code; only the info table is significant = -- Use a zero place-holder in place of the -- entry-label in the info table [mkRODataLits info_lbl (zeroCLit : std_info ++ extra_bits)] | otherwise -- Separately emit info table (with the function entry = -- point as first entry) and the entry code - [mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits), - CmmProc [] entry_lbl args blocks] + [CmmProc [] entry_lbl args blocks, + mkDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits)] mkSRTLit :: CLabel -> C_SRT @@ -200,9 +200,11 @@ 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 @@ -214,14 +216,16 @@ mkLiveness uniq live = mkBits (reg:regs) = take sizeW bits ++ mkBits regs where sizeW = case reg of Nothing -> 1 - Just r -> machRepByteWidth (localRegRep r) `quot` wORD_SIZE + Just r -> (machRepByteWidth (localRegRep 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 - KindNonPtr -> True - KindPtr -> False + GCKindNonPtr -> True + GCKindPtr -> False bits :: [Bool] bits = mkBits live @@ -273,3 +277,4 @@ mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit | otherwise = [] type_lit = packHalfWordsCLit cl_type srt_len +