Merge branch 'master' of darcs.haskell.org:/home/darcs/ghc

compiler/cmm/CmmNode.hs

@@ -4,13 +4,6 @@
 {-# LANGUAGE StandaloneDeriving #-}
 {-# LANGUAGE UndecidableInstances #-}
 
-{-# OPTIONS -fno-warn-tabs #-}
--- The above warning supression flag is a temporary kludge.
--- While working on this module you are encouraged to remove it and
--- detab the module (please do the detabbing in a separate patch). See
---     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
--- for details
-
 module CmmNode (
      CmmNode(..), CmmFormal, CmmActual,
      UpdFrameOffset, Convention(..),
@@ -50,13 +43,13 @@ data CmmNode e x where
     -- Assign to memory location.  Size is
     -- given by cmmExprType of the rhs.
 
-  CmmUnsafeForeignCall ::         -- An unsafe foreign call;
-                                  -- see Note [Foreign calls]
-  		       		  -- Like a "fat machine instruction"; can occur
-				  -- in the middle of a block
-      ForeignTarget ->            -- call target
-      [CmmFormal] ->               -- zero or more results
-      [CmmActual] ->               -- zero or more arguments
+  CmmUnsafeForeignCall ::       -- An unsafe foreign call;
+                                -- see Note [Foreign calls]
+                                -- Like a "fat machine instruction"; can occur
+                                -- in the middle of a block
+      ForeignTarget ->          -- call target
+      [CmmFormal] ->            -- zero or more results
+      [CmmActual] ->            -- zero or more arguments
       CmmNode O O
       -- Semantics: clobbers any GlobalRegs for which callerSaves r == True
       -- See Note [foreign calls clobber GlobalRegs]
@@ -124,7 +117,7 @@ data CmmNode e x where
   } -> CmmNode O C
 
   CmmForeignCall :: {           -- A safe foreign call; see Note [Foreign calls]
-  		    		-- Always the last node of a block
+                                -- Always the last node of a block
       tgt   :: ForeignTarget,   -- call target and convention
       res   :: [CmmFormal],     -- zero or more results
       args  :: [CmmActual],     -- zero or more arguments; see Note [Register parameter passing]
@@ -143,14 +136,14 @@ instruction".  In particular, they do *not* kill all live registers,
 just the registers they return to (there was a bit of code in GHC that
 conservatively assumed otherwise.)  However, see [Register parameter passing].
 
-Safe ones are trickier.  A safe foreign call 
+Safe ones are trickier.  A safe foreign call
      r = f(x)
 ultimately expands to
-     push "return address"	-- Never used to return to; 
-     	  	  		-- just points an info table
+     push "return address"      -- Never used to return to;
+                                -- just points an info table
      save registers into TSO
      call suspendThread
-     r = f(x)			-- Make the call
+     r = f(x)                   -- Make the call
      call resumeThread
      restore registers
      pop "return address"
@@ -354,7 +347,7 @@ instance DefinerOfRegs GlobalReg (CmmNode e x) where
 -----------------------------------
 -- mapping Expr in CmmNode
 
-mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget 
+mapForeignTarget :: (CmmExpr -> CmmExpr) -> ForeignTarget -> ForeignTarget
 mapForeignTarget exp   (ForeignTarget e c) = ForeignTarget (exp e) c
 mapForeignTarget _   m@(PrimTarget _)      = m
 
@@ -430,7 +423,7 @@ mapExpDeepM f = mapExpM $ wrapRecExpM f
 -----------------------------------
 -- folding Expr in CmmNode
 
-foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z 
+foldExpForeignTarget :: (CmmExpr -> z -> z) -> ForeignTarget -> z -> z
 foldExpForeignTarget exp (ForeignTarget e _) z = exp e z
 foldExpForeignTarget _   (PrimTarget _)      z = z
 

compiler/codeGen/StgCmmBind.hs

@@ -204,9 +204,8 @@ cgRhs :: Id
                                   -- (see above)
                )
 
-cgRhs id (StgRhsCon cc con args)
-  = withNewTickyCounterThunk (idName id) $
-    buildDynCon id True cc con args
+cgRhs name (StgRhsCon cc con args)
+  = buildDynCon name cc con args
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag _srt args body)
   = do dflags <- getDynFlags
@@ -364,7 +363,7 @@ mkRhsClosure _ bndr cc _ fvs upd_flag args body
         ; emit (mkComment $ mkFastString "calling allocDynClosure")
         ; let toVarArg (NonVoid a, off) = (NonVoid (StgVarArg a), off)
         ; let info_tbl = mkCmmInfo closure_info
-        ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
+        ; hp_plus_n <- allocDynClosure info_tbl lf_info use_cc blame_cc
                                          (map toVarArg fv_details)
 
         -- RETURN
@@ -382,9 +381,8 @@ cgRhsStdThunk bndr lf_info payload
        ; return (id_info, gen_code reg)
        }
  where
- gen_code reg  -- AHA!  A STANDARD-FORM THUNK
-  = withNewTickyCounterStdThunk (idName bndr) $
-    do
+ gen_code reg
+  = do  -- AHA!  A STANDARD-FORM THUNK
   {     -- LAY OUT THE OBJECT
     mod_name <- getModuleName
   ; dflags <- getDynFlags
@@ -399,11 +397,9 @@ cgRhsStdThunk bndr lf_info payload
 --  ; (use_cc, blame_cc) <- chooseDynCostCentres cc [{- no args-}] body
   ; let use_cc = curCCS; blame_cc = curCCS
 
-  ; tickyEnterStdThunk
-
         -- BUILD THE OBJECT
   ; let info_tbl = mkCmmInfo closure_info
-  ; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
+  ; hp_plus_n <- allocDynClosure info_tbl lf_info
                                    use_cc blame_cc payload_w_offsets
 
         -- RETURN
@@ -452,8 +448,7 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
 
 closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
   | arity == 0 -- No args i.e. thunk
-  = ASSERT ( not (isStaticClosure cl_info) )
-    withNewTickyCounterThunk (closureName cl_info) $
+  = withNewTickyCounterThunk cl_info $
     emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
    where
@@ -557,7 +552,7 @@ thunkCode cl_info fv_details _cc node arity body
             -- that cc of enclosing scope will be recorded
             -- in update frame CAF/DICT functions will be
             -- subsumed by this enclosing cc
-            do { tickyEnterThunk
+            do { tickyEnterThunk cl_info
                ; enterCostCentreThunk (CmmReg nodeReg)
                ; let lf_info = closureLFInfo cl_info
                ; fv_bindings <- mapM bind_fv fv_details
@@ -722,7 +717,7 @@ link_caf node _is_upd = do
         blame_cc = use_cc
         tso      = CmmReg (CmmGlobal CurrentTSO)
 
-  ; hp_rel <- allocDynClosureCmm Nothing cafBlackHoleInfoTable mkLFBlackHole
+  ; hp_rel <- allocDynClosureCmm cafBlackHoleInfoTable mkLFBlackHole
                                          use_cc blame_cc [(tso,fixedHdrSize dflags)]
         -- small optimisation: we duplicate the hp_rel expression in
         -- both the newCAF call and the value returned below.

compiler/codeGen/StgCmmCon.hs

@@ -109,21 +109,19 @@ cgTopRhsCon id con args
 
 buildDynCon :: Id                 -- Name of the thing to which this constr will
                                   -- be bound
-            -> Bool   -- is it genuinely bound to that name, or just for profiling?
             -> CostCentreStack    -- Where to grab cost centre from;
                                   -- current CCS if currentOrSubsumedCCS
             -> DataCon            -- The data constructor
             -> [StgArg]           -- Its args
             -> FCode (CgIdInfo, FCode CmmAGraph)
                -- Return details about how to find it and initialization code
-buildDynCon binder actually_bound cc con args
+buildDynCon binder cc con args
     = do dflags <- getDynFlags
-         buildDynCon' dflags (targetPlatform dflags) binder actually_bound cc con args
-
+         buildDynCon' dflags (targetPlatform dflags) binder cc con args
 
 buildDynCon' :: DynFlags
              -> Platform
-             -> Id -> Bool
+             -> Id
              -> CostCentreStack
              -> DataCon
              -> [StgArg]
@@ -150,7 +148,7 @@ premature looking at the args will cause the compiler to black-hole!
 -- which have exclusively size-zero (VoidRep) args, we generate no code
 -- at all.
 
-buildDynCon' dflags _ binder _ _cc con []
+buildDynCon' dflags _ binder _cc con []
   = return (litIdInfo dflags binder (mkConLFInfo con)
                 (CmmLabel (mkClosureLabel (dataConName con) (idCafInfo binder))),
             return mkNop)
@@ -181,7 +179,7 @@ We don't support this optimisation when compiling into Windows DLLs yet
 because they don't support cross package data references well.
 -}
 
-buildDynCon' dflags platform binder _ _cc con [arg]
+buildDynCon' dflags platform binder _cc con [arg]
   | maybeIntLikeCon con
   , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
   , StgLitArg (MachInt val) <- arg
@@ -195,7 +193,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
         ; return ( litIdInfo dflags binder (mkConLFInfo con) intlike_amode
                  , return mkNop) }
 
-buildDynCon' dflags platform binder _ _cc con [arg]
+buildDynCon' dflags platform binder _cc con [arg]
   | maybeCharLikeCon con
   , platformOS platform /= OSMinGW32 || not (gopt Opt_PIC dflags)
   , StgLitArg (MachChar val) <- arg
@@ -210,7 +208,7 @@ buildDynCon' dflags platform binder _ _cc con [arg]
                  , return mkNop) }
 
 -------- buildDynCon': the general case -----------
