----------------------------------------------------------------------------- -- -- Building info tables. -- -- (c) The University of Glasgow 2004 -- ----------------------------------------------------------------------------- module CgInfoTbls ( emitClosureCodeAndInfoTable, emitInfoTableAndCode, dataConTagZ, getSRTInfo, emitDirectReturnTarget, emitAlgReturnTarget, emitDirectReturnInstr, emitVectoredReturnInstr, mkRetInfoTable, mkStdInfoTable, stdInfoTableSizeB, mkFunGenInfoExtraBits, entryCode, closureInfoPtr, getConstrTag, infoTable, infoTableClosureType, infoTablePtrs, infoTableNonPtrs, funInfoTable, retVec ) where #include "HsVersions.h" import ClosureInfo ( ClosureInfo, closureTypeDescr, closureName, infoTableLabelFromCI, Liveness, closureValDescr, closureSRT, closureSMRep, closurePtrsSize, closureNonHdrSize, closureFunInfo, C_SRT(..), needsSRT, isConstrClosure_maybe, ArgDescr(..) ) import SMRep ( StgHalfWord, hALF_WORD_SIZE_IN_BITS, hALF_WORD_SIZE, WordOff, ByteOff, smRepClosureTypeInt, tablesNextToCode, rET_BIG, rET_SMALL, rET_VEC_BIG, rET_VEC_SMALL ) import CgBindery ( getLiveStackSlots ) import CgCallConv ( isBigLiveness, mkLivenessCLit, buildContLiveness, argDescrType, getSequelAmode, CtrlReturnConvention(..) ) import CgUtils ( mkStringCLit, packHalfWordsCLit, mkWordCLit, cmmOffsetB, cmmOffsetExprW, cmmLabelOffW, cmmOffsetW, emitDataLits, emitRODataLits, emitSwitch, cmmNegate, newTemp ) import CgMonad import CmmUtils ( mkIntCLit, zeroCLit ) import Cmm ( CmmStmt(..), CmmExpr(..), CmmLit(..), LocalReg, CmmBasicBlock, nodeReg ) import MachOp import CLabel import StgSyn ( SRT(..) ) import Name ( Name ) import DataCon ( DataCon, dataConTag, fIRST_TAG ) import Unique ( Uniquable(..) ) import DynFlags ( DynFlags(..), HscTarget(..) ) import StaticFlags ( opt_SccProfilingOn ) import ListSetOps ( assocDefault ) import Maybes ( isJust ) import Constants ( wORD_SIZE, sIZEOF_StgFunInfoExtraRev ) import Outputable ------------------------------------------------------------------------- -- -- Generating the info table and code for a closure -- ------------------------------------------------------------------------- -- Here we make a concrete info table, represented as a list of CmmAddr -- (it can't be simply a list of Word, because the SRT field is -- represented by a label+offset expression). -- With tablesNextToCode, the layout is -- -- -- -- -- Without tablesNextToCode, the layout of an info table is -- -- -- -- -- See includes/InfoTables.h emitClosureCodeAndInfoTable :: ClosureInfo -> [LocalReg] -> CgStmts -> Code emitClosureCodeAndInfoTable cl_info args body = do { ty_descr_lit <- if opt_SccProfilingOn then mkStringCLit (closureTypeDescr cl_info) else return (mkIntCLit 0) ; cl_descr_lit <- if opt_SccProfilingOn then mkStringCLit cl_descr_string else return (mkIntCLit 0) ; let std_info = mkStdInfoTable ty_descr_lit cl_descr_lit cl_type srt_len layout_lit ; blks <- cgStmtsToBlocks body ; emitInfoTableAndCode info_lbl std_info extra_bits args blks } where info_lbl = infoTableLabelFromCI cl_info cl_descr_string = closureValDescr cl_info cl_type = smRepClosureTypeInt (closureSMRep cl_info) srt = closureSRT cl_info needs_srt = needsSRT srt mb_con = isConstrClosure_maybe cl_info is_con = isJust mb_con (srt_label,srt_len) = case mb_con of 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)) Nothing -> -- Not a constructor srtLabelAndLength srt info_lbl ptrs = closurePtrsSize cl_info nptrs = size - ptrs size = closureNonHdrSize cl_info layout_lit = packHalfWordsCLit ptrs nptrs extra_bits | is_fun = fun_extra_bits | is_con = [] | needs_srt = [srt_label] | otherwise = [] maybe_fun_stuff = closureFunInfo cl_info is_fun = isJust maybe_fun_stuff (Just (arity, arg_descr)) = maybe_fun_stuff fun_extra_bits | ArgGen liveness <- arg_descr = [ fun_amode, srt_label, makeRelativeRefTo info_lbl $ mkLivenessCLit liveness, slow_entry ] | needs_srt = [fun_amode, srt_label] | otherwise = [fun_amode] slow_entry = makeRelativeRefTo info_lbl (CmmLabel slow_entry_label) slow_entry_label = mkSlowEntryLabel (closureName cl_info) fun_amode = packHalfWordsCLit fun_type arity fun_type = argDescrType arg_descr -- We keep the *zero-indexed* tag in the srt_len field of the info -- table of a data constructor. dataConTagZ :: DataCon -> ConTagZ dataConTagZ con = dataConTag con - fIRST_TAG -- A low-level way to generate the variable part of a fun-style info table. -- (must match fun_extra_bits above). Used by the C-- parser. mkFunGenInfoExtraBits :: Int -> Int -> CmmLit -> CmmLit -> CmmLit -> [CmmLit] mkFunGenInfoExtraBits fun_type arity srt_label liveness slow_entry = [ packHalfWordsCLit fun_type arity, srt_label, liveness, slow_entry ] ------------------------------------------------------------------------- -- -- Generating the info table and code for a return point -- ------------------------------------------------------------------------- -- Here's the layout of a return-point info table -- -- Tables next to code: -- -- -- -- -- ret-addr --> -- -- Not tables-next-to-code: -- -- ret-addr --> -- -- -- -- -- * The vector table is only present for vectored returns -- -- * The SRT slot is only there if either -- (a) there is SRT info to record, OR -- (b) if the return is vectored -- The latter (b) is necessary so that the vector is in a -- predictable place vectorSlot :: CmmExpr -> CmmExpr -> CmmExpr -- Get the vector slot from the info pointer vectorSlot info_amode zero_indexed_tag | tablesNextToCode = cmmOffsetExprW (cmmOffsetW info_amode (- (stdInfoTableSizeW + 2))) (cmmNegate zero_indexed_tag) -- The "2" is one for the SRT slot, and one more -- to get to the first word of the vector | otherwise = cmmOffsetExprW (cmmOffsetW info_amode (stdInfoTableSizeW + 2)) zero_indexed_tag -- The "2" is one for the entry-code slot and one for the SRT slot retVec :: CmmExpr -> CmmExpr -> CmmExpr -- Get a return vector from the info pointer retVec info_amode zero_indexed_tag = let slot = vectorSlot info_amode zero_indexed_tag #ifdef x86_64_TARGET_ARCH tableEntry = CmmMachOp (MO_S_Conv I32 I64) [CmmLoad slot I32] -- offsets are 32-bits on x86-64, due to the inability of -- the tools to handle 64-bit PC-relative relocations. See also -- PprMach.pprDataItem, and InfoTables.h:OFFSET_FIELD(). #else tableEntry = CmmLoad slot wordRep #endif in if tablesNextToCode then CmmMachOp (MO_Add wordRep) [tableEntry, info_amode] else tableEntry emitReturnTarget :: Name -> CgStmts -- The direct-return code (if any) -- (empty for vectored returns) -> [CmmLit] -- Vector of return points -- (empty for non-vectored returns) -> SRT -> FCode CLabel emitReturnTarget name stmts vector srt = do { live_slots <- getLiveStackSlots ; liveness <- buildContLiveness name live_slots ; srt_info <- getSRTInfo name srt ; let cl_type = case (null vector, isBigLiveness liveness) of (True, True) -> rET_BIG (True, False) -> rET_SMALL (False, True) -> rET_VEC_BIG (False, False) -> rET_VEC_SMALL (std_info, extra_bits) = mkRetInfoTable info_lbl liveness srt_info cl_type vector ; blks <- cgStmtsToBlocks stmts ; emitInfoTableAndCode info_lbl std_info extra_bits args blks ; return info_lbl } where args = {- trace "emitReturnTarget: missing args" -} [] uniq = getUnique name info_lbl = mkReturnInfoLabel uniq mkRetInfoTable :: CLabel -- info label -> Liveness -- liveness -> C_SRT -- SRT Info -> Int -- type (eg. rET_SMALL) -> [CmmLit] -- vector -> ([CmmLit],[CmmLit]) mkRetInfoTable info_lbl liveness srt_info cl_type vector = (std_info, extra_bits) where (srt_label, srt_len) = srtLabelAndLength srt_info info_lbl srt_slot | need_srt = [srt_label] | otherwise = [] need_srt = needsSRT srt_info || not (null vector) -- If there's a vector table then we must allocate -- an SRT slot, so that the vector table is at a -- known offset from the info pointer liveness_lit = makeRelativeRefTo info_lbl $ mkLivenessCLit liveness std_info = mkStdInfoTable zeroCLit zeroCLit cl_type srt_len liveness_lit extra_bits = srt_slot ++ map (makeRelativeRefTo info_lbl) vector emitDirectReturnTarget :: Name -> CgStmts -- The direct-return code -> SRT -> FCode CLabel emitDirectReturnTarget name code srt = emitReturnTarget name code [] srt emitAlgReturnTarget :: Name -- Just for its unique -> [(ConTagZ, CgStmts)] -- Tagged branches -> Maybe CgStmts -- Default branch (if any) -> SRT -- Continuation's SRT -> CtrlReturnConvention -> FCode (CLabel, SemiTaggingStuff) emitAlgReturnTarget name branches mb_deflt srt ret_conv = case ret_conv of UnvectoredReturn fam_sz -> do { blks <- getCgStmts $ emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1) -- NB: tag_expr is zero-based ; lbl <- emitDirectReturnTarget name blks srt ; 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' VectoredReturn fam_sz -> do { let tagged_lbls = zip (map fst branches) $ map (CmmLabel . mkAltLabel uniq . fst) branches deflt_lbl | isJust mb_deflt = CmmLabel $ mkDefaultLabel uniq | otherwise = mkIntCLit 0 ; let vector = [ assocDefault deflt_lbl tagged_lbls i | i <- [0..fam_sz-1]] ; lbl <- emitReturnTarget name noCgStmts vector srt ; mapFCs emit_alt branches ; emit_deflt mb_deflt ; return (lbl, Just (tagged_lbls, deflt_lbl)) } where uniq = getUnique name tag_expr = getConstrTag (CmmReg nodeReg) emit_alt :: (Int, CgStmts) -> FCode (Int, CmmLit) -- Emit the code for the alternative as a top-level -- code block returning a label for it emit_alt (tag, stmts) = do { let lbl = mkAltLabel uniq tag ; blks <- cgStmtsToBlocks stmts ; emitProc [] lbl [] blks ; return (tag, CmmLabel lbl) } emit_deflt (Just stmts) = do { let lbl = mkDefaultLabel uniq ; blks <- cgStmtsToBlocks stmts ; emitProc [] lbl [] blks ; return (CmmLabel lbl) } emit_deflt Nothing = return (mkIntCLit 0) -- Nothing case: the simplifier might have eliminated a case -- so we may have e.g. case xs of -- [] -> e -- In that situation the default should never be taken, -- so we just use a NULL pointer -------------------------------- emitDirectReturnInstr :: Code emitDirectReturnInstr = do { info_amode <- getSequelAmode ; stmtC (CmmJump (entryCode info_amode) []) } emitVectoredReturnInstr :: CmmExpr -- _Zero-indexed_ constructor tag -> Code emitVectoredReturnInstr zero_indexed_tag = do { info_amode <- getSequelAmode -- HACK! assign info_amode to a temp, because retVec -- uses it twice and the NCG doesn't have any CSE yet. -- Only do this for the NCG, because gcc is too stupid -- to optimise away the extra tmp (grrr). ; dflags <- getDynFlags ; x <- if hscTarget dflags == HscAsm then do z <- newTemp wordRep stmtC (CmmAssign z info_amode) return (CmmReg z) else return info_amode ; let target = retVec x zero_indexed_tag ; stmtC (CmmJump target []) } ------------------------------------------------------------------------- -- -- Generating a standard info table -- ------------------------------------------------------------------------- -- The standard bits of an info table. This part of the info table -- corresponds to the StgInfoTable type defined in InfoTables.h. -- -- Its shape varies with ticky/profiling/tables next to code etc -- so we can't use constant offsets from Constants mkStdInfoTable :: CmmLit -- closure type descr (profiling) -> CmmLit -- closure descr (profiling) -> Int -- closure type -> StgHalfWord -- SRT length -> CmmLit -- layout field -> [CmmLit] mkStdInfoTable type_descr closure_descr cl_type srt_len layout_lit = -- Parallel revertible-black hole field prof_info -- Ticky info (none at present) -- Debug info (none at present) ++ [layout_lit, type_lit] where prof_info | opt_SccProfilingOn = [type_descr, closure_descr] | otherwise = [] type_lit = packHalfWordsCLit cl_type srt_len stdInfoTableSizeW :: WordOff -- The size of a standard info table varies with profiling/ticky etc, -- so we can't get it from Constants -- It must vary in sync with mkStdInfoTable stdInfoTableSizeW = size_fixed + size_prof where size_fixed = 2 -- layout, type size_prof | opt_SccProfilingOn = 2 | otherwise = 0 stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff stdSrtBitmapOffset :: ByteOff -- Byte offset of the SRT bitmap half-word which is -- in the *higher-addressed* part of the type_lit stdSrtBitmapOffset = stdInfoTableSizeB - hALF_WORD_SIZE stdClosureTypeOffset :: ByteOff -- Byte offset of the closure type half-word stdClosureTypeOffset = stdInfoTableSizeB - wORD_SIZE stdPtrsOffset, stdNonPtrsOffset :: ByteOff stdPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE stdNonPtrsOffset = stdInfoTableSizeB - 2*wORD_SIZE + hALF_WORD_SIZE ------------------------------------------------------------------------- -- -- Accessing fields of an info table -- ------------------------------------------------------------------------- closureInfoPtr :: CmmExpr -> CmmExpr -- Takes a closure pointer and returns the info table pointer closureInfoPtr e = CmmLoad e wordRep entryCode :: CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns its entry code entryCode e | tablesNextToCode = e | otherwise = CmmLoad e wordRep getConstrTag :: CmmExpr -> CmmExpr -- Takes a closure pointer, and return the *zero-indexed* -- constructor tag obtained from the info table -- This lives in the SRT field of the info table -- (constructors don't need SRTs). getConstrTag closure_ptr = CmmMachOp (MO_U_Conv halfWordRep wordRep) [infoTableConstrTag info_table] where info_table = infoTable (closureInfoPtr closure_ptr) infoTable :: CmmExpr -> CmmExpr -- Takes an info pointer (the first word of a closure) -- and returns a pointer to the first word of the standard-form -- info table, excluding the entry-code word (if present) infoTable info_ptr | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB) | otherwise = cmmOffsetW info_ptr 1 -- Past the entry code pointer infoTableConstrTag :: CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the constr tag -- field of the info table (same as the srt_bitmap field) infoTableConstrTag = infoTableSrtBitmap infoTableSrtBitmap :: CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the srt_bitmap -- field of the info table infoTableSrtBitmap info_tbl = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) halfWordRep infoTableClosureType :: CmmExpr -> CmmExpr -- Takes an info table pointer (from infoTable) and returns the closure type -- field of the info table. infoTableClosureType info_tbl = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) halfWordRep infoTablePtrs :: CmmExpr -> CmmExpr infoTablePtrs info_tbl = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) halfWordRep infoTableNonPtrs :: CmmExpr -> CmmExpr infoTableNonPtrs info_tbl = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) halfWordRep funInfoTable :: CmmExpr -> CmmExpr -- Takes the info pointer of a function, -- and returns a pointer to the first word of the StgFunInfoExtra struct -- in the info table. funInfoTable info_ptr | tablesNextToCode = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev) | otherwise = cmmOffsetW info_ptr (1 + stdInfoTableSizeW) -- Past the entry code pointer ------------------------------------------------------------------------- -- -- Emit the code for a closure (or return address) -- and its associated info table -- ------------------------------------------------------------------------- -- The complication here concerns whether or not we can -- put the info table next to the code emitInfoTableAndCode :: CLabel -- Label of info table -> [CmmLit] -- ...its invariant part -> [CmmLit] -- ...and its variant part -> [LocalReg] -- ...args -> [CmmBasicBlock] -- ...and body -> Code emitInfoTableAndCode info_lbl std_info extra_bits args blocks | tablesNextToCode -- Reverse the extra_bits; and emit the top-level proc = emitProc (reverse extra_bits ++ std_info) entry_lbl args blocks -- NB: the info_lbl is discarded | null blocks -- No actual code; only the info table is significant = -- Use a zero place-holder in place of the -- entry-label in the info table emitRODataLits info_lbl (zeroCLit : std_info ++ extra_bits) | otherwise -- Separately emit info table (with the function entry = -- point as first entry) and the entry code do { emitDataLits info_lbl (CmmLabel entry_lbl : std_info ++ extra_bits) ; emitProc [] entry_lbl args blocks } where entry_lbl = infoLblToEntryLbl info_lbl ------------------------------------------------------------------------- -- -- Static reference tables -- ------------------------------------------------------------------------- -- 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) srtLabelAndLength (C_SRT lbl off bitmap) info_lbl = (makeRelativeRefTo info_lbl $ cmmLabelOffW lbl off, bitmap) ------------------------------------------------------------------------- -- -- Position independent code -- ------------------------------------------------------------------------- -- In order to support position independent code, we mustn't put absolute -- references into read-only space. Info tables in the tablesNextToCode -- case must be in .text, which is read-only, so we doctor the CmmLits -- to use relative offsets instead. -- Note that this is done even when the -fPIC flag is not specified, -- as we want to keep binary compatibility between PIC and non-PIC. makeRelativeRefTo :: CLabel -> CmmLit -> CmmLit makeRelativeRefTo info_lbl (CmmLabel lbl) | tablesNextToCode = CmmLabelDiffOff lbl info_lbl 0 makeRelativeRefTo info_lbl (CmmLabelOff lbl off) | tablesNextToCode = CmmLabelDiffOff lbl info_lbl off makeRelativeRefTo _ lit = lit