X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgInfoTbls.hs;fp=ghc%2Fcompiler%2FcodeGen%2FCgInfoTbls.hs;h=0000000000000000000000000000000000000000;hb=0065d5ab628975892cea1ec7303f968c3338cbe1;hp=b769950d874f18edf2f5f4104ae4382569953911;hpb=28a464a75e14cece5db40f2765a29348273ff2d2;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/CgInfoTbls.hs b/ghc/compiler/codeGen/CgInfoTbls.hs deleted file mode 100644 index b769950..0000000 --- a/ghc/compiler/codeGen/CgInfoTbls.hs +++ /dev/null @@ -1,591 +0,0 @@ ------------------------------------------------------------------------------ --- --- 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 ( MachOp(..), wordRep, halfWordRep ) -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 - tableEntry = CmmLoad slot wordRep - 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