emitDirectReturnInstr, emitVectoredReturnInstr,
mkRetInfoTable,
mkStdInfoTable,
+ stdInfoTableSizeB,
mkFunGenInfoExtraBits,
entryCode, closureInfoPtr,
getConstrTag,
infoTable, infoTableClosureType,
infoTablePtrs, infoTableNonPtrs,
funInfoTable,
- vectorSlot,
+ retVec
) where
import CmdLineOpts ( opt_SccProfilingOn )
import ListSetOps ( assocDefault )
import Maybes ( isJust )
-import Constants ( wORD_SIZE, sIZEOF_StgFunInfoExtra )
+import Constants ( wORD_SIZE, sIZEOF_StgFunInfoExtraRev )
import Outputable
(mkIntCLit 0, fromIntegral (dataConTagZ con))
Nothing -> -- Not a constructor
- srtLabelAndLength srt
+ srtLabelAndLength srt info_lbl
ptrs = closurePtrsSize cl_info
nptrs = size - ptrs
| ArgGen liveness <- arg_descr
= [ fun_amode,
srt_label,
- mkLivenessCLit liveness,
- CmmLabel (mkSlowEntryLabel (closureName cl_info)) ]
+ 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
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)
- -> [CLabel] -- Vector of return points
+ -> [CmmLit] -- Vector of return points
-- (empty for non-vectored returns)
-> SRT
-> FCode CLabel
(False, False) -> rET_VEC_SMALL
(std_info, extra_bits) =
- mkRetInfoTable liveness srt_info cl_type vector
+ mkRetInfoTable info_lbl liveness srt_info cl_type vector
; blks <- cgStmtsToBlocks stmts
; emitInfoTableAndCode info_lbl std_info extra_bits args blks
mkRetInfoTable
- :: Liveness -- liveness
+ :: CLabel -- info label
+ -> Liveness -- liveness
-> C_SRT -- SRT Info
-> Int -- type (eg. rET_SMALL)
- -> [CLabel] -- vector
+ -> [CmmLit] -- vector
-> ([CmmLit],[CmmLit])
-mkRetInfoTable liveness srt_info cl_type vector
+mkRetInfoTable info_lbl liveness srt_info cl_type vector
= (std_info, extra_bits)
where
- (srt_label, srt_len) = srtLabelAndLength srt_info
+ (srt_label, srt_len) = srtLabelAndLength srt_info info_lbl
srt_slot | need_srt = [srt_label]
| otherwise = []
-- an SRT slot, so that the vector table is at a
-- known offset from the info pointer
- liveness_lit = mkLivenessCLit liveness
+ liveness_lit = makeRelativeRefTo info_lbl $ mkLivenessCLit liveness
std_info = mkStdInfoTable zeroCLit zeroCLit cl_type srt_len liveness_lit
- extra_bits = srt_slot ++ map CmmLabel vector
+ extra_bits = srt_slot ++ map (makeRelativeRefTo info_lbl) vector
emitDirectReturnTarget
-- global labels, so we can't use them at the 'call site'
VectoredReturn fam_sz -> do
- { tagged_lbls <- mapFCs emit_alt branches
- ; deflt_lbl <- emit_deflt mb_deflt
+ { 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, CLabel)
+ 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, lbl) }
+ ; return (tag, CmmLabel lbl) }
emit_deflt (Just stmts) = do { let lbl = mkDefaultLabel uniq
; blks <- cgStmtsToBlocks stmts
; emitProc [] lbl [] blks
- ; return lbl }
- emit_deflt Nothing = return mkErrorStdEntryLabel
+ ; 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 mkErrorStdEntryLabel
+ -- so we just use a NULL pointer
--------------------------------
emitDirectReturnInstr :: Code
-> Code
emitVectoredReturnInstr zero_indexed_tag
= do { info_amode <- getSequelAmode
- ; let slot = vectorSlot info_amode zero_indexed_tag
- ; stmtC (CmmJump (CmmLoad slot wordRep) []) }
-
+ ; let target = retVec info_amode zero_indexed_tag
+ ; stmtC (CmmJump target []) }
-------------------------------------------------------------------------
-- in the info table.
funInfoTable info_ptr
| tablesNextToCode
- = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtra)
+ = cmmOffsetB info_ptr (- stdInfoTableSizeB - sIZEOF_StgFunInfoExtraRev)
| otherwise
= cmmOffsetW info_ptr (1 + stdInfoTableSizeW)
-- Past the entry code pointer
srt_escape = (-1) :: StgHalfWord
-srtLabelAndLength :: C_SRT -> (CmmLit, StgHalfWord)
-srtLabelAndLength NoC_SRT = (zeroCLit, 0)
-srtLabelAndLength (C_SRT lbl off bitmap) = (cmmLabelOffW lbl off, bitmap)
+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