X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmHeap.hs;h=a02d2e24a373495d57c9c4df82fe8eb907053226;hb=c74c72f60dcc4cbea519826e98ec90ad8016b49d;hp=0e3501a7209c3c74a12a3ee5143c2fb8074f1d87;hpb=5d1c70a506f366eca47464f2a354de8cc0d9a795;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 0e3501a..a02d2e2 100644
--- a/compiler/codeGen/StgCmmHeap.hs
+++ b/compiler/codeGen/StgCmmHeap.hs
@@ -42,7 +42,6 @@ import CostCentre
 import Outputable
 import FastString( LitString, mkFastString, sLit )
 import Constants
-import Data.List
 
 
 -----------------------------------------------------------
@@ -334,7 +333,7 @@ These are used in the following circumstances
 --------------------------------------------------------------
 -- A heap/stack check at a function or thunk entry point.
 
-entryHeapCheck :: LocalReg	-- Function (closure environment)
+entryHeapCheck :: Maybe LocalReg -- Function (closure environment)
 	       -> Int           -- Arity -- not same as length args b/c of voids
 	       -> [LocalReg]	-- Non-void args (empty for thunk)
 	       -> FCode ()
@@ -344,15 +343,15 @@ entryHeapCheck fun arity args code
   = do updfr_sz <- getUpdFrameOff
        heapCheck True (gc_call updfr_sz) code   -- The 'fun' keeps relevant CAFs alive
   where
-    fun_expr = CmmReg (CmmLocal fun)
-    -- JD: ugh... we should only do the following for dynamic closures
-    args' = fun_expr : map (CmmReg . CmmLocal) args
+    args'     = case fun of Just f  -> f : args
+                            Nothing -> args
+    arg_exprs = map (CmmReg . CmmLocal) args'
     gc_call updfr_sz
-	| arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) args' updfr_sz
-	| otherwise  = case gc_lbl (fun : args) of
-		 	 Just lbl -> mkJumpGC (CmmLit (CmmLabel (mkRtsCodeLabel lbl)))
-					      args' updfr_sz
-			 Nothing  -> mkCall generic_gc (GC, GC) [] [] 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
+                         Nothing  -> mkCall generic_gc (GC, GC) [] [] updfr_sz
 
     gc_lbl :: [LocalReg] -> Maybe LitString
 {-