X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgClosure.lhs;h=fabf434d07c4dbb3b14b141e82523ef42731e671;hb=c6eadadbefe2ec5709e9d31893f79c4ff78754b4;hp=1a2cbc5202e0e60333ab78d0dc8b8d0e9140675a;hpb=0065d5ab628975892cea1ec7303f968c3338cbe1;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 1a2cbc5..fabf434 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -1,8 +1,7 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgClosure.lhs,v 1.72 2005/05/18 12:06:51 simonmar Exp $
-%
 \section[CgClosure]{Code generation for closures}
 
 This module provides the support code for @StgToAbstractC@ to deal
@@ -23,36 +22,32 @@ import {-# SOURCE #-} CgExpr ( cgExpr )
 import CgMonad
 import CgBindery
 import CgHeapery
-import CgStackery	( mkVirtStkOffsets, pushUpdateFrame, getVirtSp,
-			  setRealAndVirtualSp )
-import CgProf		( chooseDynCostCentres, ldvEnter, enterCostCentre,
-			  costCentreFrom )
+import CgStackery
+import CgProf
 import CgTicky
-import CgParallel	( granYield, granFetchAndReschedule )
-import CgInfoTbls	( emitClosureCodeAndInfoTable, getSRTInfo )
-import CgCallConv	( assignCallRegs, mkArgDescr )
-import CgUtils		( emitDataLits, addIdReps, cmmRegOffW, 
-			  emitRtsCallWithVols )
-import ClosureInfo	-- lots and lots of stuff
-import SMRep		( CgRep, cgRepSizeW, argMachRep, fixedHdrSize, WordOff,
-			  idCgRep )
-import MachOp		( MachHint(..) )
+import CgParallel
+import CgInfoTbls
+import CgCallConv
+import CgUtils
+import ClosureInfo
+import SMRep
+import MachOp
 import Cmm
-import CmmUtils		( CmmStmts, mkStmts, oneStmt, plusStmts, noStmts,
-			  mkLblExpr )
+import CmmUtils
 import CLabel
 import StgSyn
-import StaticFlags	( opt_DoTickyProfiling )
 import CostCentre	
-import Id		( Id, idName, idType )
-import Name		( Name, isExternalName )
-import Module		( Module, pprModule )
-import ListSetOps	( minusList )
-import Util		( isIn, mapAccumL, zipWithEqual )
-import BasicTypes	( TopLevelFlag(..) )
-import Constants	( oFFSET_StgInd_indirectee, wORD_SIZE )
+import Id
+import Name
+import Module
+import ListSetOps
+import Util
+import BasicTypes
+import Constants
 import Outputable
 import FastString
+
+import Data.List
 \end{code}
 
 %********************************************************
@@ -68,18 +63,17 @@ They should have no free variables.
 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
-  ; mod_name <- moduleName
+  ; srt_info <- getSRTInfo
+  ; mod_name <- getModuleName
   ; let descr         = closureDescription mod_name name
 	closure_info  = mkClosureInfo True id lf_info 0 0 srt_info descr
 	closure_label = mkLocalClosureLabel name
@@ -118,7 +112,7 @@ cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload
   = do	-- AHA!  A STANDARD-FORM THUNK
   {	-- LAY OUT THE OBJECT
     amodes <- getArgAmodes payload
-  ; mod_name <- moduleName
+  ; mod_name <- getModuleName
   ; let (tot_wds, ptr_wds, amodes_w_offsets) 
 	    = mkVirtHeapOffsets (isLFThunk lf_info) amodes
 
@@ -143,14 +137,13 @@ Here's the general case.
 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.
@@ -168,8 +161,8 @@ cgRhsClosure bndr cc bndr_info srt fvs upd_flag args body = do
 
   ; lf_info <- mkClosureLFInfo bndr NotTopLevel fvs upd_flag args
   ; fv_infos <- mapFCs getCgIdInfo reduced_fvs
-  ; srt_info <- getSRTInfo name srt
-  ; mod_name <- moduleName
+  ; srt_info <- getSRTInfo
+  ; mod_name <- getModuleName
   ; let	bind_details :: [(CgIdInfo, VirtualHpOffset)]
 	(tot_wds, ptr_wds, bind_details) 
 	   = mkVirtHeapOffsets (isLFThunk lf_info) (map add_rep fv_infos)
@@ -453,12 +446,12 @@ emitBlackHoleCode is_single_entry
 	-- 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}
@@ -481,17 +474,9 @@ setupUpdate closure_info 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 }
     }
@@ -550,7 +535,7 @@ link_caf cl_info is_upd = do
 	-- 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") [(CmmReg nodeReg,PtrHint)] [node] False
 	-- node is live, so save it.
 
 	-- Overwrite the closure with a (static) indirection