X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgInfoTbls.hs;h=6b7fcd563ea1e2ce866db7d002abb0915fbb32b4;hb=f96e9aa0444de0e673b3c4055c6e43299639bc5b;hp=fed5d804e9994e6cd4b4780c9841a00d5dd0eba4;hpb=9ff76535edb25ab7434284adddb5c64708ecb547;p=ghc-hetmet.git diff --git a/compiler/codeGen/CgInfoTbls.hs b/compiler/codeGen/CgInfoTbls.hs index fed5d80..6b7fcd5 100644 --- a/compiler/codeGen/CgInfoTbls.hs +++ b/compiler/codeGen/CgInfoTbls.hs @@ -10,7 +10,6 @@ module CgInfoTbls ( emitClosureCodeAndInfoTable, emitInfoTableAndCode, dataConTagZ, - getSRTInfo, emitReturnTarget, emitAlgReturnTarget, emitReturnInstr, mkRetInfoTable, @@ -21,7 +20,7 @@ module CgInfoTbls ( getConstrTag, infoTable, infoTableClosureType, infoTablePtrs, infoTableNonPtrs, - funInfoTable + funInfoTable, makeRelativeRefTo ) where @@ -46,8 +45,7 @@ import StaticFlags import Maybes import Constants - -import Outputable +import Panic ------------------------------------------------------------------------- -- @@ -72,15 +70,17 @@ import Outputable -- -- 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 @@ -89,10 +89,11 @@ emitClosureCodeAndInfoTable cl_info args body ; 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 @@ -110,7 +111,8 @@ emitClosureCodeAndInfoTable cl_info args body 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 @@ -185,12 +187,11 @@ mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry 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 @@ -200,7 +201,7 @@ emitReturnTarget name stmts srt 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" -} [] @@ -212,7 +213,7 @@ mkRetInfoTable :: 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) @@ -229,15 +230,14 @@ emitAlgReturnTarget :: 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' @@ -265,7 +265,7 @@ emitReturnInstr mkStdInfoTable :: CmmLit -- closure type descr (profiling) -> CmmLit -- closure descr (profiling) - -> Int -- closure type + -> StgHalfWord -- closure type -> StgHalfWord -- SRT length -> CmmLit -- layout field -> [CmmLit] @@ -392,9 +392,22 @@ funInfoTable info_ptr 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 @@ -416,6 +429,7 @@ emitInfoTableAndCode info_lbl std_info extra_bits args blocks where entry_lbl = infoLblToEntryLbl info_lbl +-} ------------------------------------------------------------------------- -- @@ -423,29 +437,6 @@ emitInfoTableAndCode info_lbl std_info extra_bits args blocks -- ------------------------------------------------------------------------- --- 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)