X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FCgClosure.lhs;h=56f2847052815c1f797e91c7b9ff4819c1d73b78;hb=fd12b167cd246087858d50ab66840274ef609f79;hp=80949e7513c62152799db4ab56ab97f964f2abeb;hpb=d600bf7a6afdbfc4a22f9379406a9c6f789a4c2d;p=ghc-hetmet.git

diff --git a/compiler/codeGen/CgClosure.lhs b/compiler/codeGen/CgClosure.lhs
index 80949e7..56f2847 100644
--- a/compiler/codeGen/CgClosure.lhs
+++ b/compiler/codeGen/CgClosure.lhs
@@ -9,13 +9,6 @@ with {\em closures} on the RHSs of let(rec)s.  See also
 @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,
@@ -38,7 +31,6 @@ import CgCallConv
 import CgUtils
 import ClosureInfo
 import SMRep
-import MachOp
 import Cmm
 import CmmUtils
 import CLabel
@@ -85,7 +77,7 @@ cgTopRhsClosure id ccs binder_info upd_flag args body = do
   ; 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
+	closure_label = mkLocalClosureLabel name $ idCafInfo id
     	cg_id_info    = stableIdInfo id (mkLblExpr closure_label) lf_info
 	closure_rep   = mkStaticClosureFields closure_info ccs True []
 
@@ -117,7 +109,7 @@ cgStdRhsClosure
 	-> [StgArg]		-- payload
 	-> FCode (Id, CgIdInfo)
 
-cgStdRhsClosure bndr cc bndr_info fvs args body lf_info payload 
+cgStdRhsClosure bndr cc _bndr_info _fvs args body lf_info payload 
   = do	-- AHA!  A STANDARD-FORM THUNK
   {	-- LAY OUT THE OBJECT
     amodes <- getArgAmodes payload
@@ -249,7 +241,7 @@ So it should set up an update frame (if it is shared).
 NB: Thunks cannot have a primitive type!
 
 \begin{code}
-closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
+closureCodeBody _binder_info cl_info cc [{- No args i.e. thunk -}] body = do
   { body_absC <- getCgStmts $ do
 	{ tickyEnterThunk cl_info
 	; ldvEnterClosure cl_info  -- NB: Node always points when profiling
@@ -259,6 +251,7 @@ closureCodeBody binder_info cl_info cc [{- No args i.e. thunk -}] body = do
 		-- in update frame CAF/DICT functions will be
 		-- subsumed by this enclosing cc
 	    { enterCostCentre cl_info cc body
+            ; stmtsC [CmmComment $ mkFastString $ showSDoc $ ppr body]
 	    ; cgExpr body }
 	}
     
@@ -273,7 +266,7 @@ argSatisfactionCheck (by calling fetchAndReschedule).  There info if
 Node points to closure is available. -- HWL
 
 \begin{code}
-closureCodeBody binder_info cl_info cc args body 
+closureCodeBody _binder_info cl_info cc args body 
   = ASSERT( length args > 0 )
   do { 	-- Get the current virtual Sp (it might not be zero, 
 	-- eg. if we're compiling a let-no-escape).
@@ -282,7 +275,7 @@ closureCodeBody binder_info cl_info cc args body
 	(sp_top, stk_args)     = mkVirtStkOffsets vSp other_args
 
 	-- Allocate the global ticky counter
-  ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info)
+  ; let ticky_ctr_lbl = mkRednCountsLabel (closureName cl_info) (clHasCafRefs cl_info)
   ; emitTickyCounter cl_info args sp_top
 
    	-- ...and establish the ticky-counter 
@@ -355,7 +348,8 @@ mkSlowEntryCode cl_info reg_args
   | otherwise = return noStmts
   where
      name = closureName cl_info
-     slow_lbl = mkSlowEntryLabel name
+     has_caf_refs = clHasCafRefs cl_info
+     slow_lbl = mkSlowEntryLabel name has_caf_refs
 
      load_stmts = mkStmts load_assts `plusStmts` mkStmts [stk_adj_pop, jump_to_entry]
      save_stmts = oneStmt stk_adj_push `plusStmts`  mkStmts save_assts
@@ -372,13 +366,13 @@ mkSlowEntryCode cl_info reg_args
 						   (argMachRep rep))
 
      save_assts = zipWithEqual "mk_save" mk_save reps_w_regs stk_offsets
-     mk_save (rep,reg) offset = ASSERT( argMachRep rep == globalRegRep reg )
+     mk_save (rep,reg) offset = ASSERT( argMachRep rep `cmmEqType` globalRegType reg )
 				CmmStore (cmmRegOffW spReg offset) 
 					 (CmmReg (CmmGlobal reg))
 
      stk_adj_pop   = CmmAssign spReg (cmmRegOffW spReg final_stk_offset)
      stk_adj_push  = CmmAssign spReg (cmmRegOffW spReg (- final_stk_offset))
-     jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name)) []
+     jump_to_entry = CmmJump (mkLblExpr (enterLocalIdLabel name has_caf_refs)) []
 \end{code}
 
 
@@ -401,8 +395,10 @@ thunkWrapper closure_info thunk_code = do
 
         -- Stack and/or heap checks
   ; thunkEntryChecks closure_info $ do
-      	{	-- Overwrite with black hole if necessary
-	  whenC (blackHoleOnEntry closure_info && node_points)
+      	{
+          dflags <- getDynFlags
+          -- Overwrite with black hole if necessary
+	; whenC (blackHoleOnEntry dflags closure_info && node_points)
  	        (blackHoleIt closure_info)
 	; setupUpdate closure_info thunk_code }
 		-- setupUpdate *encloses* the thunk_code
@@ -554,7 +550,7 @@ link_caf :: ClosureInfo
 -- updated with the new value when available.  The reason for all of this
 -- is that we only want to update dynamic heap objects, not static ones,
 -- so that generational GC is easier.
-link_caf cl_info is_upd = do
+link_caf cl_info _is_upd = do
   { 	-- Alloc black hole specifying CC_HDR(Node) as the cost centre
   ; let	use_cc   = costCentreFrom (CmmReg nodeReg)
         blame_cc = use_cc
@@ -565,7 +561,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") [CmmKinded (CmmReg nodeReg) PtrHint] [node] False
+  ; emitRtsCallWithVols (sLit "newCAF") [CmmHinted (CmmReg nodeReg) AddrHint] [node] False
 	-- node is live, so save it.
 
 	-- Overwrite the closure with a (static) indirection