Catch too-large allocations and emit an error message (#4505)

[ghc-hetmet.git] / compiler / codeGen / StgCmmBind.hs

diff --git a/compiler/codeGen/StgCmmBind.hs b/compiler/codeGen/StgCmmBind.hs
index ad1b3e2..6451840 100644 (file)
--- a/compiler/codeGen/StgCmmBind.hs
+++ b/compiler/codeGen/StgCmmBind.hs
@@ -17,7 +17,6 @@ module StgCmmBind (
 
 import StgCmmExpr
 import StgCmmMonad
-import StgCmmExpr
 import StgCmmEnv
 import StgCmmCon
 import StgCmmHeap
@@ -37,7 +36,7 @@ import CLabel
 import StgSyn
 import CostCentre      
 import Id
-import Monad (foldM, liftM)
+import Control.Monad
 import Name
 import Module
 import ListSetOps
@@ -48,8 +47,6 @@ import Outputable
 import FastString
 import Maybes
 
-import Data.List
-
 ------------------------------------------------------------------------
 --             Top-level bindings
 ------------------------------------------------------------------------
@@ -87,8 +84,7 @@ cgTopRhsClosure id ccs _ upd_flag srt args body = do
   ; forkClosureBody (closureCodeBody True id closure_info ccs
                                      (nonVoidIds args) (length args) body fv_details)
 
-  ; pprTrace "arity for" (ppr id <+> ppr (length args) <+> ppr args) $
-    returnFC cg_id_info }
+  ; returnFC cg_id_info }
 
 ------------------------------------------------------------------------
 --             Non-top-level bindings
@@ -154,8 +150,7 @@ cgRhs name (StgRhsCon maybe_cc con args)
   = buildDynCon name maybe_cc con args
 
 cgRhs name (StgRhsClosure cc bi fvs upd_flag srt args body)
-  = pprTrace "cgRhs closure" (ppr name <+> ppr args) $
-    mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
+  = mkRhsClosure name cc bi (nonVoidIds fvs) upd_flag srt args body
 
 ------------------------------------------------------------------------
 --             Non-constructor right hand sides
@@ -396,21 +391,22 @@ closureCodeBody top_lvl bndr cl_info cc args arity body fv_details
 
        -- Emit the main entry code
         ; emitClosureProcAndInfoTable top_lvl bndr cl_info args $ \(node, arg_regs) -> do
-               -- Emit the slow-entry code (for entering a closure through a PAP)
-               { mkSlowEntryCode cl_info arg_regs
-
-               ; let lf_info = closureLFInfo cl_info
-                     node_points = nodeMustPointToIt lf_info
-               ; tickyEnterFun cl_info
-               ; whenC node_points (ldvEnterClosure cl_info)
-               ; granYield arg_regs node_points
-
-                       -- Main payload
-               ; entryHeapCheck node arity arg_regs $ do
-               { enterCostCentre cl_info cc body
+                    -- Emit the slow-entry code (for entering a closure through a PAP)
+                { mkSlowEntryCode cl_info arg_regs
+
+                ; let lf_info = closureLFInfo cl_info
+                      node_points = nodeMustPointToIt lf_info
+                ; tickyEnterFun cl_info
+                ; whenC node_points (ldvEnterClosure cl_info)
+                ; granYield arg_regs node_points
+
+                        -- Main payload
+                ; entryHeapCheck (if node_points then Just node else Nothing) arity arg_regs $ do
+                { enterCostCentre cl_info cc body
                 ; fv_bindings <- mapM bind_fv fv_details
-               ; load_fvs node lf_info fv_bindings -- Load free vars out of closure *after*
-               ; cgExpr body }}            -- heap check, to reduce live vars over check
+                -- Load free vars out of closure *after*
+                ; if node_points then load_fvs node lf_info fv_bindings else return ()
+                ; cgExpr body }}           -- heap check, to reduce live vars over check
 
   }
 
@@ -421,7 +417,7 @@ bind_fv (id, off) = do { reg <- rebindToReg id; return (reg, off) }
 
 load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, WordOff)] -> FCode ()
 load_fvs node lf_info = mapCs (\ (reg, off) ->
-      pprTrace "get tag for" (ppr reg <+> ppr tag) $ emit $ mkTaggedObjectLoad reg node off tag)
+      emit $ mkTaggedObjectLoad reg node off tag)
   where tag = lfDynTag lf_info
 
 -----------------------------------------
@@ -461,10 +457,11 @@ thunkCode cl_info fv_details cc node arity body
        ; granThunk node_points
 
         -- Heap overflow check
-       ; entryHeapCheck node arity [] $ do
+       ; entryHeapCheck (if node_points then Just node else Nothing) arity [] $ do
        {       -- Overwrite with black hole if necessary
                -- but *after* the heap-overflow check
-         whenC (blackHoleOnEntry cl_info && node_points)
+         dflags <- getDynFlags
+       ; whenC (blackHoleOnEntry dflags cl_info && node_points)
                (blackHoleIt cl_info)
 
                -- Push update frame
@@ -497,8 +494,8 @@ emitBlackHoleCode is_single_entry
   | otherwise = 
        nopC
   where
-    bh_lbl | is_single_entry = mkRtsDataLabel (sLit "stg_SE_BLACKHOLE_info")
-          | otherwise       = mkRtsDataLabel (sLit "stg_BLACKHOLE_info")
+    bh_lbl | is_single_entry = mkCmmDataLabel rtsPackageId (fsLit "stg_SE_BLACKHOLE_info")
+          | otherwise       = mkCmmDataLabel rtsPackageId (fsLit "stg_BLACKHOLE_info")
 
        -- If we wanted to do eager blackholing with slop filling,
        -- we'd need to do it at the *end* of a basic block, otherwise
@@ -597,7 +594,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
@@ -608,7 +605,10 @@ 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,AddrHint)] [node] False
+  ; emitRtsCallWithVols rtsPackageId (fsLit "newCAF")
+      [ (CmmReg (CmmGlobal BaseReg),  AddrHint),
+        (CmmReg nodeReg, AddrHint) ]
+      [node] False
        -- node is live, so save it.
 
        -- Overwrite the closure with a (static) indirection