X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FCgCon.lhs;h=89a4e84400be7b40fe0c31edf43463d93aaafba8;hp=bf4cf3d9e75e905625a55a5e23322aa356b533f1;hb=a02e7f40afc1aab7fe466f949f505c1d7250713d;hpb=16a2f6a8a381af31c23b6a41a851951da9bc1803

diff --git a/compiler/codeGen/CgCon.lhs b/compiler/codeGen/CgCon.lhs
index bf4cf3d..89a4e84 100644
--- a/compiler/codeGen/CgCon.lhs
+++ b/compiler/codeGen/CgCon.lhs
@@ -9,13 +9,6 @@ with {\em constructors} on the RHSs of let(rec)s.  See also
 @CgClosure@, which deals with closures.
 
 \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 CgCon (
 	cgTopRhsCon, buildDynCon,
 	bindConArgs, bindUnboxedTupleComponents,
@@ -47,13 +40,15 @@ import Constants
 import TyCon
 import DataCon
 import Id
+import IdInfo
 import Type
 import PrelInfo
 import Outputable
 import ListSetOps
-#ifdef DEBUG
-import Util             ( lengthIs )
-#endif
+import Util
+import Module
+import FastString
+import StaticFlags
 \end{code}
 
 
@@ -83,7 +78,7 @@ cgTopRhsCon id con args
 	; let
 	    name          = idName id
 	    lf_info	  = mkConLFInfo con
-    	    closure_label = mkClosureLabel name
+    	    closure_label = mkClosureLabel name $ idCafInfo id
 	    caffy         = any stgArgHasCafRefs args
 	    (closure_info, amodes_w_offsets) = layOutStaticConstr con amodes
 	    closure_rep = mkStaticClosureFields
@@ -141,9 +136,10 @@ which have exclusively size-zero (VoidRep) args, we generate no code
 at all.
 
 \begin{code}
-buildDynCon binder cc con []
+buildDynCon binder _ con []
   = returnFC (taggedStableIdInfo binder
-			   (mkLblExpr (mkClosureLabel (dataConName con)))
+			   (mkLblExpr (mkClosureLabel (dataConName con)
+                                      (idCafInfo binder)))
     			   (mkConLFInfo con)
                            con)
 \end{code}
@@ -170,23 +166,23 @@ which is guaranteed in range.
 Because of this, we use can safely return an addressing mode.
 
 \begin{code}
-buildDynCon binder cc con [arg_amode]
+buildDynCon binder _ con [arg_amode]
   | maybeIntLikeCon con 
   , (_, CmmLit (CmmInt val _)) <- arg_amode
   , let val_int = (fromIntegral val) :: Int
   , val_int <= mAX_INTLIKE && val_int >= mIN_INTLIKE
-  = do 	{ let intlike_lbl   = mkRtsDataLabel SLIT("stg_INTLIKE_closure")
+  = do 	{ let intlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_INTLIKE_closure")
 	      offsetW = (val_int - mIN_INTLIKE) * (fixedHdrSize + 1)
 		-- INTLIKE closures consist of a header and one word payload
 	      intlike_amode = CmmLit (cmmLabelOffW intlike_lbl offsetW)
 	; returnFC (taggedStableIdInfo binder intlike_amode (mkConLFInfo con) con) }
 
-buildDynCon binder cc con [arg_amode]
+buildDynCon binder _ con [arg_amode]
   | maybeCharLikeCon con 
   , (_, CmmLit (CmmInt val _)) <- arg_amode
   , let val_int = (fromIntegral val) :: Int
   , val_int <= mAX_CHARLIKE && val_int >= mIN_CHARLIKE
-  = do 	{ let charlike_lbl   = mkRtsDataLabel SLIT("stg_CHARLIKE_closure")
+  = do 	{ let charlike_lbl   = mkCmmGcPtrLabel rtsPackageId (fsLit "stg_CHARLIKE_closure")
 	      offsetW = (val_int - mIN_CHARLIKE) * (fixedHdrSize + 1)
 		-- CHARLIKE closures consist of a header and one word payload
 	      charlike_amode = CmmLit (cmmLabelOffW charlike_lbl offsetW)
@@ -302,6 +298,11 @@ sure the @amodes@ passed don't conflict with each other.
 cgReturnDataCon :: DataCon -> [(CgRep, CmmExpr)] -> Code
 
 cgReturnDataCon con amodes
+  | isUnboxedTupleCon con = returnUnboxedTuple amodes
+      -- when profiling we can't shortcut here, we have to enter the closure
+      -- for it to be marked as "used" for LDV profiling.
+  | opt_SccProfilingOn    = build_it_then enter_it
+  | otherwise
   = ASSERT( amodes `lengthIs` dataConRepArity con )
     do	{ EndOfBlockInfo _ sequel <- getEndOfBlockInfo
 	; case sequel of
@@ -325,11 +326,12 @@ cgReturnDataCon con amodes
 			| isDeadBinder bndr -> performReturn (jump_to deflt_lbl)
 			| otherwise	    -> build_it_then (jump_to deflt_lbl) }
     
-	    other_sequel	-- The usual case
-	      | isUnboxedTupleCon con -> returnUnboxedTuple amodes
-              | otherwise -> build_it_then emitReturnInstr
+	    _otherwise	-- The usual case
+              -> build_it_then emitReturnInstr
 	}
   where
+    enter_it    = stmtsC [ CmmAssign nodeReg (cmmUntag (CmmReg nodeReg)),
+                           CmmJump (entryCode (closureInfoPtr (CmmReg nodeReg))) [] ]
     jump_to lbl = stmtC (CmmJump (CmmLit lbl) [])
     build_it_then return_code
       = do { 	-- BUILD THE OBJECT IN THE HEAP
@@ -402,9 +404,8 @@ cgTyCon tycon
             -- code appears to put it before --- NR 16 Aug 2007
 	; extra <- 
 	   if isEnumerationTyCon tycon then do
-	        tbl <- getCmm (emitRODataLits (mkLocalClosureTableLabel 
-						(tyConName tycon))
-			   [ CmmLabelOff (mkLocalClosureLabel (dataConName con)) (tagForCon con)
+	        tbl <- getCmm (emitRODataLits "cgTyCon" (mkLocalClosureTableLabel (tyConName tycon) NoCafRefs)
+			   [ CmmLabelOff (mkLocalClosureLabel (dataConName con) NoCafRefs) (tagForCon con)
     			   | con <- tyConDataCons tycon])
 		return [tbl]
 	   else
@@ -437,7 +438,7 @@ cgDataCon data_con
 		= do { code_blks <- getCgStmts the_code
 		     ; emitClosureCodeAndInfoTable cl_info [] code_blks }
 		where
-		  the_code = do	{ ticky_code
+		  the_code = do	{ _ <- ticky_code
 				; ldvEnter (CmmReg nodeReg)
 				; body_code }