-buildDynCon' dflags _ binder actually_bound ccs con args
+buildDynCon' dflags _ binder ccs con args
   = do  { (id_info, reg) <- rhsIdInfo binder lf_info
         ; return (id_info, gen_code reg)
         }
@@ -224,10 +222,7 @@ buildDynCon' dflags _ binder actually_bound ccs con args
                 nonptr_wds = tot_wds - ptr_wds
                 info_tbl = mkDataConInfoTable dflags con False
                                 ptr_wds nonptr_wds
-          ; let ticky_name | actually_bound = Just binder
-                           | otherwise = Nothing
-
-          ; hp_plus_n <- allocDynClosure ticky_name info_tbl lf_info
+          ; hp_plus_n <- allocDynClosure info_tbl lf_info
                                           use_cc blame_cc args_w_offsets
           ; return (mkRhsInit dflags reg lf_info hp_plus_n) }
     where

compiler/codeGen/StgCmmExpr.hs

@@ -610,11 +610,10 @@ cgConApp con stg_args
 
   | otherwise   --  Boxed constructors; allocate and return
   = ASSERT( stg_args `lengthIs` dataConRepRepArity con )
-    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con) False
+    do  { (idinfo, fcode_init) <- buildDynCon (dataConWorkId con)
                                      currentCCS con stg_args
-                -- The first "con" says that the name bound to this
-                -- closure is is "con", which is a bit of a fudge, but
-                -- it only affects profiling (hence the False)
+                -- The first "con" says that the name bound to this closure is
+                -- is "con", which is a bit of a fudge, but it only affects profiling
 
         ; emit =<< fcode_init
         ; emitReturn [idInfoToAmode idinfo] }

