+{-# 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
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] ++
- case pap_bitmap of
+ 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]
_ -> srt_label
- 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 [{- no SRT -}] entry_label
- arguments blocks
- where
- std_info = mkStdInfoTable ty_prof cl_prof type_tag 0 (mkWordCLit offset)
- info_label = entryLblToInfoLbl entry_label
-
- -- 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
+ 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
| 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
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
projects / ghc-hetmet.git / blobdiff