+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+
-----------------------------------------------------------------------------
--
-- Building info tables.
stdInfoTableSizeB,
entryCode, closureInfoPtr,
getConstrTag,
+ cmmGetClosureType,
infoTable, infoTableClosureType,
infoTablePtrs, infoTableNonPtrs,
funInfoTable, makeRelativeRefTo
-- representation as a list of 'CmmAddr' is handled later
-- in the pipeline by 'cmmToRawCmm'.
-emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormals -> CgStmts -> Code
+emitClosureCodeAndInfoTable :: ClosureInfo -> CmmFormalsWithoutKinds -> CgStmts -> Code
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
-- 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 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 prof cl_type info)
where
info =
case lf_info of
; 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
+ (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" -} []
unique = getUnique (cgIdInfoId bind)
machRep = argMachRep (cgIdInfoArgRep bind)
kind = if isFollowableArg (cgIdInfoArgRep bind)
- then KindPtr
- else KindNonPtr
+ then GCKindPtr
+ else GCKindNonPtr
stack_layout binds@((off, _):_) sizeW | otherwise =
Nothing : (stack_layout binds (sizeW - 1))
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)
+ uniq = getUnique name
--------------------------------
emitReturnInstr :: Code
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_U_Conv halfWordRep wordRep) [infoTableClosureType 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
-- 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
+ -> CmmFormalsWithoutKinds -- ...args
-> [CmmBasicBlock] -- ...and body
-> Code
-emitInfoTableAndCode info_lbl info args blocks
- = emitProc info entry_lbl args blocks
- where
- entry_lbl = infoLblToEntryLbl info_lbl
+emitInfoTableAndCode entry_ret_lbl info args blocks
+ = emitProc info entry_ret_lbl args blocks
-------------------------------------------------------------------------
--