emitClosureCodeAndInfoTable,
emitInfoTableAndCode,
dataConTagZ,
- getSRTInfo,
emitReturnTarget, emitAlgReturnTarget,
emitReturnInstr,
mkRetInfoTable,
getConstrTag,
infoTable, infoTableClosureType,
infoTablePtrs, infoTableNonPtrs,
- funInfoTable
+ funInfoTable, makeRelativeRefTo
) where
import Maybes
import Constants
-
-import Outputable
+import Panic
-------------------------------------------------------------------------
--
--
-- See includes/InfoTables.h
-emitClosureCodeAndInfoTable :: ClosureInfo -> [LocalReg] -> CgStmts -> Code
+emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code
emitClosureCodeAndInfoTable cl_info args body
= do { ty_descr_lit <-
if opt_SccProfilingOn
- then mkStringCLit (closureTypeDescr cl_info)
+ then do lit <- mkStringCLit (closureTypeDescr cl_info)
+ return (makeRelativeRefTo info_lbl lit)
else return (mkIntCLit 0)
; cl_descr_lit <-
if opt_SccProfilingOn
- then mkStringCLit cl_descr_string
+ then do lit <- mkStringCLit cl_descr_string
+ return (makeRelativeRefTo info_lbl lit)
else return (mkIntCLit 0)
; let std_info = mkStdInfoTable ty_descr_lit cl_descr_lit
cl_type srt_len layout_lit
; conName <-
if is_con
- then mkStringCLit $ fromJust conIdentity
+ then do cstr <- mkByteStringCLit $ fromJust conIdentity
+ return (makeRelativeRefTo info_lbl cstr)
else return (mkIntCLit 0)
- ; emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
+ ; panic "emitClosureCodeAndInfoTable" } --emitInfoTableAndCode info_lbl std_info (extra_bits conName) args blks }
where
info_lbl = infoTableLabelFromCI cl_info
Just con -> -- Constructors don't have an SRT
-- We keep the *zero-indexed* tag in the srt_len
-- field of the info table.
- (mkIntCLit 0, fromIntegral (dataConTagZ con), Just $ dataConIdentity con)
+ (mkIntCLit 0, fromIntegral (dataConTagZ con),
+ Just $ dataConIdentity con)
Nothing -> -- Not a constructor
let (label, len) = srtLabelAndLength srt info_lbl
emitReturnTarget
:: Name
-> CgStmts -- The direct-return code (if any)
- -> SRT
-> FCode CLabel
-emitReturnTarget name stmts srt
+emitReturnTarget name stmts
= do { live_slots <- getLiveStackSlots
; liveness <- buildContLiveness name live_slots
- ; srt_info <- getSRTInfo name srt
+ ; srt_info <- getSRTInfo
; let
cl_type | isBigLiveness liveness = rET_BIG
mkRetInfoTable info_lbl liveness srt_info cl_type
; blks <- cgStmtsToBlocks stmts
- ; emitInfoTableAndCode info_lbl std_info extra_bits args blks
+ ; panic "emitReturnTarget" --emitInfoTableAndCode info_lbl std_info extra_bits args blks
; return info_lbl }
where
args = {- trace "emitReturnTarget: missing args" -} []
:: CLabel -- info label
-> Liveness -- liveness
-> C_SRT -- SRT Info
- -> Int -- type (eg. rET_SMALL)
+ -> StgHalfWord -- type (eg. rET_SMALL)
-> ([CmmLit],[CmmLit])
mkRetInfoTable info_lbl liveness srt_info cl_type
= (std_info, srt_slot)
:: Name -- Just for its unique
-> [(ConTagZ, CgStmts)] -- Tagged branches
-> Maybe CgStmts -- Default branch (if any)
- -> SRT -- Continuation's SRT
-> Int -- family size
-> FCode (CLabel, SemiTaggingStuff)
-emitAlgReturnTarget name branches mb_deflt srt fam_sz
+emitAlgReturnTarget name branches mb_deflt fam_sz
= do { blks <- getCgStmts $
emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
-- NB: tag_expr is zero-based
- ; lbl <- emitReturnTarget name blks srt
+ ; lbl <- emitReturnTarget name blks
; return (lbl, Nothing) }
-- Nothing: the internal branches in the switch don't have
-- global labels, so we can't use them at the 'call site'
mkStdInfoTable
:: CmmLit -- closure type descr (profiling)
-> CmmLit -- closure descr (profiling)
- -> Int -- closure type
+ -> StgHalfWord -- closure type
-> StgHalfWord -- SRT length
-> CmmLit -- layout field
-> [CmmLit]
emitInfoTableAndCode
:: CLabel -- Label of info table
+ -> CmmInfo -- ...the info table
+ -> CmmFormals -- ...args
+ -> [CmmBasicBlock] -- ...and body
+ -> Code
+
+emitInfoTableAndCode info_lbl info args blocks
+ = emitProc info entry_lbl args blocks
+ where
+ entry_lbl = infoLblToEntryLbl info_lbl
+
+{-
+emitInfoTableAndCode
+ :: CLabel -- Label of info table
-> [CmmLit] -- ...its invariant part
-> [CmmLit] -- ...and its variant part
- -> [LocalReg] -- ...args
+ -> CmmFormals -- ...args
-> [CmmBasicBlock] -- ...and body
-> Code
where
entry_lbl = infoLblToEntryLbl info_lbl
+-}
-------------------------------------------------------------------------
--
--
-------------------------------------------------------------------------
--- There is just one SRT for each top level binding; all the nested
--- bindings use sub-sections of this SRT. The label is passed down to
--- the nested bindings via the monad.
-
-getSRTInfo :: Name -> SRT -> FCode C_SRT
-getSRTInfo id NoSRT = return NoC_SRT
-getSRTInfo id (SRT off len bmp)
- | len > hALF_WORD_SIZE_IN_BITS || bmp == [fromIntegral srt_escape]
- = do { srt_lbl <- getSRTLabel
- ; let srt_desc_lbl = mkSRTDescLabel id
- ; emitRODataLits srt_desc_lbl
- ( cmmLabelOffW srt_lbl off
- : mkWordCLit (fromIntegral len)
- : map mkWordCLit bmp)
- ; return (C_SRT srt_desc_lbl 0 srt_escape) }
-
- | otherwise
- = do { srt_lbl <- getSRTLabel
- ; return (C_SRT srt_lbl off (fromIntegral (head bmp))) }
- -- The fromIntegral converts to StgHalfWord
-
-srt_escape = (-1) :: StgHalfWord
-
srtLabelAndLength :: C_SRT -> CLabel -> (CmmLit, StgHalfWord)
srtLabelAndLength NoC_SRT _
= (zeroCLit, 0)
projects / ghc-hetmet.git / blobdiff