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

compiler/cmm/CmmCallConv.hs

@@ -22,7 +22,6 @@ import Constants
 import qualified Data.List as L
 import DynFlags
 import Outputable
-import Platform
 
 -- Calculate the 'GlobalReg' or stack locations for function call
 -- parameters as used by the Cmm calling convention.
@@ -111,34 +110,19 @@ type AvailRegs = ( [VGcPtr -> GlobalReg]   -- available vanilla regs.
 -- We take these register supplies from the *real* registers, i.e. those
 -- that are guaranteed to map to machine registers.
 
-vanillaRegNos, floatRegNos, doubleRegNos, longRegNos :: DynFlags -> [Int]
-vanillaRegNos dflags
- | platformUnregisterised (targetPlatform dflags) = []
- | otherwise                                      = regList mAX_Real_Vanilla_REG
-floatRegNos dflags
- | platformUnregisterised (targetPlatform dflags) = []
- | otherwise                                      = regList mAX_Real_Float_REG
-doubleRegNos dflags
- | platformUnregisterised (targetPlatform dflags) = []
- | otherwise                                      = regList mAX_Real_Double_REG
-longRegNos dflags
- | platformUnregisterised (targetPlatform dflags) = []
- | otherwise                                      = regList mAX_Real_Long_REG
-
--- 
 getRegsWithoutNode, getRegsWithNode :: DynFlags -> AvailRegs
-getRegsWithoutNode dflags =
-  (filter (\r -> r VGcPtr /= node) intRegs,
-   map FloatReg  (floatRegNos dflags),
-   map DoubleReg (doubleRegNos dflags),
-   map LongReg   (longRegNos dflags))
-    where intRegs = map VanillaReg (vanillaRegNos dflags)
-getRegsWithNode dflags =
-  (intRegs,
-   map FloatReg  (floatRegNos dflags),
-   map DoubleReg (doubleRegNos dflags),
-   map LongReg   (longRegNos dflags))
-    where intRegs = map VanillaReg (vanillaRegNos dflags)
+getRegsWithoutNode _dflags =
+  ( filter (\r -> r VGcPtr /= node) realVanillaRegs
+  , realFloatRegs
+  , realDoubleRegs
+  , realLongRegs )
+
+-- getRegsWithNode uses R1/node even if it isn't a register
+getRegsWithNode _dflags =
+  ( if null realVanillaRegs then [VanillaReg 1] else realVanillaRegs
+  , realFloatRegs
+  , realDoubleRegs
+  , realLongRegs )
 
 allFloatRegs, allDoubleRegs, allLongRegs :: [GlobalReg]
 allVanillaRegs :: [VGcPtr -> GlobalReg]
@@ -148,6 +132,14 @@ allFloatRegs   = map FloatReg   $ regList mAX_Float_REG
 allDoubleRegs  = map DoubleReg  $ regList mAX_Double_REG
 allLongRegs    = map LongReg    $ regList mAX_Long_REG
 
+realFloatRegs, realDoubleRegs, realLongRegs :: [GlobalReg]
+realVanillaRegs :: [VGcPtr -> GlobalReg]
+
+realVanillaRegs = map VanillaReg $ regList mAX_Real_Vanilla_REG
+realFloatRegs   = map FloatReg   $ regList mAX_Real_Float_REG
+realDoubleRegs  = map DoubleReg  $ regList mAX_Real_Double_REG
+realLongRegs    = map LongReg    $ regList mAX_Real_Long_REG
+
 regList :: Int -> [Int]
 regList n = [1 .. n]
 

compiler/cmm/CmmExpr.hs

@@ -345,9 +345,11 @@ instance Eq GlobalReg where
    SpLim == SpLim = True
    Hp == Hp = True
    HpLim == HpLim = True
+   CCCS == CCCS = True
    CurrentTSO == CurrentTSO = True
    CurrentNursery == CurrentNursery = True
    HpAlloc == HpAlloc = True
+   EagerBlackholeInfo == EagerBlackholeInfo = True
    GCEnter1 == GCEnter1 = True
    GCFun == GCFun = True
    BaseReg == BaseReg = True

compiler/cmm/CmmLayoutStack.hs

@@ -26,8 +26,6 @@ import Util
 import DynFlags
 import FastString
 import Outputable
-import Data.Map (Map)
-import qualified Data.Map as Map
 import qualified Data.Set as Set
 import Control.Monad.Fix
 import Data.Array as Array
@@ -485,12 +483,11 @@ spOffsetForCall current_sp cont_stack args
 fixupStack :: StackMap -> StackMap -> [CmmNode O O]
 fixupStack old_stack new_stack = concatMap move new_locs
  where
-     old_map :: Map LocalReg ByteOff
-     old_map  = Map.fromList (stackSlotRegs old_stack)
+     old_map  = sm_regs old_stack
      new_locs = stackSlotRegs new_stack
 
      move (r,n)
-       | Just m <- Map.lookup r old_map, n == m = []
+       | Just (_,m) <- lookupUFM old_map r, n == m = []
        | otherwise = [CmmStore (CmmStackSlot Old n)
                                (CmmReg (CmmLocal r))]
 

compiler/cmm/CmmLint.hs

@@ -13,6 +13,7 @@ module CmmLint (
 import Hoopl
 import Cmm
 import CmmUtils
+import CmmLive
 import PprCmm ()
 import BlockId
 import FastString
@@ -53,7 +54,10 @@ lintCmmDecl (CmmData {})
 
 
 lintCmmGraph :: CmmGraph -> CmmLint ()
-lintCmmGraph g = mapM_ (lintCmmBlock labels) blocks
+lintCmmGraph g = cmmLiveness g `seq` mapM_ (lintCmmBlock labels) blocks
+                 -- cmmLiveness throws an error if there are registers
+                 -- live on entry to the graph (i.e. undefined
+                 -- variables)
   where
        blocks = toBlockList g
        labels = setFromList (map entryLabel blocks)

compiler/cmm/CmmMachOp.hs

@@ -274,12 +274,6 @@ maybeInvertComparison op
         MO_S_Gt r -> Just (MO_S_Le r)
         MO_S_Le r -> Just (MO_S_Gt r)
         MO_S_Ge r -> Just (MO_S_Lt r)
-        MO_F_Eq r -> Just (MO_F_Ne r)
-        MO_F_Ne r -> Just (MO_F_Eq r)
-        MO_F_Ge r -> Just (MO_F_Le r)
-        MO_F_Le r -> Just (MO_F_Ge r)
-        MO_F_Gt r -> Just (MO_F_Lt r)
-        MO_F_Lt r -> Just (MO_F_Gt r)
         _other    -> Nothing
 
 -- ----------------------------------------------------------------------------

compiler/cmm/MkGraph.hs

@@ -167,6 +167,7 @@ mkComment _   = nilOL
 
 ---------- Assignment and store
 mkAssign     :: CmmReg  -> CmmExpr -> CmmAGraph
+mkAssign l (CmmReg r) | l == r  = mkNop
 mkAssign l r  = mkMiddle $ CmmAssign l r
 
 mkStore      :: CmmExpr -> CmmExpr -> CmmAGraph

compiler/codeGen/StgCmmBind.hs

@@ -104,7 +104,8 @@ cgBind :: StgBinding -> FCode ()
 cgBind (StgNonRec name rhs)
   = do	{ ((info, init), body) <- getCodeR $ cgRhs name rhs
         ; addBindC (cg_id info) info
-        ; emit (init <*> body) }
+        ; emit (body <*> init) }
+        -- init cannot be used in body, so slightly better to sink it eagerly
 
 cgBind (StgRec pairs)
   = do  { ((new_binds, inits), body) <- getCodeR $ fixC (\ new_binds_inits ->
@@ -311,11 +312,11 @@ 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
-        ; (tmp, init) <- allocDynClosure 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
-	; regIdInfo bndr lf_info tmp init }
+        ; regIdInfo bndr lf_info hp_plus_n }
 
 -- Use with care; if used inappropriately, it could break invariants.
 stripNV :: NonVoid a -> a
@@ -349,11 +350,11 @@ cgStdThunk bndr _cc _bndr_info _body lf_info payload
 
 	-- BUILD THE OBJECT
   ; let info_tbl = mkCmmInfo closure_info
-  ; (tmp, init) <- allocDynClosure info_tbl lf_info
+  ; hp_plus_n <- allocDynClosure info_tbl lf_info
                                    use_cc blame_cc payload_w_offsets
 
 	-- RETURN
-  ; regIdInfo bndr lf_info tmp init }
+  ; regIdInfo bndr lf_info hp_plus_n }
 
 mkClosureLFInfo :: Id		-- The binder
 		-> TopLevelFlag	-- True of top level
