summaryrefslogtreecommitdiff
path: root/ghc/compiler/codeGen
diff options
context:
space:
mode:
Diffstat (limited to 'ghc/compiler/codeGen')
-rw-r--r--ghc/compiler/codeGen/CgBindery.lhs20
-rw-r--r--ghc/compiler/codeGen/CgCase.lhs6
-rw-r--r--ghc/compiler/codeGen/CgClosure.lhs58
-rw-r--r--ghc/compiler/codeGen/CgCon.lhs2
-rw-r--r--ghc/compiler/codeGen/CgConTbls.lhs7
-rw-r--r--ghc/compiler/codeGen/CgExpr.lhs35
-rw-r--r--ghc/compiler/codeGen/CgHeapery.lhs2
-rw-r--r--ghc/compiler/codeGen/CgLetNoEscape.lhs2
-rw-r--r--ghc/compiler/codeGen/CgLoop1_1_3.lhi10
-rw-r--r--ghc/compiler/codeGen/CgLoop2.lhi3
-rw-r--r--ghc/compiler/codeGen/CgLoop2_1_3.lhi5
-rw-r--r--ghc/compiler/codeGen/CgMonad.lhs15
-rw-r--r--ghc/compiler/codeGen/CgRetConv.lhs2
-rw-r--r--ghc/compiler/codeGen/CgStackery.lhs2
-rw-r--r--ghc/compiler/codeGen/CgTailCall.lhs4
-rw-r--r--ghc/compiler/codeGen/CgUsages.lhs8
-rw-r--r--ghc/compiler/codeGen/ClosureInfo.lhs23
-rw-r--r--ghc/compiler/codeGen/CodeGen.lhs4
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
View Lorry Controller Status