X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmHeap.hs;h=d7eafe3dbaa22f6a2f3b505cdb69f9c68e12a78a;hp=713857929ac2439a48ff1e52bcc4ab385a68f163;hb=a02e7f40afc1aab7fe466f949f505c1d7250713d;hpb=6bc92166180824bf046d31e378359e3c386150f9

diff --git a/compiler/codeGen/StgCmmHeap.hs b/compiler/codeGen/StgCmmHeap.hs
index 7138579..d7eafe3 100644
--- 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
 
 
 -----------------------------------------------------------
@@ -334,7 +334,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,17 +344,18 @@ 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 [] [] updfr_sz
-
-    gc_lbl :: [LocalReg] -> Maybe LitString
+        | arity == 0 = mkJumpGC (CmmReg (CmmGlobal GCEnter1)) arg_exprs updfr_sz
+        | otherwise  = case gc_lbl args' of
+                         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 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")
@@ -386,13 +387,14 @@ altHeapCheck regs code
        heapCheck False (gc_call updfr_sz) code
   where
     gc_call updfr_sz
-	| null regs = mkCall generic_gc GC [] [] 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
-		    regs (map (CmmReg . CmmLocal) regs) updfr_sz
+	= 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 [] [] updfr_sz
+	= mkCall generic_gc (GC, GC) [] [] updfr_sz
 
 {-
     rts_label [reg] 
@@ -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")))
 
@@ -437,7 +439,7 @@ do_checks :: Bool       -- Should we check the stack?
 do_checks checkStack alloc do_gc
   = withFreshLabel "gc" $ \ loop_id ->
     withFreshLabel "gc" $ \ gc_id   ->
-      mkLabel loop_id emptyStackInfo
+      mkLabel loop_id 
       <*> (let hpCheck = if alloc == 0 then mkNop
                          else mkAssign hpReg bump_hp <*>
                               mkCmmIfThen hp_oflo (save_alloc <*> mkBranch gc_id)
@@ -445,7 +447,7 @@ do_checks checkStack alloc do_gc
                 mkCmmIfThenElse sp_oflo (mkBranch gc_id) hpCheck
               else hpCheck)
       <*> mkComment (mkFastString "outOfLine should follow:")
-      <*> outOfLine (mkLabel gc_id emptyStackInfo
+      <*> outOfLine (mkLabel gc_id 
                      <*> mkComment (mkFastString "outOfLine here")
                      <*> do_gc
                      <*> mkBranch loop_id)