X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FCgClosure.lhs;h=d0f9bf808c414229e3d277a7f18a4c2ce6a8c1c6;hb=573ef10b2afd99d3c6a36370a9367609716c97d2;hp=8bf533fcc40e96d9e15b4ec0f7aaf64ef012fdde;hpb=30f15b4e7d579dc142537342161c460c6b80290b;p=ghc-hetmet.git

diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index 8bf533f..d0f9bf8 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -1,5 +1,5 @@
 %
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
 %
 \section[CgClosure]{Code generation for closures}
 
@@ -49,7 +49,7 @@ import ClosureInfo	-- lots and lots of stuff
 import CmdLineOpts	( opt_ForConcurrent, opt_GranMacros )
 import CostCentre	( useCurrentCostCentre, currentOrSubsumedCosts,
 			  noCostCentreAttached, costsAreSubsumed,
-			  isCafCC, isDictCC, overheadCostCentre
+			  isCafCC, isDictCC, overheadCostCentre, showCostCentre
 			)
 import HeapOffs		( SYN_IE(VirtualHeapOffset) )
 import Id		( idType, idPrimRep, 
@@ -59,13 +59,14 @@ import Id		( idType, idPrimRep,
 			)
 import ListSetOps	( minusList )
 import Maybes		( maybeToBool )
+import Outputable	( Outputable(..){-instances-} ) -- ToDo:rm
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-}, TyCon{-ditto-} )
-import Pretty		( prettyToUn, ppBesides, ppChar, ppPStr )
+import Pretty		( prettyToUn, ppBesides, ppChar, ppPStr, ppCat, ppStr )
 import PrimRep		( isFollowableRep, PrimRep(..) )
 import TyCon		( isPrimTyCon, tyConDataCons )
 import Unpretty		( uppShow )
-import Util		( isIn, panic, pprPanic, assertPanic )
+import Util		( isIn, panic, pprPanic, assertPanic, pprTrace{-ToDo:rm-} )
 
 myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
 showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
@@ -409,8 +410,12 @@ closureCodeBody binder_info closure_info cc [] body
 
     body_addr   = CLbl (entryLabelFromCI closure_info) CodePtrRep
     body_code   = profCtrC SLIT("ENT_THK") [] 			`thenC`
-		  enterCostCentreCode closure_info cc IsThunk	`thenC`
-		  thunkWrapper closure_info (cgExpr body)
+		  thunkWrapper closure_info (
+			-- We only enter cc after setting up update so that cc
+			-- of enclosing scope will be recorded in update frame
+			-- CAF/DICT functions will be subsumed by this enclosing cc
+		    enterCostCentreCode closure_info cc IsThunk	`thenC`
+		    cgExpr body)
 
     stdUpd      = CLbl mkErrorStdEntryLabel CodePtrRep
 \end{code}
@@ -580,9 +585,9 @@ Node is guaranteed to point to it, if profiling and not inherited.
 
 \begin{code}
 data IsThunk = IsThunk | IsFunction -- Bool-like, local
-#ifdef DEBUG
+--#ifdef DEBUG
 	deriving Eq
-#endif
+--#endif
 
 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
 
@@ -594,8 +599,9 @@ enterCostCentreCode closure_info cc is_thunk
 	ASSERT(not (noCostCentreAttached cc))
 
 	if costsAreSubsumed cc then
-	    ASSERT(isToplevClosure closure_info)
-	    ASSERT(is_thunk == IsFunction)
+	    --ASSERT(isToplevClosure closure_info)
+	    --ASSERT(is_thunk == IsFunction)
+	    (if isToplevClosure closure_info && is_thunk == IsFunction then \x->x else pprTrace "enterCostCenterCode:" (ppCat [ppr PprDebug (is_thunk == IsFunction){-, ppr PprDebug closure_info-}, ppStr (showCostCentre PprDebug False cc)])) $
 	    costCentresC SLIT("ENTER_CC_FSUB") []
 
 	else if currentOrSubsumedCosts cc then 
@@ -704,8 +710,8 @@ thunkWrapper closure_info thunk_code
     let
        emit_gran_macros = opt_GranMacros
     in
-    -- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
-    -- (we prefer fetchAndReschedule-style context switches to yield ones)
+	-- HWL: insert macros for GrAnSim; 2 versions depending on liveness of node
+	-- (we prefer fetchAndReschedule-style context switches to yield ones)
     (if emit_gran_macros 
       then if node_points 
              then fetchAndReschedule  [] node_points 
@@ -714,19 +720,20 @@ thunkWrapper closure_info thunk_code
 
     stackCheck closure_info [] node_points (	-- stackCheck *encloses* the rest
 
-    -- Must be after stackCheck: if stchk fails new stack
-    -- space has to be allocated from the heap
+	-- heapCheck must be after stackCheck: if stchk fails
+	-- new stack space is allocated from the heap which
+	-- would violate any previous heapCheck
 
-    heapCheck [] node_points (
-					-- heapCheck *encloses* the rest
-	-- The "[]" says there are no live argument registers
+    heapCheck [] node_points (			-- heapCheck *encloses* the rest
+    	-- The "[]" says there are no live argument registers
 
 	-- Overwrite with black hole if necessary
-    blackHoleIt closure_info 				`thenC`
+    blackHoleIt closure_info 			`thenC`
 
-	-- Push update frame if necessary
-    setupUpdate closure_info (		-- setupUpdate *encloses* the rest
-	thunk_code
+    setupUpdate closure_info (			-- setupUpdate *encloses* the rest
+
+	-- Finally, do the business
+    thunk_code
     )))
 
 funWrapper :: ClosureInfo 	-- Closure whose code body this is
@@ -744,11 +751,11 @@ funWrapper closure_info arg_regs fun_body
       then yield  arg_regs node_points
       else absC AbsCNop)                                 `thenC`
 
-    stackCheck closure_info arg_regs node_points (	-- stackCheck *encloses* the rest
+    stackCheck closure_info arg_regs node_points (
+	-- stackCheck *encloses* the rest
 
-	-- Heap overflow check
     heapCheck arg_regs node_points (
-					-- heapCheck *encloses* the rest
+	-- heapCheck *encloses* the rest
 
 	-- Finally, do the business
     fun_body