@CgCon@, which deals with constructors.
\begin{code}
+{-# 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
+
module CgClosure ( cgTopRhsClosure,
cgStdRhsClosure,
cgRhsClosure,
import CmmUtils
import CLabel
import StgSyn
-import StaticFlags
import CostCentre
import Id
import Name
import Constants
import Outputable
import FastString
+
+import Data.List
\end{code}
%********************************************************
cgTopRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
- -> SRT
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> FCode (Id, CgIdInfo)
-cgTopRhsClosure id ccs binder_info srt upd_flag args body = do
+cgTopRhsClosure id ccs binder_info upd_flag args body = do
{ -- LAY OUT THE OBJECT
let name = idName id
; lf_info <- mkClosureLFInfo id TopLevel [] upd_flag args
- ; srt_info <- getSRTInfo name srt
+ ; srt_info <- getSRTInfo
; mod_name <- getModuleName
; let descr = closureDescription mod_name name
closure_info = mkClosureInfo True id lf_info 0 0 srt_info descr
cgRhsClosure :: Id
-> CostCentreStack -- Optional cost centre annotation
-> StgBinderInfo
- -> SRT
-> [Id] -- Free vars
-> UpdateFlag
-> [Id] -- Args
-> StgExpr
-> FCode (Id, CgIdInfo)
-cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
+cgRhsClosure bndr cc bndr_info fvs upd_flag args body = do
{ -- LAY OUT THE OBJECT
-- If the binder is itself a free variable, then don't store
-- it in the closure. Instead, just bind it to Node on entry.
; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
; fv_infos <- mapFCs getCgIdInfo reduced_fvs
- ; srt_info <- getSRTInfo name srt
+ ; srt_info <- getSRTInfo
; mod_name <- getModuleName
; let bind_details :: [(CgIdInfo, VirtualHpOffset)]
(tot_wds, ptr_wds, bind_details)
-- BUILD ITS INFO TABLE AND CODE
; forkClosureBody (do
{ -- Bind the fvs
- let bind_fv (info, offset)
+ let
+ -- A function closure pointer may be tagged, so we
+ -- must take it into account when accessing the free variables.
+ mbtag = tagForArity (length args)
+ bind_fv (info, offset)
+ | Just tag <- mbtag
+ = bindNewToUntagNode (cgIdInfoId info) offset (cgIdInfoLF info) tag
+ | otherwise
= bindNewToNode (cgIdInfoId info) offset (cgIdInfoLF info)
; mapCs bind_fv bind_details
closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
{ body_absC <- getCgStmts $ do
{ tickyEnterThunk cl_info
- ; ldvEnter (CmmReg nodeReg) -- NB: Node always points when profiling
+ ; ldvEnterClosure cl_info -- NB: Node always points when profiling
; thunkWrapper cl_info $ do
-- We only enter cc after setting up update so
-- that cc of enclosing scope will be recorded
funWrapper closure_info arg_regs reg_save_code fun_body = do
{ let node_points = nodeMustPointToIt (closureLFInfo closure_info)
+ {-
+ -- Debugging: check that R1 has the correct tag
+ ; let tag = funTag closure_info
+ ; whenC (tag /= 0 && node_points) $ do
+ l <- newLabelC
+ stmtC (CmmCondBranch (CmmMachOp mo_wordEq [cmmGetTag (CmmReg nodeReg),
+ CmmLit (mkIntCLit tag)]) l)
+ stmtC (CmmStore (CmmLit (mkWordCLit 0)) (CmmLit (mkWordCLit 0)))
+ labelC l
+ -}
+
-- Enter for Ldv profiling
- ; whenC node_points (ldvEnter (CmmReg nodeReg))
+ ; whenC node_points (ldvEnterClosure closure_info)
-- GranSim yeild poin
; granYield arg_regs node_points
-- Profiling needs slop filling (to support LDV profiling), so
-- currently eager blackholing doesn't work with profiling.
--
- -- TICKY_TICKY needs EAGER_BLACKHOLING to verify no double-entries of
- -- single-entry thunks.
- eager_blackholing
- | opt_DoTickyProfiling = True
- | otherwise = False
+ -- Previously, eager blackholing was enabled when ticky-ticky
+ -- was on. But it didn't work, and it wasn't strictly necessary
+ -- to bring back minimal ticky-ticky, so now EAGER_BLACKHOLING
+ -- is unconditionally disabled. -- krc 1/2007
+ eager_blackholing = False
\end{code}
\begin{code}
; if closureUpdReqd closure_info
then do -- Blackhole the (updatable) CAF:
{ upd_closure <- link_caf closure_info True
- ; pushUpdateFrame upd_closure code }
+ ; pushUpdateFrame upd_closure code }
else do
- { -- No update reqd, you'd think we don't need to
- -- black-hole it. But when ticky-ticky is on, we
- -- black-hole it regardless, to catch errors in which
- -- an allegedly single-entry closure is entered twice
- --
- -- We discard the pointer returned by link_caf, because
- -- we don't push an update frame
- whenC opt_DoTickyProfiling -- Blackhole even a SE CAF
- (link_caf closure_info False >> nopC)
+ { -- krc: removed some ticky-related code here.
; tickyUpdateFrameOmitted
; code }
}
-- so that the garbage collector can find them
-- This must be done *before* the info table pointer is overwritten,
-- because the old info table ptr is needed for reversion
- ; emitRtsCallWithVols SLIT("newCAF") [(CmmReg nodeReg,PtrHint)] [node]
+ ; emitRtsCallWithVols SLIT("newCAF") [CmmHinted (CmmReg nodeReg) PtrHint] [node] False
-- node is live, so save it.
-- Overwrite the closure with a (static) indirection