[project @ 1996-06-26 10:26:00 by partain]

SLPJ 1.3 changes through 96/06/25

18 files changed, 113 insertions, 95 deletions

diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 92d6af2c5d..0fc6bed0b7 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -35,11 +35,11 @@ import CgMonad
 import CgUsages		( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
 import CLabel		( mkClosureLabel )
 import ClosureInfo	( mkLFImported, mkConLFInfo, mkLFArgument )
-import HeapOffs		( VirtualHeapOffset(..),
-			  VirtualSpAOffset(..), VirtualSpBOffset(..)
+import HeapOffs		( SYN_IE(VirtualHeapOffset),
+			  SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
 			)
 import Id		( idPrimRep, toplevelishId, isDataCon,
-			  mkIdEnv, rngIdEnv, IdEnv(..),
+			  mkIdEnv, rngIdEnv, SYN_IE(IdEnv),
 			  idSetToList,
 			  GenId{-instance NamedThing-}
 			)
@@ -49,7 +49,7 @@ import Name		( isLocallyDefined, oddlyImportedName, Name{-instance NamedThing-}
 import PprAbsC		( pprAmode )
 #endif
 import PprStyle		( PprStyle(..) )
-import StgSyn		( StgArg(..), StgLiveVars(..), GenStgArg(..) )
+import StgSyn		( SYN_IE(StgArg), SYN_IE(StgLiveVars), GenStgArg(..) )
 import Unpretty		( uppShow )
 import Util		( zipWithEqual, panic )
 \end{code}
@@ -196,11 +196,17 @@ getCAddrModeAndInfo :: Id -> FCode (CAddrMode, LambdaFormInfo)
 
 getCAddrModeAndInfo id
   | not (isLocallyDefined name) || oddlyImportedName name
+    {- Why the "oddlyImported"?
+	Imagine you are compiling GHCbase.hs (a module that
+	supplies some of the wired-in values).  What can
+	happen is that the compiler will inject calls to
+	(e.g.) GHCbase.unpackPS, where-ever it likes -- it
+	assumes those values are ubiquitously available.
+	The main point is: it may inject calls to them earlier
+	in GHCbase.hs than the actual definition...
+    -}
   = returnFC (global_amode, mkLFImported id)
 
-  | isDataCon id
-  = returnFC (global_amode, mkConLFInfo id)
-
   | otherwise = -- *might* be a nested defn: in any case, it's something whose
 		-- definition we will know about...
     lookupBindC id `thenFC` \ (MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 17d61261c1..538a9e397e 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -46,10 +46,10 @@ import CLabel		( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
 import ClosureInfo	( mkConLFInfo, mkLFArgument, layOutDynCon )
 import CmdLineOpts	( opt_SccProfilingOn, opt_GranMacros )
 import CostCentre	( useCurrentCostCentre )
-import HeapOffs		( VirtualSpBOffset(..), VirtualHeapOffset(..) )
+import HeapOffs		( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) )
 import Id		( idPrimRep, toplevelishId,
-			  dataConTag, fIRST_TAG, ConTag(..),
-			  isDataCon, DataCon(..),
+			  dataConTag, fIRST_TAG, SYN_IE(ConTag),
+			  isDataCon, SYN_IE(DataCon),
 			  idSetToList, GenId{-instance Uniquable,Eq-}
 			)
 import Maybes		( catMaybes )
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index cfd5ceade1..e2d6de9f86 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -13,7 +13,7 @@ with {\em closures} on the RHSs of let(rec)s.  See also
 module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
 
 IMP_Ubiq(){-uitous-}
-IMPORT_DELOOPER(CgLoop2)		( cgExpr, cgSccExpr )
+IMPORT_DELOOPER(CgLoop2)	( cgExpr )
 
 import CgMonad
 import AbsCSyn
@@ -50,9 +50,9 @@ import ClosureInfo	-- lots and lots of stuff
 import CmdLineOpts	( opt_ForConcurrent, opt_GranMacros )
 import CostCentre	( useCurrentCostCentre, currentOrSubsumedCosts,
 			  noCostCentreAttached, costsAreSubsumed,
-			  isCafCC, overheadCostCentre
+			  isCafCC, isDictCC, overheadCostCentre
 			)
-import HeapOffs		( VirtualHeapOffset(..) )
+import HeapOffs		( SYN_IE(VirtualHeapOffset) )
 import Id		( idType, idPrimRep, 
 			  showId, getIdStrictness, dataConTag,
 			  emptyIdSet,
@@ -411,7 +411,7 @@ 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 (cgSccExpr body)
+		  thunkWrapper closure_info (cgExpr body)
 
     stdUpd      = CLbl mkErrorStdEntryLabel CodePtrRep
 \end{code}
@@ -581,6 +581,9 @@ Node is guaranteed to point to it, if profiling and not inherited.
 
 \begin{code}
 data IsThunk = IsThunk | IsFunction -- Bool-like, local
+#ifdef DEBUG
+	deriving Eq
+#endif
 
 enterCostCentreCode :: ClosureInfo -> CostCentre -> IsThunk -> Code
 
@@ -588,37 +591,31 @@ enterCostCentreCode closure_info cc is_thunk
   = costCentresFlag	`thenFC` \ profiling_on ->
     if not profiling_on then
 	nopC
-    else -- down to business
+    else
 	ASSERT(not (noCostCentreAttached cc))
 
 	if costsAreSubsumed cc then
-	    nopC
-
-	else if is_current_CC cc then -- fish the CC out of the closure,
-				      -- where we put it when we alloc'd;
-				      -- NB: chk defn of "is_current_CC"
-				      -- if you go to change this! (WDP 94/12)
-	    costCentresC
-		(case is_thunk of
-		   IsThunk    -> SLIT("ENTER_CC_TCL")
-		   IsFunction -> SLIT("ENTER_CC_FCL"))
-		[CReg node]
-
-	else if isCafCC cc then
-	    costCentresC
-		SLIT("ENTER_CC_CAF")
-		[mkCCostCentre cc]
+	    ASSERT(isToplevClosure closure_info)
+	    ASSERT(is_thunk == IsFunction)
+	    costCentresC SLIT("ENTER_CC_FSUB") []
+
+	else if currentOrSubsumedCosts cc then 
+	    -- i.e. current; subsumed dealt with above
+	    -- get CCC out of the closure, where we put it when we alloc'd
+	    case is_thunk of 
+		IsThunk    -> costCentresC SLIT("ENTER_CC_TCL") [CReg node]
+		IsFunction -> costCentresC SLIT("ENTER_CC_FCL") [CReg node]
+
+	else if isCafCC cc && isToplevClosure closure_info then
+	    ASSERT(is_thunk == IsThunk)
+	    costCentresC SLIT("ENTER_CC_CAF") [mkCCostCentre cc]
 
 	else -- we've got a "real" cost centre right here in our hands...
-	    costCentresC
-		(case is_thunk of
-		   IsThunk    -> SLIT("ENTER_CC_T")
-		   IsFunction -> SLIT("ENTER_CC_F"))
-		[mkCCostCentre cc]
-  where
-    is_current_CC cc
-      = currentOrSubsumedCosts cc
-	-- but we've already ruled out "subsumed", so it must be "current"!
+	    case is_thunk of 
+		IsThunk    -> costCentresC SLIT("ENTER_CC_T") [mkCCostCentre cc]
+		IsFunction -> if isCafCC cc || isDictCC cc
+			      then costCentresC SLIT("ENTER_CC_FCAF") [mkCCostCentre cc]
+			      else costCentresC SLIT("ENTER_CC_FLOAD") [mkCCostCentre cc]
 \end{code}
 
 %************************************************************************
@@ -933,6 +930,7 @@ chooseDynCostCentres cc args fvs body
 		| just1 == fun
 		-> mkCCostCentre overheadCostCentre
 	      _ -> use_cc
+
 	    -- if it's an utterly trivial RHS, then it must be
 	    -- one introduced by boxHigherOrderArgs for profiling,
 	    -- so we charge it to "OVERHEAD".
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index cb5337be61..c2aa1f5fe4 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -44,7 +44,7 @@ import CostCentre	( currentOrSubsumedCosts, useCurrentCostCentre,
 			  dontCareCostCentre
 			)
 import Id		( idPrimRep, dataConTag, dataConTyCon,
-			  isDataCon, DataCon(..),
+			  isDataCon, SYN_IE(DataCon),
 			  emptyIdSet
 			)
 import Literal		( Literal(..) )
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 2083d8fe10..e13d043b37 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -34,9 +34,9 @@ import ClosureInfo	( layOutStaticClosure, layOutDynCon,
 			)
 import CostCentre	( dontCareCostCentre )
 import FiniteMap	( fmToList )
-import HeapOffs		( zeroOff, VirtualHeapOffset(..) )
+import HeapOffs		( zeroOff, SYN_IE(VirtualHeapOffset) )
 import Id		( dataConTag, dataConRawArgTys,
-			  dataConArity, fIRST_TAG,
+			  dataConNumFields, fIRST_TAG,
 			  emptyIdSet,
 			  GenId{-instance NamedThing-}
 			)
@@ -241,7 +241,6 @@ genConInfo comp_info tycon data_con
     zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0
 
     arg_tys	    = dataConRawArgTys 	   data_con
-    con_arity	    = dataConArity 	   data_con
     entry_label     = mkConEntryLabel      data_con
     closure_label   = mkStaticClosureLabel data_con
 \end{code}
@@ -339,7 +338,7 @@ genPhantomUpdInfo comp_info tycon data_con
 
 	    con_descr = _UNPK_ (nameOf (origName "con_descr2" data_con))
 
-	    con_arity = dataConArity data_con
+	    con_arity = dataConNumFields data_con
 
 	    upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
     	    upd_label = mkConUpdCodePtrVecLabel tycon tag
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index a4a0746d3d..212a728f97 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -10,7 +10,7 @@
 \begin{code}
 #include "HsVersions.h"
 
-module CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) where
+module CgExpr ( cgExpr, getPrimOpArgAmodes ) where
 
 IMP_Ubiq(){-uitous-}
 IMPORT_DELOOPER(CgLoop2)	-- here for paranoia-checking
@@ -35,8 +35,8 @@ import CgTailCall	( cgTailCall, performReturn,
 			)
 import CLabel		( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
 import ClosureInfo	( mkClosureLFInfo )
-import CostCentre	( setToAbleCostCentre, isDupdCC )
-import HeapOffs		( VirtualSpBOffset(..) )
+import CostCentre	( sccAbleCostCentre, isDictCC, isSccCountCostCentre )
+import HeapOffs		( SYN_IE(VirtualSpBOffset) )
 import Id		( mkIdSet, unionIdSets, GenId{-instance Outputable-} )
 import PprStyle		( PprStyle(..) )
 import PrimOp		( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
@@ -270,30 +270,17 @@ cgExpr (StgLetNoEscape live_in_whole_let live_in_rhss bindings body)
 
 SCC expressions are treated specially. They set the current cost
 centre.
-
-For evaluation scoping we also need to save the cost centre in an
-``restore CC frame''. We only need to do this once before setting all
-nested SCCs.
-
 \begin{code}
-cgExpr scc_expr@(StgSCC ty cc expr) = cgSccExpr scc_expr
+cgExpr (StgSCC ty cc expr)
+  = ASSERT(sccAbleCostCentre cc)
+    costCentresC
+	(if isDictCC cc then SLIT("SET_DICT_CCC") else SLIT("SET_CCC"))
+	[mkCCostCentre cc, mkIntCLit (if isSccCountCostCentre cc then 1 else 0)]
+    `thenC`
+    cgExpr expr
 \end{code}
 
-@cgSccExpr@ (also used in \tr{CgClosure}):
-We *don't* set the cost centre for CAF/Dict cost centres
-[Likewise Subsumed and NoCostCentre, but they probably
-don't exist in an StgSCC expression.]
-\begin{code}
-cgSccExpr (StgSCC ty cc expr)
-  = (if setToAbleCostCentre cc then
-	costCentresC SLIT("SET_CCC")
-	    [mkCCostCentre cc, mkIntCLit (if isDupdCC cc then 1 else 0)]
-     else
-	nopC)		`thenC`
-    cgSccExpr expr
-cgSccExpr other
-  = cgExpr other
-\end{code}
+ToDo: counting of dict sccs ...
 
 %********************************************************
 %*							*
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index 888908f612..2d4abe27d9 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -28,7 +28,7 @@ import ClosureInfo	( closureSize, closureHdrSize, closureGoodStuffSize,
 			  slopSize, allocProfilingMsg, closureKind
 			)
 import HeapOffs		( isZeroOff, addOff, intOff,
-			  VirtualHeapOffset(..)
+			  SYN_IE(VirtualHeapOffset)
 			)
 import PrimRep		( PrimRep(..) )
 \end{code}
diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index 3748ddd657..3126b25d78 100644
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -28,7 +28,7 @@ import CgStackery	( mkVirtStkOffsets )
 import CgUsages		( setRealAndVirtualSps, getVirtSps )
 import CLabel		( mkStdEntryLabel )
 import ClosureInfo	( mkLFLetNoEscape )
-import HeapOffs		( VirtualSpBOffset(..) )
+import HeapOffs		( SYN_IE(VirtualSpBOffset) )
 import Id		( idPrimRep )
 \end{code}
 
diff --git a/ghc/compiler/codeGen/CgLoop1_1_3.lhi b/ghc/compiler/codeGen/CgLoop1_1_3.lhi
new file mode 100644
index 0000000000..c5b3d81f86
--- /dev/null
+++ b/ghc/compiler/codeGen/CgLoop1_1_3.lhi
@@ -0,0 +1,10 @@
+\begin{code}
+interface CgLoop1_1_3 1
+__exports__
+CgBindery CgBindings(..)
+CgBindery CgIdInfo(..)
+CgBindery nukeVolatileBinds (..)
+CgBindery maybeAStkLoc (..)
+CgBindery maybeBStkLoc (..)
+CgUsages  getSpBRelOffset (..)
+\end{code}
diff --git a/ghc/compiler/codeGen/CgLoop2.lhi b/ghc/compiler/codeGen/CgLoop2.lhi
index feda847f2c..421fbfa782 100644
--- a/ghc/compiler/codeGen/CgLoop2.lhi
+++ b/ghc/compiler/codeGen/CgLoop2.lhi
@@ -2,7 +2,7 @@ Break loops caused by cgExpr and getPrimOpArgAmodes.
 \begin{code}
 interface CgLoop2 where
 
-import CgExpr	( cgExpr, cgSccExpr, getPrimOpArgAmodes )
+import CgExpr	( cgExpr, getPrimOpArgAmodes )
 
 import AbsCSyn	( CAddrMode )
 import CgMonad	( Code(..), FCode(..) )
@@ -10,6 +10,5 @@ import PrimOp	( PrimOp )
 import StgSyn	( StgExpr(..), StgArg(..) )
 
 cgExpr		   :: StgExpr -> Code
-cgSccExpr	   :: StgExpr -> Code
 getPrimOpArgAmodes :: PrimOp -> [StgArg] -> FCode [CAddrMode]
 \end{code}
diff --git a/ghc/compiler/codeGen/CgLoop2_1_3.lhi b/ghc/compiler/codeGen/CgLoop2_1_3.lhi
new file mode 100644
index 0000000000..7a0feb086b
--- /dev/null
+++ b/ghc/compiler/codeGen/CgLoop2_1_3.lhi
@@ -0,0 +1,5 @@
+\begin{code}
+interface CgLoop2_1_3 1
+__exports__
+Outputable Outputable (..)
+\end{code}
diff --git a/ghc/compiler/codeGen/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index ab22daeb24..8e9ae24a85 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -49,6 +49,7 @@ module CgMonad (
 
 IMP_Ubiq(){-uitous-}
 IMPORT_DELOOPER(CgLoop1)		-- stuff from CgBindery and CgUsages
+IMPORT_1_3(List(nub))
 
 import AbsCSyn
 import AbsCUtils	( mkAbsCStmts )
@@ -56,19 +57,19 @@ import CmdLineOpts	( opt_SccProfilingOn, opt_DoTickyProfiling,
 			  opt_OmitBlackHoling
 			)
 import HeapOffs		( maxOff,
-			  VirtualSpAOffset(..), VirtualSpBOffset(..)
+			  SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset)
 			)
 import Id		( idType,
 			  nullIdEnv, mkIdEnv, addOneToIdEnv,
-			  modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv(..),
-			  ConTag(..), GenId{-instance Outputable-}
+			  modifyIdEnv, lookupIdEnv, rngIdEnv, SYN_IE(IdEnv),
+			  SYN_IE(ConTag), GenId{-instance Outputable-}
 			)
 import Maybes		( maybeToBool )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-} )
 import Pretty		( ppAboves, ppCat, ppStr )
 import PrimRep		( getPrimRepSize, PrimRep(..) )
-import StgSyn		( StgLiveVars(..) )
+import StgSyn		( SYN_IE(StgLiveVars) )
 import Type		( typePrimRep )
 import UniqSet		( elementOfUniqSet )
 import Util		( sortLt, panic, pprPanic )
@@ -323,7 +324,7 @@ thenC :: Code
 -- thenC :: Code -> Code    -> Code
 -- thenC :: Code -> FCode a -> FCode a
 
-(m `thenC` k) info_down state
+thenC m k info_down state
   = k info_down new_state
   where
     new_state  = m info_down state
@@ -353,7 +354,7 @@ thenFC	:: FCode a
 -- thenFC :: FCode a -> (a -> FCode b) -> FCode b
 -- thenFC :: FCode a -> (a -> Code)    -> Code
 
-(m `thenFC` k) info_down state
+thenFC m k info_down state
   = k m_result info_down new_state
   where
     (m_result, new_state) = m info_down state
@@ -649,7 +650,7 @@ is just a wrapper for its lower-level @Bind@ routine (drop the \tr{C}
 on the end of each function name).
 
 A @Id@ is bound to a @(VolatileLoc, StableLoc)@ triple.
-The name should not already be bound.
+The name should not already be bound. (nice ASSERT, eh?)
 \begin{code}
 addBindC :: Id -> CgIdInfo -> Code
 addBindC name stuff_to_bind info_down (MkCgState absC binds usage)
diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index fa3644038b..5768b2df45 100644
--- a/ghc/compiler/codeGen/CgRetConv.lhs
+++ b/ghc/compiler/codeGen/CgRetConv.lhs
@@ -35,7 +35,7 @@ import CgCompInfo	( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
 			)
 import CmdLineOpts	( opt_ReturnInRegsThreshold )
 import Id		( isDataCon, dataConRawArgTys,
-			  DataCon(..), GenId{-instance Eq-}
+			  SYN_IE(DataCon), GenId{-instance Eq-}
 			)
 import Maybes		( catMaybes )
 import PprStyle		( PprStyle(..) )
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index caf38104dd..cc845bf539 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -22,7 +22,7 @@ import CgMonad
 import AbsCSyn
 
 import AbsCUtils	( mkAbstractCs, mkAbsCStmts, getAmodeRep )
-import HeapOffs		( VirtualSpAOffset(..), VirtualSpBOffset(..) )
+import HeapOffs		( SYN_IE(VirtualSpAOffset), SYN_IE(VirtualSpBOffset) )
 import PrimRep		( getPrimRepSize, separateByPtrFollowness,
 			  PrimRep(..)
 			)
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index 770c4b52df..590a80a207 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -37,14 +37,14 @@ import ClosureInfo	( nodeMustPointToIt,
 			  getEntryConvention, EntryConvention(..)
 			)
 import CmdLineOpts	( opt_DoSemiTagging )
-import HeapOffs		( zeroOff, VirtualSpAOffset(..) )
+import HeapOffs		( zeroOff, SYN_IE(VirtualSpAOffset) )
 import Id		( idType, dataConTyCon, dataConTag,
 			  fIRST_TAG
 			)
 import Literal		( mkMachInt )
 import Maybes		( assocMaybe )
 import PrimRep		( PrimRep(..) )
-import StgSyn		( StgArg(..), GenStgArg(..), StgLiveVars(..) )
+import StgSyn		( SYN_IE(StgArg), GenStgArg(..), SYN_IE(StgLiveVars) )
 import Type		( isPrimType )
 import Util		( zipWithEqual, panic, assertPanic )
 \end{code}
diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs
index e7e7b962cb..cab19c01eb 100644
--- a/ghc/compiler/codeGen/CgUsages.lhs
+++ b/ghc/compiler/codeGen/CgUsages.lhs
@@ -26,11 +26,11 @@ IMPORT_DELOOPER(CgLoop1)	-- here for paranoia-checking
 import AbsCSyn		( RegRelative(..), AbstractC, CAddrMode )
 import CgMonad
 import HeapOffs		( zeroOff,
-			  VirtualHeapOffset(..),
-			  VirtualSpAOffset(..),
-			  VirtualSpBOffset(..)
+			  SYN_IE(VirtualHeapOffset),
+			  SYN_IE(VirtualSpAOffset),
+			  SYN_IE(VirtualSpBOffset)
 			)
-import Id		( IdEnv(..) )
+import Id		( SYN_IE(IdEnv) )
 \end{code}
 
 %************************************************************************
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index d24b55e253..1c3d61a6ab 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -41,6 +41,7 @@ module ClosureInfo (
 	closureSingleEntry, closureSemiTag, closureType,
 	closureReturnsUnboxedType, getStandardFormThunkInfo,
 
+	isToplevClosure,
 	closureKind, closureTypeDescr,		-- profiling
 
 	isStaticClosure, allocProfilingMsg,
@@ -76,13 +77,13 @@ import CLabel		( mkStdEntryLabel, mkFastEntryLabel,
 import CmdLineOpts	( opt_SccProfilingOn, opt_ForConcurrent )
 import HeapOffs		( intOff, addOff, totHdrSize, varHdrSize,
 			  intOffsetIntoGoods,
-			  VirtualHeapOffset(..)
+			  SYN_IE(VirtualHeapOffset)
 			)
 import Id		( idType, idPrimRep, getIdArity,
 			  externallyVisibleId,
 			  dataConTag, fIRST_TAG,
 			  isDataCon, isNullaryDataCon, dataConTyCon,
-			  isTupleCon, DataCon(..),
+			  isTupleCon, SYN_IE(DataCon),
 			  GenId{-instance Eq-}
 			)
 import IdInfo		( arityMaybe )
@@ -90,11 +91,12 @@ import Maybes		( assocMaybe, maybeToBool )
 import Name		( isLocallyDefined, nameOf, origName )
 import PprStyle		( PprStyle(..) )
 import PprType		( GenType{-instance Outputable-} )
+import Pretty--ToDo:rm
 import PrelInfo		( maybeCharLikeTyCon, maybeIntLikeTyCon )
 import PrimRep		( getPrimRepSize, separateByPtrFollowness )
 import SMRep		-- all of it
 import TyCon		( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type		( isPrimType, splitForAllTy, splitFunTyExpandingDicts,
+import Type		( isPrimType, splitForAllTy, splitFunTyExpandingDictsAndPeeking,
 			  mkFunTys, maybeAppSpecDataTyConExpandingDicts
 			)
 import Util		( isIn, mapAccumL, panic, pprPanic, assertPanic )
@@ -1159,9 +1161,10 @@ closureReturnsUnboxedType other_closure = False
 fun_result_ty arity id
   = let
 	(_, de_foralld_ty) = splitForAllTy (idType id)
-	(arg_tys, res_ty)  = splitFunTyExpandingDicts de_foralld_ty
+	(arg_tys, res_ty)  = splitFunTyExpandingDictsAndPeeking de_foralld_ty
     in
-    ASSERT(arity >= 0 && length arg_tys >= arity)
+    -- ASSERT(arity >= 0 && length arg_tys >= arity)
+    (if (arity >= 0 && length arg_tys >= arity) then (\x->x) else pprPanic "fun_result_ty:" (ppCat [ppInt arity, ppr PprShowAll id, ppr PprDebug (idType id)])) $
     mkFunTys (drop arity arg_tys) res_ty
 \end{code}
 
@@ -1175,6 +1178,16 @@ closureSemiTag (MkClosureInfo _ lf_info _)
       _	    	       -> fromInteger oTHER_TAG
 \end{code}
 
+\begin{code}
+isToplevClosure :: ClosureInfo -> Bool
+
+isToplevClosure (MkClosureInfo _ lf_info _)
+  = case lf_info of
+      LFReEntrant top _ _ -> top
+      LFThunk top _ _ _   -> top
+      _ -> panic "ClosureInfo:isToplevClosure"
+\end{code}
+
 Label generation.
 
 \begin{code}
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index 590aa9f65e..4a1fed5c3a 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -31,7 +31,7 @@ import CgClosure	( cgTopRhsClosure )
 import CgCon		( cgTopRhsCon )
 import CgConTbls	( genStaticConBits )
 import ClosureInfo	( mkClosureLFInfo )
-import CmdLineOpts	( opt_SccProfilingOn, opt_CompilingPrelude,
+import CmdLineOpts	( opt_SccProfilingOn, opt_CompilingGhcInternals,
 			  opt_EnsureSplittableC, opt_SccGroup
 			)
 import CStrings		( modnameToC )
@@ -54,7 +54,7 @@ codeGen :: FAST_STRING		-- module name
 codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg_pgm
   = let
 	doing_profiling   = opt_SccProfilingOn
-	compiling_prelude = opt_CompilingPrelude
+	compiling_prelude = opt_CompilingGhcInternals
 	maybe_split       = if maybeToBool (opt_EnsureSplittableC)
 			    then CSplitMarker
 			    else AbsCNop