@@ -394,16 +395,16 @@ closureCodeBody :: Bool            -- whether this is a top-level binding
   argSatisfactionCheck (by calling fetchAndReschedule).
   There info if Node points to closure is available. -- HWL -}
 
-closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
-  | length args == 0 -- No args i.e. thunk
+closureCodeBody top_lvl bndr cl_info cc _args arity body fv_details
+  | arity == 0 -- No args i.e. thunk
   = emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl [] $
       \(_, node, _) -> thunkCode cl_info fv_details cc node arity body
    where
      lf_info  = closureLFInfo cl_info
      info_tbl = mkCmmInfo cl_info
 
-closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
-  = ASSERT( length args > 0 )
+closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
+  = -- Note: args may be [], if all args are Void
     do  { -- Allocate the global ticky counter,
           -- and establish the ticky-counter
           -- label for this block
@@ -417,7 +418,7 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
 
         -- Emit the main entry code
         ; emitClosureProcAndInfoTable top_lvl bndr lf_info info_tbl args $
-            \(offset, node, arg_regs) -> do
+            \(_offset, node, arg_regs) -> do
                 -- Emit slow-entry code (for entering a closure through a PAP)
                 { mkSlowEntryCode cl_info arg_regs
 
@@ -426,11 +427,15 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
                       node_points = nodeMustPointToIt dflags lf_info
                       node' = if node_points then Just node else Nothing
                 ; tickyEnterFun cl_info
+                ; enterCostCentreFun cc
+                    (CmmMachOp mo_wordSub
+                         [ CmmReg nodeReg
+                         , CmmLit (mkIntCLit (funTag cl_info)) ])
                 ; whenC node_points (ldvEnterClosure cl_info)
                 ; granYield arg_regs node_points
 
                 -- Main payload
-                ; entryHeapCheck cl_info offset node' arity arg_regs $ do
+                ; entryHeapCheck cl_info node' arity arg_regs $ do
                 { fv_bindings <- mapM bind_fv fv_details
                 -- Load free vars out of closure *after*
                 -- heap check, to reduce live vars over check
@@ -463,7 +468,6 @@ mkSlowEntryCode :: ClosureInfo -> [LocalReg] -> FCode ()
 -- If this function doesn't have a specialised ArgDescr, we need
 -- to generate the function's arg bitmap and slow-entry code.
 -- Here, we emit the slow-entry code.
-mkSlowEntryCode _ [] = panic "entering a closure with no arguments?"
 mkSlowEntryCode cl_info arg_regs -- function closure is already in `Node'
   | Just (_, ArgGen _) <- closureFunInfo cl_info
   = do dflags <- getDynFlags
@@ -489,7 +493,7 @@ thunkCode cl_info fv_details _cc node arity body
         ; granThunk node_points
 
         -- Heap overflow check
-        ; entryHeapCheck cl_info 0 node' arity [] $ do
+        ; entryHeapCheck cl_info node' arity [] $ do
         { -- Overwrite with black hole if necessary
           -- but *after* the heap-overflow check
         ; whenC (blackHoleOnEntry cl_info && node_points)
@@ -574,16 +578,15 @@ setupUpdate closure_info node body
               lbl | bh        = mkBHUpdInfoLabel
                   | otherwise = mkUpdInfoLabel
 
-          pushUpdateFrame [CmmReg (CmmLocal node), mkLblExpr lbl] body
+          pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
 
   | otherwise	-- A static closure
   = do 	{ tickyUpdateBhCaf closure_info
 
 	; if closureUpdReqd closure_info
 	  then do	-- Blackhole the (updatable) CAF:
-                { upd_closure <- link_caf True
-                ; pushUpdateFrame [upd_closure,
-                                   mkLblExpr mkBHUpdInfoLabel] body }
+                { upd_closure <- link_caf node True
+                ; pushUpdateFrame mkBHUpdInfoLabel upd_closure body }
 	  else do {tickyUpdateFrameOmitted; body}
     }
 
@@ -593,16 +596,21 @@ setupUpdate closure_info node body
 -- Push the update frame on the stack in the Entry area,
 -- leaving room for the return address that is already
 -- at the old end of the area.
-pushUpdateFrame :: [CmmExpr] -> FCode () -> FCode ()
-pushUpdateFrame es body
-  = do -- [EZY] I'm not sure if we need to special-case for BH too
+--
+pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
+pushUpdateFrame lbl updatee body
+  = do
        updfr  <- getUpdFrameOff
-       offset <- foldM push updfr es
-       withUpdFrameOff offset body
-     where push off e =
-             do emitStore (CmmStackSlot Old base) e
-                return base
-             where base = off + widthInBytes (cmmExprWidth e)
+       dflags <- getDynFlags
+       let
+           hdr         = fixedHdrSize dflags * wORD_SIZE
+           frame       = updfr + hdr + sIZEOF_StgUpdateFrame_NoHdr
+           off_updatee = hdr + oFFSET_StgUpdateFrame_updatee
+       --
+       emitStore (CmmStackSlot Old frame) (mkLblExpr lbl)
+       emitStore (CmmStackSlot Old (frame - off_updatee)) updatee
+       initUpdFrameProf frame
+       withUpdFrameOff frame body
 
 -----------------------------------------------------------------------------
 -- Entering a CAF
@@ -637,7 +645,8 @@ pushUpdateFrame es body
 -- be closer together, and the compiler wouldn't need to know
 -- about off_indirectee etc.
 
-link_caf :: Bool               -- True <=> updatable, False <=> single-entry
+link_caf :: LocalReg           -- pointer to the closure
+         -> Bool               -- True <=> updatable, False <=> single-entry
          -> FCode CmmExpr      -- Returns amode for closure to be updated
 -- To update a CAF we must allocate a black hole, link the CAF onto the
 -- CAF list, then update the CAF to point to the fresh black hole.
@@ -645,7 +654,7 @@ link_caf :: Bool               -- True <=> updatable, False <=> single-entry
 -- 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 _is_upd = do
+link_caf node _is_upd = do
   { dflags <- getDynFlags
     -- Alloc black hole specifying CC_HDR(Node) as the cost centre
   ; let	use_cc   = costCentreFrom (CmmReg nodeReg)
@@ -668,9 +677,9 @@ link_caf _is_upd = do
   ; ret <- newTemp bWord
   ; emitRtsCallGen [(ret,NoHint)] rtsPackageId (fsLit "newCAF")
       [ (CmmReg (CmmGlobal BaseReg),  AddrHint),
-        (CmmReg nodeReg, AddrHint),
+        (CmmReg (CmmLocal node), AddrHint),
         (hp_rel, AddrHint) ]
-      (Just [node]) False
+      False
         -- node is live, so save it.
 
   -- see Note [atomic CAF entry] in rts/sm/Storage.c
@@ -680,7 +689,7 @@ link_caf _is_upd = do
         -- re-enter R1.  Doing this directly is slightly dodgy; we're
         -- assuming lots of things, like the stack pointer hasn't
         -- moved since we entered the CAF.
-       (let target = entryCode dflags (closureInfoPtr (CmmReg nodeReg)) in
+       (let target = entryCode dflags (closureInfoPtr (CmmReg (CmmLocal node))) in
         mkJump dflags target [] updfr)
 
   ; return hp_rel }

compiler/codeGen/StgCmmCon.hs

@@ -210,9 +210,9 @@ buildDynCon' dflags _ binder ccs con args
                 -- No void args in args_w_offsets
               nonptr_wds = tot_wds - ptr_wds
               info_tbl = mkDataConInfoTable dflags con False ptr_wds nonptr_wds
-        ; (tmp, init) <- allocDynClosure info_tbl lf_info
+        ; hp_plus_n <- allocDynClosure info_tbl lf_info
                                          use_cc blame_cc args_w_offsets
-        ; regIdInfo binder lf_info tmp init }
+        ; regIdInfo binder lf_info hp_plus_n }
   where
     lf_info = mkConLFInfo con
 

compiler/codeGen/StgCmmEnv.hs

@@ -44,7 +44,7 @@ import CLabel
 import BlockId
 import CmmExpr
 import CmmUtils
-import MkGraph (CmmAGraph, mkAssign, (<*>))
+import MkGraph (CmmAGraph, mkAssign)
 import FastString
 import Id
 import VarEnv
@@ -103,13 +103,12 @@ lneIdInfo id regs
 -- register, and store a plain register in the CgIdInfo.  We allocate
 -- a new register in order to keep single-assignment and help out the
 -- inliner. -- EZY
-regIdInfo :: Id -> LambdaFormInfo -> LocalReg -> CmmAGraph -> FCode (CgIdInfo, CmmAGraph)
-regIdInfo id lf_info reg init 
-  = do { reg' <- newTemp (localRegType reg)
-       ; let init' = init <*> mkAssign (CmmLocal reg') 
-                                       (addDynTag (CmmReg (CmmLocal reg)) 
-                                                  (lfDynTag lf_info))
-       ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg')), init') }
+regIdInfo :: Id -> LambdaFormInfo -> CmmExpr -> FCode (CgIdInfo, CmmAGraph)
+regIdInfo id lf_info expr
+  = do { reg <- newTemp (cmmExprType expr)
+       ; let init = mkAssign (CmmLocal reg)
+                             (addDynTag expr (lfDynTag lf_info))
+       ; return (mkCgIdInfo id lf_info (CmmReg (CmmLocal reg)), init) }
 
 idInfoToAmode :: CgIdInfo -> CmmExpr
 -- Returns a CmmExpr for the *tagged* pointer

compiler/codeGen/StgCmmExpr.hs

@@ -432,8 +432,8 @@ cgCase scrut bndr alt_type alts
 -----------------
 maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
 maybeSaveCostCentre simple_scrut
-  | simple_scrut = saveCurrentCostCentre
-  | otherwise    = return Nothing
+  | simple_scrut = return Nothing
+  | otherwise    = saveCurrentCostCentre
 
 
 -----------------

compiler/codeGen/StgCmmHeap.hs

@@ -15,7 +15,7 @@ module StgCmmHeap (
         mkVirtHeapOffsets, mkVirtConstrOffsets,
         mkStaticClosureFields, mkStaticClosure,
 
-        allocDynClosure, allocDynClosureReg, allocDynClosureCmm,
+        allocDynClosure, allocDynClosureCmm,
         emitSetDynHdr
     ) where
 
@@ -63,12 +63,7 @@ allocDynClosure
         -> [(NonVoid StgArg, VirtualHpOffset)]  -- Offsets from start of object
                                                 -- ie Info ptr has offset zero.
                                                 -- No void args in here
-        -> FCode (LocalReg, CmmAGraph)
-
-allocDynClosureReg
-        :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
-        -> [(CmmExpr, VirtualHpOffset)]
-        -> FCode (LocalReg, CmmAGraph)
+        -> FCode CmmExpr -- returns Hp+n
 
 allocDynClosureCmm
         :: CmmInfoTable -> LambdaFormInfo -> CmmExpr -> CmmExpr
@@ -81,32 +76,25 @@ allocDynClosureCmm
 -- returned LocalReg, which should point to the closure after executing
 -- the graph.
 
--- Note [Return a LocalReg]
--- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
--- allocDynClosure returns a LocalReg, not a (Hp+8) CmmExpr.
--- Reason:
---      ...allocate object...
---      obj = Hp + 8
---      y = f(z)
---      ...here obj is still valid,
---         but Hp+8 means something quite different...
+-- allocDynClosure returns an (Hp+8) CmmExpr, and hence the result is
+-- only valid until Hp is changed.  The caller should assign the
+-- result to a LocalReg if it is required to remain live.
+--
+-- The reason we don't assign it to a LocalReg here is that the caller
+-- is often about to call regIdInfo, which immediately assigns the
+-- result of allocDynClosure to a new temp in order to add the tag.
+-- So by not generating a LocalReg here we avoid a common source of
+-- new temporaries and save some compile time.  This can be quite
+-- significant - see test T4801.
 
 
 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
-        ; allocDynClosureReg info_tbl lf_info
+        ; allocDynClosureCmm info_tbl lf_info
                              use_cc _blame_cc (zip cmm_args offsets)
         }
 
-allocDynClosureReg  info_tbl lf_info use_cc _blame_cc amodes_w_offsets
-  = do  { hp_rel <- allocDynClosureCmm info_tbl lf_info
-                                       use_cc _blame_cc amodes_w_offsets
-
-        -- Note [Return a LocalReg]
-        ; getCodeR $ assignTemp hp_rel
-        }
-
 allocDynClosureCmm info_tbl lf_info use_cc _blame_cc amodes_w_offsets
   = do  { virt_hp <- getVirtHp
 
@@ -340,14 +328,13 @@ These are used in the following circumstances
 -- A heap/stack check at a function or thunk entry point.
 
 entryHeapCheck :: ClosureInfo
-               -> Int            -- Arg Offset
                -> Maybe LocalReg -- Function (closure environment)
                -> Int            -- Arity -- not same as len args b/c of voids
                -> [LocalReg]     -- Non-void args (empty for thunk)
                -> FCode ()
                -> FCode ()
 
-entryHeapCheck cl_info offset nodeSet arity args code
+entryHeapCheck cl_info nodeSet arity args code
   = do dflags <- getDynFlags
        let is_thunk = arity == 0
            is_fastf = case closureFunInfo cl_info of
@@ -355,25 +342,31 @@ entryHeapCheck cl_info offset nodeSet arity args code
                            _otherwise         -> True
 
            args' = map (CmmReg . CmmLocal) args
-           setN = case nodeSet of
-                          Just _  -> mkNop -- No need to assign R1, it already
-                                           -- points to the closure
-                          Nothing -> mkAssign nodeReg $
-                              CmmLit (CmmLabel $ staticClosureLabel cl_info)
-
-           {- Thunks:          jump GCEnter1
-              Function (fast): Set R1 = node, jump GCFun
-              Function (slow): Set R1 = node, call generic_gc -}
-           gc_call upd = setN <*> gc_lbl upd
-           gc_lbl upd
-               | is_thunk  = mkDirectJump dflags (CmmReg $ CmmGlobal GCEnter1) [] sp
-               | is_fastf  = mkDirectJump dflags (CmmReg $ CmmGlobal GCFun) [] sp
-               | otherwise = mkForeignJump dflags Slow (CmmReg $ CmmGlobal GCFun) args' upd
-               where sp = max offset upd
-           {- DT (12/08/10) This is a little fishy, mainly the sp fix up amount.
-            - This is since the ncg inserts spills before the stack/heap check.
-            - This should be fixed up and then we won't need to fix up the Sp on
-            - GC calls, but until then this fishy code works -}
+           node = case nodeSet of
+                      Just r  -> CmmReg (CmmLocal r)
+                      Nothing -> CmmLit (CmmLabel $ staticClosureLabel cl_info)
+           stg_gc_fun    = CmmReg (CmmGlobal GCFun)
+           stg_gc_enter1 = CmmReg (CmmGlobal GCEnter1)
+
+           {- Thunks:          jump stg_gc_enter_1
+
+              Function (fast): call (NativeNode) stg_gc_fun(fun, args)
+
+              Function (slow): R1 = fun
+                               call (slow) stg_gc_fun(args)
+               XXX: this is a bit naughty, we should really pass R1 as an
+               argument and use a special calling convention.
+           -}
+           gc_call upd
+               | is_thunk
+                 = mkJump dflags stg_gc_enter1 [node] upd
+
+               | is_fastf
+                 = mkJump dflags stg_gc_fun (node : args') upd
+
+               | otherwise
+                 = mkAssign nodeReg node <*>
+                   mkForeignJump dflags Slow stg_gc_fun args' upd
 
        updfr_sz <- getUpdFrameOff
 

compiler/codeGen/StgCmmProf.hs

@@ -19,7 +19,7 @@ module StgCmmProf (
 
 	-- Cost-centre Profiling
 	dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
-        enterCostCentreThunk,
+        enterCostCentreThunk, enterCostCentreFun,
         costCentreFrom,
         curCCS, storeCurCCS,
         emitSetCCC,
@@ -99,11 +99,11 @@ dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
 -- Profiling header words in a dynamic closure
 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit]
 
-initUpdFrameProf :: CmmExpr -> FCode ()
+initUpdFrameProf :: ByteOff -> FCode ()
 -- Initialise the profiling field of an update frame
-initUpdFrameProf frame_amode 
+initUpdFrameProf frame_off
   = ifProfiling $	-- frame->header.prof.ccs = CCCS
-    emitStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS
+    emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs)) curCCS
 	-- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) 
 	-- is unnecessary because it is not used anyhow.
 
@@ -190,6 +190,15 @@ enterCostCentreThunk closure =
   ifProfiling $ do 
     emit $ storeCurCCS (costCentreFrom closure)
 
+enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
+enterCostCentreFun ccs closure =
+  ifProfiling $ do
+    if isCurrentCCS ccs
+       then emitRtsCall rtsPackageId (fsLit "enterFunCCS")
+               [(CmmReg (CmmGlobal BaseReg), AddrHint),
+                (costCentreFrom closure, AddrHint)] False
+       else return () -- top-level function, nothing to do
+
 ifProfiling :: FCode () -> FCode ()
 ifProfiling code
   = do dflags <- getDynFlags
@@ -224,20 +233,19 @@ emitCostCentreDecl cc = do
                                         $ Module.moduleName
                                         $ cc_mod cc)
   ; dflags <- getDynFlags
-  ; loc <- newStringCLit (showPpr dflags (costCentreSrcSpan cc))
-           -- XXX should UTF-8 encode
-                -- All cost centres will be in the main package, since we
-                -- don't normally use -auto-all or add SCCs to other packages.
-                -- Hence don't emit the package name in the module here.
-  ; let lits = [ zero,    -- StgInt ccID,
-	      	 label,	  -- char *label,
-                 modl,    -- char *module,
-                 loc,     -- char *srcloc,
-                 zero64,  -- StgWord64 mem_alloc
-                 zero,    -- StgWord time_ticks
-                 is_caf,  -- StgInt is_caf
-                 zero     -- struct _CostCentre *link
-	       ] 
+  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
+                   showPpr dflags (costCentreSrcSpan cc)
+           -- XXX going via FastString to get UTF-8 encoding is silly
+  ; let
+     lits = [ zero,   	-- StgInt ccID,
+	      label,	-- char *label,
+	      modl,	-- char *module,
+              loc,      -- char *srcloc,
+              zero64,   -- StgWord64 mem_alloc
+              zero,     -- StgWord time_ticks
+              is_caf,   -- StgInt is_caf
+              zero      -- struct _CostCentre *link
+	    ] 
   ; emitDataLits (mkCCLabel cc) lits
   }
   where
@@ -289,7 +297,7 @@ pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
 pushCostCentre result ccs cc
   = emitRtsCallWithResult result AddrHint
 	rtsPackageId
-	(fsLit "PushCostCentre") [(ccs,AddrHint), 
+        (fsLit "pushCostCentre") [(ccs,AddrHint),
 				(CmmLit (mkCCostCentre cc), AddrHint)]
         False