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

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

diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 817a896..4163723 100644 (file)
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -40,9 +40,9 @@ import DataCon
 import TyCon
 import CostCentre
 import Outputable
-import FastString( LitString, mkFastString, sLit )
+import Module
+import FastString( mkFastString, FastString, fsLit )
 import Constants
-import Data.List
 
 
 -----------------------------------------------------------
@@ -350,11 +350,12 @@ entryHeapCheck fun arity args code
     gc_call updfr_sz
         | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
         | otherwise  = case gc_lbl args' of
-                         Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
-                                              arg_exprs updfr_sz
+                         Just _lbl -> panic "StgCmmHeap.entryHeapCheck: gc_lbl not finished"
+                                    -- mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
+                                     --         arg_exprs updfr_sz
                          Nothing  -> mkCall generic_gc (GC, GC) [] [] updfr_sz
 
-    gc_lbl :: [LocalReg] -> Maybe LitString
+    gc_lbl :: [LocalReg] -> Maybe FastString
 {-
     gc_lbl [reg]
        | isGcPtrType ty  = Just (sLit "stg_gc_unpt_r1") -- "stg_gc_fun_1p"
@@ -373,7 +374,7 @@ entryHeapCheck fun arity args code
 
     gc_lbl regs = gc_lbl_ptrs (map (isGcPtrType . localRegType) regs)
 
-    gc_lbl_ptrs :: [Bool] -> Maybe LitString
+    gc_lbl_ptrs :: [Bool] -> Maybe FastString
     -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
     --gc_lbl_ptrs [True,True]      = Just (sLit "stg_gc_fun_2p")
     --gc_lbl_ptrs [True,True,True] = Just (sLit "stg_gc_fun_3p")
@@ -388,9 +389,10 @@ altHeapCheck regs code
     gc_call updfr_sz
        | null regs = mkCall generic_gc (GC, GC) [] [] updfr_sz
 
-       | Just gc_lbl <- rts_label regs -- Canned call
-       = mkCall    (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC)
-                   regs (map (CmmReg . CmmLocal) regs) updfr_sz
+       | Just _gc_lbl <- rts_label regs        -- Canned call
+       = panic "StgCmmHeap.altHeapCheck: rts_label not finished"
+               -- mkCall    (CmmLit (CmmLabel (mkRtsCodeLabel gc_lbl))) (GC, GC)
+               --          regs (map (CmmReg . CmmLocal) regs) updfr_sz
        | otherwise             -- No canned call, and non-empty live vars
        = mkCall generic_gc (GC, GC) [] [] updfr_sz
 
@@ -414,7 +416,7 @@ altHeapCheck regs code
 
 
 generic_gc :: CmmExpr  -- The generic GC procedure; no params, no resuls
-generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_noregs")))
+generic_gc = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "stg_gc_noregs")))
 -- JD: TEMPORARY -- UNTIL THOSE FUNCTIONS EXIST...
 -- generic_gc = CmmLit (CmmLabel (mkRtsCodeLabel (sLit "stg_gc_fun")))