compiler/codeGen/StgCmmHeap.hs

@@ -42,7 +42,6 @@ import Cmm
 import CmmUtils
 import CostCentre
 import IdInfo( CafInfo(..), mayHaveCafRefs )
-import Id ( Id )
 import Module
 import DynFlags
 import FastString( mkFastString, fsLit )
@@ -55,8 +54,7 @@ import Data.Maybe (isJust)
 -----------------------------------------------------------
 
 allocDynClosure
-        :: Maybe Id
-        -> CmmInfoTable
+        :: CmmInfoTable
         -> LambdaFormInfo
         -> CmmExpr              -- Cost Centre to stick in the object
         -> CmmExpr              -- Cost Centre to blame for this alloc
@@ -68,7 +66,7 @@ allocDynClosure
         -> FCode CmmExpr -- returns Hp+n
 
 allocDynClosureCmm
-        :: Maybe Id -> CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
+        :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
         -> [(CmmExpr, VirtualHpOffset)]
         -> FCode CmmExpr -- returns Hp+n
 
@@ -90,19 +88,19 @@ allocDynClosureCmm
 -- significant - see test T4801.
 
 
-allocDynClosure mb_id info_tbl lf_info use_cc _blame_cc args_w_offsets
+allocDynClosure info_tbl lf_info use_cc _blame_cc args_w_offsets
   = do  { let (args, offsets) = unzip args_w_offsets
         ; cmm_args <- mapM getArgAmode args     -- No void args
-        ; allocDynClosureCmm mb_id info_tbl lf_info
+        ; allocDynClosureCmm info_tbl lf_info
                              use_cc _blame_cc (zip cmm_args offsets)
         }
 
-allocDynClosureCmm mb_id info_tbl lf_info use_cc _blame_cc amodes_w_offsets
+allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets
   = do  { virt_hp <- getVirtHp
 
         -- SAY WHAT WE ARE ABOUT TO DO
         ; let rep = cit_rep info_tbl
-        ; tickyDynAlloc mb_id rep lf_info
+        ; tickyDynAlloc (toRednCountsLbl $ cit_lbl info_tbl) rep lf_info
         ; profDynAlloc rep use_cc
 
         -- FIND THE OFFSET OF THE INFO-PTR WORD

compiler/codeGen/StgCmmMonad.hs

@@ -514,7 +514,7 @@ getTickyCtrLabel = do
         info <- getInfoDown
         return (cgd_ticky info)
 
-setTickyCtrLabel :: CLabel -> FCode a -> FCode a
+setTickyCtrLabel :: CLabel -> FCode () -> FCode ()
 setTickyCtrLabel ticky code = do
         info <- getInfoDown
         withInfoDown code (info {cgd_ticky = ticky})