stdInfoTableSizeB,
entryCode, closureInfoPtr,
getConstrTag,
+ cmmGetClosureType,
infoTable, infoTableClosureType,
infoTablePtrs, infoTableNonPtrs,
funInfoTable, makeRelativeRefTo
import CgUtils
import CgMonad
-import CmmUtils
-import Cmm
-import MachOp
+import OldCmmUtils
+import OldCmm
import CLabel
-import StgSyn
import Name
import DataCon
import Unique
import StaticFlags
-import Maybes
import Constants
-import Panic
import Util
import Outputable
emitClosureCodeAndInfoTable cl_info args body
= do { blks <- cgStmtsToBlocks body
; info <- mkCmmInfo cl_info
- ; emitInfoTableAndCode info_lbl info args blks }
+ ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks }
where
- info_lbl = infoTableLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info $ clHasCafRefs cl_info
-- We keep the *zero-indexed* tag in the srt_len field of the info
-- table of a data constructor.
-- Not used for return points. (The 'smRepClosureTypeInt' call would panic.)
mkCmmInfo :: ClosureInfo -> FCode CmmInfo
mkCmmInfo cl_info = do
- prof <-
- if opt_SccProfilingOn
+ prof <-
+ if opt_SccProfilingOn
then do ty_descr_lit <- mkStringCLit (closureTypeDescr cl_info)
cl_descr_lit <- mkStringCLit (closureValDescr cl_info)
- return $ ProfilingInfo
- (makeRelativeRefTo info_lbl ty_descr_lit)
- (makeRelativeRefTo info_lbl cl_descr_lit)
+ return $ ProfilingInfo ty_descr_lit cl_descr_lit
else return $ ProfilingInfo (mkIntCLit 0) (mkIntCLit 0)
case cl_info of
info = ConstrInfo (ptrs, nptrs)
(fromIntegral (dataConTagZ con))
conName
- return $ CmmInfo prof gc_target cl_type info
+ return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
ClosureInfo { closureName = name,
closureLFInfo = lf_info,
closureSRT = srt } ->
- return $ CmmInfo prof gc_target cl_type info
+ return $ CmmInfo gc_target Nothing (CmmInfoTable False prof cl_type info)
where
info =
case lf_info of
LFReEntrant _ arity _ arg_descr ->
FunInfo (ptrs, nptrs)
srt
- (argDescrType arg_descr)
(fromIntegral arity)
arg_descr
- (CmmLabel (mkSlowEntryLabel name))
+ (CmmLabel (mkSlowEntryLabel name has_caf_refs))
LFThunk _ _ _ (SelectorThunk offset) _ ->
ThunkSelectorInfo (fromIntegral offset) srt
LFThunk _ _ _ _ _ ->
ThunkInfo (ptrs, nptrs) srt
_ -> panic "unexpected lambda form in mkCmmInfo"
where
- info_lbl = infoTableLabelFromCI cl_info
+ info_lbl = infoTableLabelFromCI cl_info has_caf_refs
+ has_caf_refs = clHasCafRefs cl_info
cl_type = smRepClosureTypeInt (closureSMRep cl_info)
; blks <- cgStmtsToBlocks stmts
; frame <- mkStackLayout
; let info = CmmInfo
- (ProfilingInfo zeroCLit zeroCLit)
gc_target
- rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
- (ContInfo frame srt_info)
- ; emitInfoTableAndCode info_lbl info args blks
+ Nothing
+ (CmmInfoTable False
+ (ProfilingInfo zeroCLit zeroCLit)
+ rET_SMALL -- cmmToRawCmm may convert it to rET_BIG
+ (ContInfo frame srt_info))
+ ; emitInfoTableAndCode (infoLblToEntryLbl info_lbl) info args blks
; return info_lbl }
where
args = {- trace "emitReturnTarget: missing args" -} []
(Just stack_bind) : (stack_layout binds (sizeW - rep_size))
where
rep_size = cgRepSizeW (cgIdInfoArgRep bind)
- stack_bind = LocalReg unique machRep kind
+ stack_bind = LocalReg unique machRep
unique = getUnique (cgIdInfoId bind)
machRep = argMachRep (cgIdInfoArgRep bind)
- kind = if isFollowableArg (cgIdInfoArgRep bind)
- then KindPtr
- else KindNonPtr
-stack_layout binds@((off, _):_) sizeW | otherwise =
+stack_layout binds@(_:_) sizeW | otherwise =
Nothing : (stack_layout binds (sizeW - 1))
{- Another way to write the function that might be less error prone (untested)
unique = getUnique (cgIdInfoId x)
machRep = argMachrep (cgIdInfoArgRep bind)
kind = if isFollowableArg (cgIdInfoArgRep bind)
- then KindPtr
- else KindNonPtr
+ then GCKindPtr
+ else GCKindNonPtr
-}
emitAlgReturnTarget
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
+ -- is the constructor tag in the node reg?
+ if isSmallFamily fam_sz
+ then do -- yes, node has constr. tag
+ let tag_expr = cmmConstrTag1 (CmmReg nodeReg)
+ branches' = [(tag+1,branch)|(tag,branch)<-branches]
+ emitSwitch tag_expr branches' mb_deflt 1 fam_sz
+ else do -- no, get tag from info table
+ let -- Note that ptr _always_ has tag 1
+ -- when the family size is big enough
+ untagged_ptr = cmmRegOffB nodeReg (-1)
+ tag_expr = getConstrTag (untagged_ptr)
+ emitSwitch tag_expr branches mb_deflt 0 (fam_sz - 1)
; 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'
- where
- tag_expr = getConstrTag (CmmReg nodeReg)
--------------------------------
emitReturnInstr :: Code
size_prof | opt_SccProfilingOn = 2
| otherwise = 0
-stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE :: ByteOff
+stdInfoTableSizeB :: ByteOff
+stdInfoTableSizeB = stdInfoTableSizeW * wORD_SIZE
stdSrtBitmapOffset :: ByteOff
-- Byte offset of the SRT bitmap half-word which is
closureInfoPtr :: CmmExpr -> CmmExpr
-- Takes a closure pointer and returns the info table pointer
-closureInfoPtr e = CmmLoad e wordRep
+closureInfoPtr e = CmmLoad e bWord
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
+ | otherwise = CmmLoad e bWord
getConstrTag :: CmmExpr -> CmmExpr
-- Takes a closure pointer, and return the *zero-indexed*
-- 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]
+ = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableConstrTag info_table]
+ where
+ info_table = infoTable (closureInfoPtr closure_ptr)
+
+cmmGetClosureType :: CmmExpr -> CmmExpr
+-- Takes a closure pointer, and return the closure type
+-- obtained from the info table
+cmmGetClosureType closure_ptr
+ = CmmMachOp (MO_UU_Conv halfWordWidth wordWidth) [infoTableClosureType info_table]
where
info_table = infoTable (closureInfoPtr closure_ptr)
-- 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
+ = CmmLoad (cmmOffsetB info_tbl stdSrtBitmapOffset) bHalfWord
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
+ = CmmLoad (cmmOffsetB info_tbl stdClosureTypeOffset) bHalfWord
infoTablePtrs :: CmmExpr -> CmmExpr
infoTablePtrs info_tbl
- = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) halfWordRep
+ = CmmLoad (cmmOffsetB info_tbl stdPtrsOffset) bHalfWord
infoTableNonPtrs :: CmmExpr -> CmmExpr
infoTableNonPtrs info_tbl
- = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) halfWordRep
+ = CmmLoad (cmmOffsetB info_tbl stdNonPtrsOffset) bHalfWord
funInfoTable :: CmmExpr -> CmmExpr
-- Takes the info pointer of a function,
-- put the info table next to the code
emitInfoTableAndCode
- :: CLabel -- Label of info table
+ :: CLabel -- Label of entry or ret
-> CmmInfo -- ...the info table
- -> CmmFormals -- ...args
+ -> CmmFormals -- ...args
-> [CmmBasicBlock] -- ...and body
-> Code
-emitInfoTableAndCode info_lbl info args blocks
- = emitProc info entry_lbl args blocks
- where
- entry_lbl = infoLblToEntryLbl info_lbl
-
--------------------------------------------------------------------------
---
--- Static reference tables
---
--------------------------------------------------------------------------
-
-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)
+emitInfoTableAndCode entry_ret_lbl info args blocks
+ = emitProc info entry_ret_lbl args blocks
-------------------------------------------------------------------------
--
projects / ghc-hetmet.git / blobdiff