+++ /dev/null
------------------------------------------------------------------------------
---
--- 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
--- <reversed variable part>
--- <normal forward StgInfoTable, but without
--- an entry point at the front>
--- <code>
---
--- Without tablesNextToCode, the layout of an info table is
--- <entry label>
--- <normal forward rest of StgInfoTable>
--- <forward variable part>
---
--- 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:
---
--- <reversed vector table>
--- <srt slot>
--- <standard info table>
--- ret-addr --> <entry code (if any)>
---
--- Not tables-next-to-code:
---
--- ret-addr --> <ptr to entry code>
--- <standard info table>
--- <srt slot>
--- <forward vector table>
---
--- * 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
projects / ghc-hetmet.git / blobdiff