summaryrefslogtreecommitdiff
path: root/ghc/compiler/codeGen
diff options
context:
space:
mode:
authorpartain <unknown>1996-04-05 08:30:45 +0000
committerpartain <unknown>1996-04-05 08:30:45 +0000
commit7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff (patch)
treea56a3ce1bcff5d4059ebdb9b86e4bb7c98e22c93 /ghc/compiler/codeGen
parentb8875f2f7f596482228645b9751f8f9c592a84c5 (diff)
downloadhaskell-7d61cb61daa5e433a0cb85b34b7f0c58b2f961ff.tar.gz
[project @ 1996-04-05 08:26:04 by partain]
Add SLPJ/WDP 1.3 changes through 960404
Diffstat (limited to 'ghc/compiler/codeGen')
-rw-r--r--ghc/compiler/codeGen/CgBindery.lhs60
-rw-r--r--ghc/compiler/codeGen/CgCase.lhs166
-rw-r--r--ghc/compiler/codeGen/CgClosure.lhs133
-rw-r--r--ghc/compiler/codeGen/CgCompInfo.lhs3
-rw-r--r--ghc/compiler/codeGen/CgCon.lhs92
-rw-r--r--ghc/compiler/codeGen/CgConTbls.lhs125
-rw-r--r--ghc/compiler/codeGen/CgExpr.lhs67
-rw-r--r--ghc/compiler/codeGen/CgHeapery.lhs31
-rw-r--r--ghc/compiler/codeGen/CgLetNoEscape.lhs21
-rw-r--r--ghc/compiler/codeGen/CgLoop1.lhi35
-rw-r--r--ghc/compiler/codeGen/CgLoop2.lhi15
-rw-r--r--ghc/compiler/codeGen/CgMonad.lhs168
-rw-r--r--ghc/compiler/codeGen/CgRetConv.lhs136
-rw-r--r--ghc/compiler/codeGen/CgStackery.lhs17
-rw-r--r--ghc/compiler/codeGen/CgTailCall.lhs67
-rw-r--r--ghc/compiler/codeGen/CgUpdate.lhs20
-rw-r--r--ghc/compiler/codeGen/CgUsages.lhs17
-rw-r--r--ghc/compiler/codeGen/ClosureInfo.lhs170
-rw-r--r--ghc/compiler/codeGen/CodeGen.lhs37
-rw-r--r--ghc/compiler/codeGen/SMRep.lhs24
20 files changed, 734 insertions, 670 deletions
diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs
index 84fd88487a..4d17fc1a62 100644
--- a/ghc/compiler/codeGen/CgBindery.lhs
+++ b/ghc/compiler/codeGen/CgBindery.lhs
@@ -8,7 +8,7 @@
module CgBindery (
CgBindings(..), CgIdInfo(..){-dubiously concrete-},
- StableLoc, VolatileLoc, LambdaFormInfo{-re-exported-},
+ StableLoc, VolatileLoc,
maybeAStkLoc, maybeBStkLoc,
@@ -20,25 +20,35 @@ module CgBindery (
bindNewToAStack, bindNewToBStack,
bindNewToNode, bindNewToReg, bindArgsToRegs,
bindNewToTemp, bindNewPrimToAmode,
- getAtomAmode, getAtomAmodes,
+ getArgAmode, getArgAmodes,
getCAddrModeAndInfo, getCAddrMode,
getCAddrModeIfVolatile, getVolatileRegs,
rebindToAStack, rebindToBStack
-
- -- and to make a self-sufficient interface...
) where
+import Ubiq{-uitous-}
+import CgLoop1 -- here for paranoia-checking
+
import AbsCSyn
import CgMonad
import CgUsages ( getHpRelOffset, getSpARelOffset, getSpBRelOffset )
-import CLabel ( mkClosureLabel, CLabel )
-import ClosureInfo
-import Id ( getIdPrimRep, toplevelishId, isDataCon, Id )
-import Maybes ( catMaybes, Maybe(..) )
-import UniqSet -- ( setToList )
-import StgSyn
-import Util
+import CLabel ( mkClosureLabel )
+import ClosureInfo ( mkLFImported, mkConLFInfo, mkLFArgument )
+import HeapOffs ( VirtualHeapOffset(..),
+ VirtualSpAOffset(..), VirtualSpBOffset(..)
+ )
+import Id ( idPrimRep, toplevelishId, isDataCon,
+ mkIdEnv, rngIdEnv, IdEnv(..),
+ idSetToList,
+ GenId{-instance NamedThing-}
+ )
+import Maybes ( catMaybes )
+import PprAbsC ( pprAmode )
+import PprStyle ( PprStyle(..) )
+import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
+import Unpretty ( uppShow )
+import Util ( zipWithEqual, panic )
\end{code}
@@ -113,13 +123,13 @@ newTempAmodeAndIdInfo name lf_info
= (temp_amode, temp_idinfo)
where
uniq = getItsUnique name
- temp_amode = CTemp uniq (getIdPrimRep name)
+ temp_amode = CTemp uniq (idPrimRep name)
temp_idinfo = tempIdInfo name uniq lf_info
-idInfoToAmode :: PrimKind -> CgIdInfo -> FCode CAddrMode
+idInfoToAmode :: PrimRep -> CgIdInfo -> FCode CAddrMode
idInfoToAmode kind (MkCgIdInfo _ vol stab _) = idInfoPiecesToAmode kind vol stab
-idInfoPiecesToAmode :: PrimKind -> VolatileLoc -> StableLoc -> FCode CAddrMode
+idInfoPiecesToAmode :: PrimRep -> VolatileLoc -> StableLoc -> FCode CAddrMode
idInfoPiecesToAmode kind (TempVarLoc uniq) stable_loc = returnFC (CTemp uniq kind)
idInfoPiecesToAmode kind (RegLoc magic_id) stable_loc = returnFC (CReg magic_id)
@@ -195,7 +205,7 @@ getCAddrModeAndInfo name
returnFC (amode, lf_info)
where
global_amode = CLbl (mkClosureLabel name) kind
- kind = getIdPrimRep name
+ kind = idPrimRep name
getCAddrMode :: Id -> FCode CAddrMode
getCAddrMode name
@@ -211,7 +221,7 @@ getCAddrModeIfVolatile name
= lookupBindC name `thenFC` \ ~(MkCgIdInfo _ volatile_loc stable_loc lf_info) ->
case stable_loc of
NoStableLoc -> -- Aha! So it is volatile!
- idInfoPiecesToAmode (getIdPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
+ idInfoPiecesToAmode (idPrimRep name) volatile_loc NoStableLoc `thenFC` \ amode ->
returnFC (Just amode)
a_stable_loc -> returnFC Nothing
@@ -228,7 +238,7 @@ forget the volatile one.
getVolatileRegs :: StgLiveVars -> FCode [MagicId]
getVolatileRegs vars
- = mapFCs snaffle_it (uniqSetToList vars) `thenFC` \ stuff ->
+ = mapFCs snaffle_it (idSetToList vars) `thenFC` \ stuff ->
returnFC (catMaybes stuff)
where
snaffle_it var
@@ -262,17 +272,17 @@ getVolatileRegs vars
\end{code}
\begin{code}
-getAtomAmodes :: [StgArg] -> FCode [CAddrMode]
-getAtomAmodes [] = returnFC []
-getAtomAmodes (atom:atoms)
- = getAtomAmode atom `thenFC` \ amode ->
- getAtomAmodes atoms `thenFC` \ amodes ->
+getArgAmodes :: [StgArg] -> FCode [CAddrMode]
+getArgAmodes [] = returnFC []
+getArgAmodes (atom:atoms)
+ = getArgAmode atom `thenFC` \ amode ->
+ getArgAmodes atoms `thenFC` \ amodes ->
returnFC ( amode : amodes )
-getAtomAmode :: StgArg -> FCode CAddrMode
+getArgAmode :: StgArg -> FCode CAddrMode
-getAtomAmode (StgVarArg var) = getCAddrMode var
-getAtomAmode (StgLitArg lit) = returnFC (CLit lit)
+getArgAmode (StgVarArg var) = getCAddrMode var
+getArgAmode (StgLitArg lit) = returnFC (CLit lit)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 45b21c1105..5ed617db04 100644
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%********************************************************
%* *
@@ -10,48 +10,66 @@
\begin{code}
#include "HsVersions.h"
-module CgCase (
- cgCase,
- saveVolatileVarsAndRegs
+module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
- -- and to make the interface self-sufficient...
- ) where
+import Ubiq{-uitous-}
+import CgLoop2 ( cgExpr, getPrimOpArgAmodes )
-import StgSyn
import CgMonad
+import StgSyn
import AbsCSyn
-import PrelInfo ( PrimOp(..), primOpCanTriggerGC
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
+ magicIdPrimRep, getAmodeRep
)
-import Type ( primRepFromType, getTyConDataCons,
- getUniDataSpecTyCon, getUniDataSpecTyCon_maybe,
- isEnumerationTyCon,
- Type
+import CgBindery ( getVolatileRegs, getArgAmode, getArgAmodes,
+ bindNewToReg, bindNewToTemp,
+ bindNewPrimToAmode,
+ rebindToAStack, rebindToBStack,
+ getCAddrModeAndInfo, getCAddrModeIfVolatile,
+ idInfoToAmode
)
-import CgBindery -- all of it
import CgCon ( buildDynCon, bindConArgs )
-import CgExpr ( cgExpr, getPrimOpArgAmodes )
import CgHeapery ( heapCheck )
-import CgRetConv -- lots of stuff
-import CgStackery -- plenty
+import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
+ ctrlReturnConvAlg,
+ DataReturnConvention(..), CtrlReturnConvention(..),
+ assignPrimOpResultRegs,
+ makePrimOpArgsRobust
+ )
+import CgStackery ( allocAStack, allocBStack )
import CgTailCall ( tailCallBusiness, performReturn )
-import CgUsages -- and even more
-import CLabel -- bunches of things...
-import ClosureInfo {-( blackHoleClosureInfo, mkConLFInfo, mkLFArgument,
- layOutDynCon
- )-}
-import CostCentre ( useCurrentCostCentre, CostCentre )
-import Literal ( literalPrimRep )
-import Id ( getDataConTag, getIdPrimRep, fIRST_TAG, isDataCon,
- toplevelishId, getInstantiatedDataConSig,
- ConTag(..), DataCon(..)
+import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
+import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
+ mkAltLabel, mkClosureLabel
+ )
+import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
+import CmdLineOpts ( opt_SccProfilingOn )
+import CostCentre ( useCurrentCostCentre )
+import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) )
+import Id ( idPrimRep, toplevelishId,
+ dataConTag, fIRST_TAG, ConTag(..),
+ isDataCon, DataCon(..),
+ idSetToList, GenId{-instance NamedThing,Eq-}
)
-import Maybes ( catMaybes, Maybe(..) )
-import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize, PrimRep(..) )
-import UniqSet -- ( uniqSetToList, UniqSet(..) )
-import Util
+import Maybes ( catMaybes )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
+import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
+ PrimRep(..)
+ )
+import TyCon ( isEnumerationTyCon )
+import Type ( typePrimRep,
+ getDataSpecTyCon, getDataSpecTyCon_maybe,
+ isEnumerationTyCon
+ )
+import Util ( sortLt, isIn, isn'tIn, zipEqual,
+ pprError, panic, assertPanic
+ )
+
+getDataSpecTyCon = panic "CgCase.getDataSpecTyCon (ToDo)"
+getDataSpecTyCon_maybe = panic "CgCase.getDataSpecTyCon_maybe (ToDo)"
\end{code}
\begin{code}
@@ -193,18 +211,17 @@ cgCase (StgPrim op args _) live_in_whole_case live_in_alts uniq alts
| otherwise -- *Can* trigger GC
= getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
---NO: getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- Get amodes for the arguments and results, and assign to regs
-- (Can-trigger-gc primops guarantee to have their (nonRobust)
-- args in regs)
let
- op_result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op
+ op_result_regs = assignPrimOpResultRegs op
op_result_amodes = map CReg op_result_regs
(op_arg_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
+ = makePrimOpArgsRobust op arg_amodes
liveness_arg = mkIntCLit liveness_mask
in
@@ -275,7 +292,7 @@ eliminate a heap check altogether.
\begin{code}
cgCase (StgApp v [] _) live_in_whole_case live_in_alts uniq (StgPrimAlts ty alts deflt)
- = getAtomAmode v `thenFC` \ amode ->
+ = getArgAmode v `thenFC` \ amode ->
cgPrimAltsGivenScrutinee NoGC amode alts deflt
\end{code}
@@ -288,7 +305,7 @@ cgCase (StgApp (StgVarArg fun) args _ {-lvs must be same as live_in_alts-})
live_in_whole_case live_in_alts uniq alts@(StgAlgAlts _ _ _)
=
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getAtomAmodes args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
-- Squish the environment
nukeDeadBindings live_in_alts `thenC`
@@ -368,7 +385,7 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts (StgBindDefault _ True {- used -
-- A temporary variable to hold the tag; this is unaffected by GC because
-- the heap-checks in the branches occur after the switch
tag_amode = CTemp uniq IntRep
- (spec_tycon, _, _) = getUniDataSpecTyCon ty
+ (spec_tycon, _, _) = getDataSpecTyCon ty
getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
-- Default is either StgNoDefault or StgBindDefault with unused binder
@@ -383,14 +400,14 @@ getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
-- Sort alternatives into canonical order; there must be a complete
-- set because there's no default case.
sorted_alts = sortLt lt alts
- (con1,_,_,_) `lt` (con2,_,_,_) = getDataConTag con1 < getDataConTag con2
+ (con1,_,_,_) `lt` (con2,_,_,_) = dataConTag con1 < dataConTag con2
arg_amodes :: [CAddrMode]
-- Turn them into amodes
arg_amodes = concat (map mk_amodes sorted_alts)
mk_amodes (con, args, use_mask, rhs)
- = [ CTemp (getItsUnique arg) (getIdPrimRep arg) | arg <- args ]
+ = [ CTemp (getItsUnique arg) (idPrimRep arg) | arg <- args ]
\end{code}
The situation is simpler for primitive
@@ -398,9 +415,7 @@ results, because there is only one!
\begin{code}
getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
- = [CTemp uniq kind]
- where
- kind = primRepFromType ty
+ = [CTemp uniq (typePrimRep ty)]
\end{code}
@@ -425,7 +440,6 @@ cgEvalAlts :: Maybe VirtualSpBOffset -- Offset of cost-centre to be restored, if
cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
= -- Generate the instruction to restore cost centre, if any
restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
@@ -437,7 +451,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
-- which is worse than having the alt code in the switch statement
let
- (spec_tycon, _, _) = getUniDataSpecTyCon ty
+ (spec_tycon, _, _) = getDataSpecTyCon ty
use_labelled_alts
= case ctrlReturnConvAlg spec_tycon of
@@ -448,7 +462,7 @@ cgEvalAlts cc_slot uniq (StgAlgAlts ty alts deflt)
= if not use_labelled_alts then
Nothing -- no semi-tagging info
else
- cgSemiTaggedAlts isw_chkr uniq alts deflt -- Just <something>
+ cgSemiTaggedAlts uniq alts deflt -- Just <something>
in
cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
`thenFC` \ (tagged_alt_absCs, deflt_absC) ->
@@ -560,10 +574,9 @@ It's all pretty turgid anyway.
\begin{code}
cgAlgAlts gc_flag uniq restore_cc semi_tagging
ty alts deflt@(StgBindDefault binder True{-used-} _)
- = getIntSwitchChkrC `thenFC` \ isw_chkr ->
- let
+ = let
extra_branches :: [FCode (ConTag, AbstractC)]
- extra_branches = catMaybes (map (mk_extra_branch isw_chkr) default_cons)
+ extra_branches = catMaybes (map mk_extra_branch default_cons)
must_label_default = semi_tagging || not (null extra_branches)
in
@@ -575,14 +588,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
default_join_lbl = mkDefaultLabel uniq
jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
- (spec_tycon, _, spec_cons)
- = -- trace ("cgCase:tycon:"++(ppShow 80 (ppAboves [
- -- ppr PprDebug uniq,
- -- ppr PprDebug ty,
- -- ppr PprShowAll binder
- -- ]))) (
- getUniDataSpecTyCon ty
- -- )
+ (spec_tycon, _, spec_cons) = getDataSpecTyCon ty
alt_cons = [ con | (con,_,_,_) <- alts ]
@@ -596,18 +602,18 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
-- nothing to do. Otherwise, we have a special case for a nullary constructor,
-- but in the general case we do an allocation and heap-check.
- mk_extra_branch :: IntSwitchChecker -> DataCon -> (Maybe (FCode (ConTag, AbstractC)))
+ mk_extra_branch :: DataCon -> (Maybe (FCode (ConTag, AbstractC)))
- mk_extra_branch isw_chkr con
+ mk_extra_branch con
= ASSERT(isDataCon con)
- case dataReturnConvAlg isw_chkr con of
+ case dataReturnConvAlg con of
ReturnInHeap -> Nothing
ReturnInRegs rs -> Just (getAbsC (alloc_code rs) `thenFC` \ abs_c ->
returnFC (tag, abs_c)
)
where
lf_info = mkConLFInfo con
- tag = getDataConTag con
+ tag = dataConTag con
closure_lbl = mkClosureLabel con
-- alloc_code generates code to allocate constructor con, whose args are
@@ -625,7 +631,7 @@ cgAlgAlts gc_flag uniq restore_cc semi_tagging
absC jump_instruction
)
where
- zero_size reg = getPrimRepSize (kindFromMagicId reg) == 0
+ zero_size reg = getPrimRepSize (magicIdPrimRep reg) == 0
\end{code}
Now comes the general case
@@ -698,16 +704,15 @@ cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
in
returnFC (tag, final_abs_c)
where
- tag = getDataConTag con
+ tag = dataConTag con
lbl = mkAltLabel uniq tag
cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
cgAlgAltRhs gc_flag con args use_mask rhs
- = getIntSwitchChkrC `thenFC` \ isw_chkr ->
- let
+ = let
(live_regs, node_reqd)
- = case (dataReturnConvAlg isw_chkr con) of
+ = case (dataReturnConvAlg con) of
ReturnInHeap -> ([], True)
ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
-- Pick the live registers using the use_mask
@@ -735,14 +740,13 @@ Turgid-but-non-monadic code to conjure up the required info from
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: IntSwitchChecker
- -> Unique
+cgSemiTaggedAlts :: Unique
-> [(Id, [Id], [Bool], StgExpr)]
-> GenStgCaseDefault Id Id
-> SemiTaggingStuff
-cgSemiTaggedAlts isw_chkr uniq alts deflt
- = Just (map (st_alt isw_chkr) alts, st_deflt deflt)
+cgSemiTaggedAlts uniq alts deflt
+ = Just (map st_alt alts, st_deflt deflt)
where
st_deflt StgNoDefault = Nothing
@@ -752,8 +756,8 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt
mkDefaultLabel uniq)
)
- st_alt isw_chkr (con, args, use_mask, _)
- = case (dataReturnConvAlg isw_chkr con) of
+ st_alt (con, args, use_mask, _)
+ = case (dataReturnConvAlg con) of
ReturnInHeap ->
-- Ha! Nothing to do; Node already points to the thing
@@ -767,7 +771,7 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt
-- We have to load the live registers from the constructor
-- pointed to by Node.
let
- (_, regs_w_offsets) = layOutDynCon con kindFromMagicId regs
+ (_, regs_w_offsets) = layOutDynCon con magicIdPrimRep regs
used_regs = selectByMask use_mask regs
@@ -784,12 +788,12 @@ cgSemiTaggedAlts isw_chkr uniq alts deflt
CSimultaneous (mkAbstractCs (map move_to_reg used_regs_w_offsets))],
join_label))
where
- con_tag = getDataConTag con
+ con_tag = dataConTag con
join_label = mkAltLabel uniq con_tag
move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
move_to_reg (reg, offset)
- = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
+ = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
\end{code}
%************************************************************************
@@ -821,7 +825,7 @@ cgPrimAlts gc_flag uniq ty alts deflt
NoGC -> CTemp uniq kind
GCMayHappen -> CReg (dataReturnConvPrim kind)
- kind = primRepFromType ty
+ kind = typePrimRep ty
cgPrimAltsGivenScrutinee gc_flag scrutinee alts deflt
@@ -892,7 +896,7 @@ saveVolatileVars :: StgLiveVars -- Vars which should be made safe
-> FCode AbstractC -- Assignments to to the saves
saveVolatileVars vars
- = save_em (uniqSetToList vars)
+ = save_em (idSetToList vars)
where
save_em [] = returnFC AbsCNop
@@ -978,7 +982,9 @@ saveCurrentCostCentre ::
-- AbsCNop if not lexical CCs
saveCurrentCostCentre
- = isSwitchSetC SccProfilingOn `thenFC` \ doing_profiling ->
+ = let
+ doing_profiling = opt_SccProfilingOn
+ in
if not doing_profiling then
returnFC (Nothing, AbsCNop)
else
@@ -1047,9 +1053,9 @@ mkReturnVector uniq ty tagged_alt_absCs deflt_absC
-- )
where
- (spec_tycon,_,_) = case (getUniDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
+ (spec_tycon,_,_) = case (getDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
Just xx -> xx
- Nothing -> error ("ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: "++(ppShow 80 (ppr PprDebug ty)))
+ Nothing -> pprError "ERROR: can't generate code for polymorphic case;\nprobably a mis-use of `seq' or `par';\nthe User's Guide has more details.\nOffending type: " (ppr PprDebug ty)
vtbl_label = mkVecTblLabel uniq
ret_label = mkReturnPtLabel uniq
diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs
index af318428cb..eeaf9dac40 100644
--- a/ghc/compiler/codeGen/CgClosure.lhs
+++ b/ghc/compiler/codeGen/CgClosure.lhs
@@ -12,31 +12,29 @@ with {\em closures} on the RHSs of let(rec)s. See also
module CgClosure ( cgTopRhsClosure, cgRhsClosure ) where
-import StgSyn
+import Ubiq{-uitous-}
+import CgLoop2 ( cgExpr, cgSccExpr )
+
import CgMonad
import AbsCSyn
+import StgSyn
-import PrelInfo ( PrimOp(..), Name
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Type ( isPrimType, isPrimTyCon,
- getTauType, showTypeCategory, getTyConDataCons
- )
-import CgBindery ( getCAddrMode, getAtomAmodes,
- getCAddrModeAndInfo,
- bindNewToNode, bindNewToAStack, bindNewToBStack,
- bindNewToReg, bindArgsToRegs
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getCAddrMode, getArgAmodes,
+ getCAddrModeAndInfo, bindNewToNode,
+ bindNewToAStack, bindNewToBStack,
+ bindNewToReg, bindArgsToRegs,
+ stableAmodeIdInfo, heapIdInfo
)
import CgCompInfo ( spARelToInt, spBRelToInt )
-import CgExpr ( cgExpr, cgSccExpr )
import CgUpdate ( pushUpdateFrame )
import CgHeapery ( allocDynClosure, heapCheck
#ifdef GRAN
- , heapCheckOnly, fetchAndReschedule -- HWL
-#endif {- GRAN -}
+ , fetchAndReschedule -- HWL
+#endif
)
-import CgRetConv ( ctrlReturnConvAlg, dataReturnConvAlg, mkLiveRegsBitMask,
+import CgRetConv ( mkLiveRegsMask,
+ ctrlReturnConvAlg, dataReturnConvAlg,
CtrlReturnConvention(..), DataReturnConvention(..)
)
import CgStackery ( getFinalStackHW, mkVirtStkOffsets,
@@ -46,20 +44,37 @@ import CgUsages ( getVirtSps, setRealAndVirtualSps,
getSpARelOffset, getSpBRelOffset,
getHpRelOffset
)
-import CLabel
+import CLabel ( mkClosureLabel, mkConUpdCodePtrVecLabel,
+ mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel,
+ mkErrorStdEntryLabel, mkRednCountsLabel
+ )
import ClosureInfo -- lots and lots of stuff
-import CostCentre
-import Id ( idType, getIdPrimRep, isSysLocalId, myWrapperMaybe,
- showId, getIdInfo, getIdStrictness,
- getDataConTag
+import CmdLineOpts ( opt_EmitArityChecks, opt_ForConcurrent,
+ opt_AsmTarget
+ )
+import CostCentre ( useCurrentCostCentre, currentOrSubsumedCosts,
+ noCostCentreAttached, costsAreSubsumed,
+ isCafCC, overheadCostCentre
+ )
+import HeapOffs ( VirtualHeapOffset(..) )
+import Id ( idType, idPrimRep,
+ showId, getIdStrictness, dataConTag,
+ emptyIdSet,
+ GenId{-instance Outputable-}
)
-import IdInfo
import ListSetOps ( minusList )
-import Maybes ( Maybe(..), maybeToBool )
-import PrimRep ( isFollowableRep )
-import UniqSet
-import Unpretty
-import Util
+import Maybes ( maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-}, TyCon{-ditto-} )
+import Pretty ( prettyToUn, ppBesides, ppChar, ppPStr )
+import PrimRep ( isFollowableRep, PrimRep(..) )
+import TyCon ( isPrimTyCon, tyConDataCons )
+import Unpretty ( uppShow )
+import Util ( isIn, panic, pprPanic, assertPanic )
+
+myWrapperMaybe = panic "CgClosure.myWrapperMaybe (ToDo)"
+showTypeCategory = panic "CgClosure.showTypeCategory (ToDo)"
+getWrapperArgTypeCategories = panic "CgClosure.getWrapperArgTypeCategories (ToDo)"
\end{code}
%********************************************************
@@ -171,7 +186,7 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
-- ToDo: check non-primitiveness (ASSERT)
= (
-- LAY OUT THE OBJECT
- getAtomAmodes std_thunk_payload `thenFC` \ amodes ->
+ getArgAmodes std_thunk_payload `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
= layOutDynClosure binder getAmodeRep amodes lf_info
@@ -226,7 +241,7 @@ cgRhsClosure binder cc binder_info fvs args body lf_info
amodes_w_offsets = [(amode,offset) | ((_, (amode,_)), offset) <- bind_details]
- get_kind (id, amode_and_info) = getIdPrimRep id
+ get_kind (id, amode_and_info) = idPrimRep id
in
-- BUILD ITS INFO TABLE AND CODE
forkClosureBody (
@@ -302,7 +317,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
-- If f is not top-level, then f is one of the free variables too,
-- hence "payload_ids" isn't the same as "arg_ids".
--
- vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyUniqSet
+ vap_entry_rhs = StgApp (StgVarArg fun) (map StgVarArg args) emptyIdSet
-- Empty live vars
arg_ids_w_info = [(name,mkLFArgument) | name <- args]
@@ -320,7 +335,7 @@ cgVapInfoTable perhaps_bind_the_fun upd_flag fun args fun_in_payload fun_lf_info
-- let x = f p q -- x isn't top level!
-- in ...
- get_kind (id, info) = getIdPrimRep id
+ get_kind (id, info) = idPrimRep id
payload_bind_details :: [((Id, LambdaFormInfo), VirtualHeapOffset)]
(closure_info, payload_bind_details) = layOutDynClosure
@@ -390,11 +405,10 @@ closureCodeBody binder_info closure_info cc [] body
#endif
getAbsC body_code `thenFC` \ body_absC ->
moduleName `thenFC` \ mod_name ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
absC (CClosureInfoAndCode closure_info body_absC Nothing
stdUpd (cl_descr mod_name)
- (dataConLiveness isw_chkr closure_info))
+ (dataConLiveness closure_info))
where
cl_descr mod_name = closureDescription mod_name (closureId closure_info) [] body
@@ -418,22 +432,19 @@ Node points to closure is available. -- HWL
\begin{code}
closureCodeBody binder_info closure_info cc all_args body
= getEntryConvention id lf_info
- (map getIdPrimRep all_args) `thenFC` \ entry_conv ->
-
- isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
-
- isStringSwitchSetC AsmTarget `thenFC` \ native_code ->
-
+ (map idPrimRep all_args) `thenFC` \ entry_conv ->
let
+ do_arity_chks = opt_EmitArityChecks
+ is_concurrent = opt_ForConcurrent
+ native_code = opt_AsmTarget
+
stg_arity = length all_args
-- Arg mapping for standard (slow) entry point; all args on stack
(spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets)
= mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
- getIdPrimRep
+ idPrimRep
all_args
-- Arg mapping for the fast entry point; as many args as poss in
@@ -450,7 +461,7 @@ closureCodeBody binder_info closure_info cc all_args body
(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
= mkVirtStkOffsets
0 0 -- Initial virtual SpA, SpB
- getIdPrimRep
+ idPrimRep
stk_args
-- HWL; Note: empty list of live regs in slow entry code
@@ -531,7 +542,6 @@ closureCodeBody binder_info closure_info cc all_args body
`thenFC` \ slow_abs_c ->
forkAbsC fast_entry_code `thenFC` \ fast_abs_c ->
moduleName `thenFC` \ mod_name ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-- Now either construct the info table, or put the fast code in alone
-- (We never have slow code without an info table)
@@ -539,7 +549,7 @@ closureCodeBody binder_info closure_info cc all_args body
if info_table_needed then
CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c)
stdUpd (cl_descr mod_name)
- (dataConLiveness isw_chkr closure_info)
+ (dataConLiveness closure_info)
else
CCodeBlock fast_label fast_abs_c
)
@@ -665,18 +675,22 @@ argSatisfactionCheck closure_info args
if (isFollowableRep (getAmodeRep last_amode)) then
getSpARelOffset 0 `thenFC` \ (SpARel spA off) ->
+ let
+ lit = mkIntCLit (spARelToInt spA off)
+ in
if node_points then
- absC (CMacroStmt ARGS_CHK_A [mkIntCLit (spARelToInt spA off)])
+ absC (CMacroStmt ARGS_CHK_A [lit])
else
- absC (CMacroStmt ARGS_CHK_A_LOAD_NODE
- [mkIntCLit (spARelToInt spA off), set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_A_LOAD_NODE [lit, set_Node_to_this])
else
- getSpBRelOffset 0 `thenFC` \ b_rel_offset ->
+ getSpBRelOffset 0 `thenFC` \ (SpBRel spB off) ->
+ let
+ lit = mkIntCLit (spBRelToInt spB off)
+ in
if node_points then
- absC (CMacroStmt ARGS_CHK_B [mkIntCLit (spBRelToInt b_rel_offset)])
+ absC (CMacroStmt ARGS_CHK_B [lit])
else
- absC (CMacroStmt ARGS_CHK_B_LOAD_NODE
- [mkIntCLit (spBRelToInt b_rel_offset), set_Node_to_this])
+ absC (CMacroStmt ARGS_CHK_B_LOAD_NODE [lit, set_Node_to_this])
where
-- We must tell the arg-satis macro whether Node is pointing to
-- the closure or not. If it isn't so pointing, then we give to
@@ -780,7 +794,7 @@ stackCheck closure_info regs node_reqd code
)
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
returns_prim_type = closureReturnsUnboxedType closure_info
\end{code}
@@ -817,8 +831,7 @@ setupUpdate :: ClosureInfo -> Code -> Code -- Only called for thunks
setupUpdate closure_info code
= if (closureUpdReqd closure_info) then
link_caf_if_needed `thenFC` \ update_closure ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- pushUpdateFrame update_closure (vector isw_chkr) code
+ pushUpdateFrame update_closure vector code
else
profCtrC SLIT("UPDF_OMITTED") [] `thenC`
code
@@ -849,7 +862,7 @@ setupUpdate closure_info code
closure_label = mkClosureLabel (closureId closure_info)
- vector isw_chkr
+ vector
= case (closureType closure_info) of
Nothing -> CReg StdUpdRetVecReg
Just (spec_tycon, _, spec_datacons) ->
@@ -857,9 +870,9 @@ setupUpdate closure_info code
UnvectoredReturn 1 ->
let
spec_data_con = head spec_datacons
- only_tag = getDataConTag spec_data_con
+ only_tag = dataConTag spec_data_con
- direct = case (dataReturnConvAlg isw_chkr spec_data_con) of
+ direct = case (dataReturnConvAlg spec_data_con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel spec_tycon only_tag
ReturnInHeap -> mkStdUpdCodePtrVecLabel spec_tycon only_tag
@@ -893,8 +906,8 @@ closureDescription :: FAST_STRING -- Module
-- Not called for StgRhsCon which have global info tables built in
-- CgConTbls.lhs with a description generated from the data constructor
-closureDescription mod_name name args body =
- uppShow 0 (prettyToUn (
+closureDescription mod_name name args body
+ = uppShow 0 (prettyToUn (
ppBesides [ppChar '<',
ppPStr mod_name,
ppChar '.',
diff --git a/ghc/compiler/codeGen/CgCompInfo.lhs b/ghc/compiler/codeGen/CgCompInfo.lhs
index 4b52bf0b6a..9b14dcdaf9 100644
--- a/ghc/compiler/codeGen/CgCompInfo.lhs
+++ b/ghc/compiler/codeGen/CgCompInfo.lhs
@@ -141,6 +141,9 @@ mAX_INTLIKE = MAX_INTLIKE
\begin{code}
-- THESE ARE DIRECTION SENSITIVE!
+spARelToInt :: Int{-VirtualSpAOffset-} -> Int{-VirtualSpAOffset-} -> Int
+spBRelToInt :: Int{-VirtualSpBOffset-} -> Int{-VirtualSpBOffset-} -> Int
+
spARelToInt spA off = spA - off -- equiv to: AREL(spA - off)
spBRelToInt spB off = off - spB -- equiv to: BREL(spB - off)
\end{code}
diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs
index 8201335699..6c378a93ee 100644
--- a/ghc/compiler/codeGen/CgCon.lhs
+++ b/ghc/compiler/codeGen/CgCon.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP Project, Glasgow University, 1992-1995
+% (c) The GRASP Project, Glasgow University, 1992-1996
%
\section[CgCon]{Code generation for constructors}
@@ -11,55 +11,50 @@ with {\em constructors} on the RHSs of let(rec)s. See also
#include "HsVersions.h"
module CgCon (
- -- it's all exported, actually...
cgTopRhsCon, buildDynCon,
bindConArgs,
cgReturnDataCon
-
- -- and to make the interface self-sufficient...
) where
-import StgSyn
+import Ubiq{-uitous-}
+
import CgMonad
import AbsCSyn
+import StgSyn
-import Type ( maybeCharLikeTyCon, maybeIntLikeTyCon, TyVar,
- TyCon, Class, Type
- )
-import CgBindery ( getAtomAmode, getAtomAmodes, bindNewToNode,
- bindArgsToRegs, newTempAmodeAndIdInfo, idInfoToAmode
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgBindery ( getArgAmodes, bindNewToNode,
+ bindArgsToRegs, newTempAmodeAndIdInfo,
+ idInfoToAmode, stableAmodeIdInfo,
+ heapIdInfo
)
import CgClosure ( cgTopRhsClosure )
-import CgHeapery ( allocDynClosure, heapCheck
-#ifdef GRAN
- , fetchAndReschedule -- HWL
-#endif {- GRAN -}
- )
import CgCompInfo ( mAX_INTLIKE, mIN_INTLIKE )
-
-import CgRetConv ( dataReturnConvAlg, mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
- )
+import CgHeapery ( allocDynClosure )
+import CgRetConv ( dataReturnConvAlg, DataReturnConvention(..) )
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
-import CgUsages ( getHpRelOffset )
-import CLabel ( CLabel, mkClosureLabel, mkInfoTableLabel,
+import CLabel ( mkClosureLabel, mkInfoTableLabel,
mkPhantomInfoTableLabel,
mkConEntryLabel, mkStdEntryLabel
)
-import ClosureInfo -- hiding ( auxInfoTableLabelFromCI ) -- I hate pragmas
- {-( mkConLFInfo, mkLFArgument, closureLFInfo,
+import ClosureInfo ( mkClosureLFInfo, mkConLFInfo, mkLFArgument,
layOutDynCon, layOutDynClosure,
- layOutStaticClosure, UpdateFlag(..),
- mkClosureLFInfo, layOutStaticNoFVClosure
- )-}
-import Id ( getIdPrimRep, getDataConTag, getDataConTyCon,
- isDataCon, fIRST_TAG, DataCon(..), ConTag(..)
+ layOutStaticClosure
+ )
+import CostCentre ( currentOrSubsumedCosts, useCurrentCostCentre,
+ dontCareCostCentre
)
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimRep ( PrimRep(..), isFloatingRep, getPrimRepSize )
-import CostCentre
-import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import Util
+import Id ( idPrimRep, dataConTag, dataConTyCon,
+ isDataCon, DataCon(..),
+ emptyIdSet
+ )
+import Literal ( Literal(..) )
+import Maybes ( maybeToBool )
+import PrimRep ( isFloatingRep, PrimRep(..) )
+import Util ( isIn, zipWithEqual, panic, assertPanic )
+
+maybeCharLikeTyCon = panic "CgCon.maybeCharLikeTyCon (ToDo)"
+maybeIntLikeTyCon = panic "CgCon.maybeIntLikeTyCon (ToDo)"
\end{code}
%************************************************************************
@@ -71,7 +66,7 @@ import Util
\begin{code}
cgTopRhsCon :: Id -- Name of thing bound to this RHS
-> DataCon -- Id
- -> [StgArg] -- Args
+ -> [StgArg] -- Args
-> Bool -- All zero-size args (see buildDynCon)
-> FCode (Id, CgIdInfo)
\end{code}
@@ -130,7 +125,7 @@ cgTopRhsCon name con args all_zero_size_args
|| any isLitLitArg args
= cgTopRhsClosure name top_cc NoStgBinderInfo [] body lf_info
where
- body = StgCon con args emptyUniqSet{-emptyLiveVarSet-}
+ body = StgCon con args emptyIdSet{-emptyLiveVarSet-}
lf_info = mkClosureLFInfo True {- Top level -} [] ReEntrant [] body
\end{code}
@@ -142,7 +137,7 @@ cgTopRhsCon name con args all_zero_size_args
ASSERT(isDataCon con)
-- LAY IT OUT
- getAtomAmodes args `thenFC` \ amodes ->
+ getArgAmodes args `thenFC` \ amodes ->
let
(closure_info, amodes_w_offsets)
@@ -163,13 +158,13 @@ cgTopRhsCon name con args all_zero_size_args
-- RETURN
returnFC (name, stableAmodeIdInfo name (CLbl closure_label PtrRep) lf_info)
where
- con_tycon = getDataConTyCon con
- lf_info = mkConLFInfo con
+ con_tycon = dataConTyCon con
+ lf_info = mkConLFInfo con
- closure_label = mkClosureLabel name
+ closure_label = mkClosureLabel name
info_label = mkInfoTableLabel con
- con_entry_label = mkConEntryLabel con
- entry_label = mkStdEntryLabel name
+ con_entry_label = mkConEntryLabel con
+ entry_label = mkStdEntryLabel name
\end{code}
The general case is:
@@ -314,10 +309,10 @@ buildDynCon binder cc con [arg_amode] all_zero_size_args@False
= ASSERT(isDataCon con)
returnFC (stableAmodeIdInfo binder (CIntLike arg_amode) (mkConLFInfo con))
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
(temp_amode, temp_id_info) = newTempAmodeAndIdInfo binder (mkConLFInfo con)
- in_range_int_lit (CLit (MachInt val _)) = (val <= mAX_INTLIKE) && (val >= mIN_INTLIKE)
+ in_range_int_lit (CLit (MachInt val _)) = val <= mAX_INTLIKE && val >= mIN_INTLIKE
in_range_int_lit other_amode = False
\end{code}
@@ -357,13 +352,11 @@ found a $con$.
bindConArgs :: DataCon -> [Id] -> Code
bindConArgs con args
= ASSERT(isDataCon con)
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
-
- case (dataReturnConvAlg isw_chkr con) of
+ case (dataReturnConvAlg con) of
ReturnInRegs rs -> bindArgsToRegs args rs
ReturnInHeap ->
let
- (_, args_w_offsets) = layOutDynCon con getIdPrimRep args
+ (_, args_w_offsets) = layOutDynCon con idPrimRep args
in
mapCs bind_arg args_w_offsets
where
@@ -385,13 +378,12 @@ cgReturnDataCon :: DataCon -> [CAddrMode] -> Bool -> StgLiveVars -> Code
cgReturnDataCon con amodes all_zero_size_args live_vars
= ASSERT(isDataCon con)
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
getEndOfBlockInfo `thenFC` \ (EndOfBlockInfo args_spa args_spb sequel) ->
case sequel of
CaseAlts _ (Just (alts, Just (maybe_deflt_binder, (_,deflt_lbl))))
- | not (getDataConTag con `is_elem` map fst alts)
+ | not (dataConTag con `is_elem` map fst alts)
->
-- Special case! We're returning a constructor to the default case
-- of an enclosing case. For example:
@@ -423,7 +415,7 @@ cgReturnDataCon con amodes all_zero_size_args live_vars
-- Ignore the sequel: we've already looked at it above
other_sequel -> -- The usual case
- case (dataReturnConvAlg isw_chkr con) of
+ case (dataReturnConvAlg con) of
ReturnInHeap ->
-- BUILD THE OBJECT IN THE HEAP
diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs
index 79dd48e6ea..4252890f08 100644
--- a/ghc/compiler/codeGen/CgConTbls.lhs
+++ b/ghc/compiler/codeGen/CgConTbls.lhs
@@ -1,59 +1,52 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgConTbls]{Info tables and update bits for constructors}
\begin{code}
#include "HsVersions.h"
-module CgConTbls (
- genStaticConBits,
+module CgConTbls ( genStaticConBits ) where
- -- and to complete the interface...
- TCE(..), UniqFM, CompilationInfo, AbstractC
- ) where
-
-import Pretty -- ToDo: rm (debugging)
-import Outputable
+import Ubiq{-uitous-}
import AbsCSyn
import CgMonad
-import Type ( getTyConDataCons, primRepFromType,
- maybeIntLikeTyCon, mkSpecTyCon,
- TyVarTemplate, TyCon, Class,
- TauType(..), Type, ThetaType(..)
- )
+import AbsCUtils ( mkAbsCStmts, mkAbstractCs, magicIdPrimRep )
+import CgCompInfo ( uF_UPDATEE )
import CgHeapery ( heapCheck, allocDynClosure )
-import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
- mkLiveRegsBitMask,
+import CgRetConv ( mkLiveRegsMask,
+ dataReturnConvAlg, ctrlReturnConvAlg,
CtrlReturnConvention(..),
DataReturnConvention(..)
)
import CgTailCall ( performReturn, mkStaticAlgReturnCode )
import CgUsages ( getHpRelOffset )
-import CLabel ( mkConEntryLabel, mkStaticConEntryLabel,
- mkClosureLabel,
- mkConUpdCodePtrVecLabel, mkStdUpdCodePtrVecLabel,
- mkStdUpdVecTblLabel, CLabel
+import CLabel ( mkConEntryLabel, mkClosureLabel,
+ mkConUpdCodePtrVecLabel,
+ mkStdUpdCodePtrVecLabel, mkStdUpdVecTblLabel
)
import ClosureInfo ( layOutStaticClosure, layOutDynCon,
- closureSizeWithoutFixedHdr, closurePtrsSize,
- fitsMinUpdSize, mkConLFInfo, layOutPhantomClosure,
+ layOutPhantomClosure, closurePtrsSize,
+ fitsMinUpdSize, mkConLFInfo,
infoTableLabelFromCI, dataConLiveness
)
-import FiniteMap
-import Id ( getDataConTag, getDataConSig, getDataConTyCon,
- mkSameSpecCon,
- getDataConArity, fIRST_TAG, ConTag(..),
- DataCon(..)
+import CostCentre ( dontCareCostCentre )
+import FiniteMap ( fmToList )
+import HeapOffs ( zeroOff, VirtualHeapOffset(..) )
+import Id ( dataConTag, dataConSig,
+ dataConArity, fIRST_TAG,
+ emptyIdSet,
+ GenId{-instance NamedThing-}
)
-import CgCompInfo ( uF_UPDATEE )
-import Maybes ( maybeToBool, Maybe(..) )
-import PrimRep ( getPrimRepSize, retPrimRepSize )
-import CostCentre
-import UniqSet -- ( emptyUniqSet, UniqSet(..) )
-import Util
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import TyCon ( tyConDataCons, mkSpecTyCon )
+import Type ( typePrimRep )
+import Util ( panic )
+
+maybeIntLikeTyCon = panic "CgConTbls.maybeIntLikeTyCon (ToDo)"
+mkSameSpecCon = panic "CgConTbls.mkSameSpecCon (ToDo)"
\end{code}
For every constructor we generate the following info tables:
@@ -139,7 +132,7 @@ genStaticConBits comp_info gen_tycons tycon_specs
`mkAbsCStmts`
maybe_tycon_vtbl
where
- data_cons = getTyConDataCons tycon
+ data_cons = tyConDataCons tycon
tycon_upd_label = mkStdUpdVecTblLabel tycon
maybe_tycon_vtbl =
@@ -157,7 +150,7 @@ genStaticConBits comp_info gen_tycons tycon_specs
`mkAbsCStmts`
maybe_spec_tycon_vtbl
where
- data_cons = getTyConDataCons tycon
+ data_cons = tyConDataCons tycon
spec_tycon = mkSpecTyCon tycon ty_maybes
spec_data_cons = map (mkSameSpecCon ty_maybes) data_cons
@@ -174,15 +167,12 @@ genStaticConBits comp_info gen_tycons tycon_specs
------------------
mk_upd_label tycon con
= CLbl
- (case (dataReturnConvAlg isw_chkr con) of
+ (case (dataReturnConvAlg con) of
ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag)
CodePtrRep
where
- tag = getDataConTag con
-
- ------------------
- (MkCompInfo sw_chkr isw_chkr _) = comp_info
+ tag = dataConTag con
\end{code}
%************************************************************************
@@ -197,7 +187,7 @@ static closure, for a constructor.
\begin{code}
genConInfo :: CompilationInfo -> TyCon -> Id -> AbstractC
-genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
+genConInfo comp_info tycon data_con
= mkAbstractCs [
CSplitMarker,
inregs_upd_maybe,
@@ -206,12 +196,12 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
closure_maybe]
-- Order of things is to reduce forward references
where
- (closure_info, body_code) = mkConCodeAndInfo isw_chkr data_con
+ (closure_info, body_code) = mkConCodeAndInfo data_con
-- To allow the debuggers, interpreters, etc to cope with static
-- data structures (ie those built at compile time), we take care that
-- info-table contains the information we need.
- (static_ci,_) = layOutStaticClosure data_con primRepFromType arg_tys (mkConLFInfo data_con)
+ (static_ci,_) = layOutStaticClosure data_con typePrimRep arg_tys (mkConLFInfo data_con)
body = (initC comp_info (
profCtrC SLIT("ENT_CON") [CReg node] `thenC`
@@ -222,16 +212,16 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
closure_code = CClosureInfoAndCode closure_info body Nothing
stdUpd con_descr
- (dataConLiveness isw_chkr closure_info)
+ (dataConLiveness closure_info)
static_code = CClosureInfoAndCode static_ci body Nothing
stdUpd con_descr
- (dataConLiveness isw_chkr static_ci)
+ (dataConLiveness static_ci)
inregs_upd_maybe = genPhantomUpdInfo comp_info tycon data_con
stdUpd = CLbl (mkStdUpdCodePtrVecLabel tycon tag) CodePtrRep
- tag = getDataConTag data_con
+ tag = dataConTag data_con
cost_centre = mkCCostCentre dontCareCostCentre -- not worried about static data costs
@@ -247,42 +237,41 @@ genConInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
cost_centre
[{-No args! A slight lie for constrs with VoidRep args-}]
- zero_size arg_ty = getPrimRepSize (primRepFromType arg_ty) == 0
+ zero_size arg_ty = getPrimRepSize (typePrimRep arg_ty) == 0
- (_,_,arg_tys,_) = getDataConSig data_con
- con_arity = getDataConArity data_con
+ (_,_,arg_tys,_) = dataConSig data_con
+ con_arity = dataConArity data_con
entry_label = mkConEntryLabel data_con
closure_label = mkClosureLabel data_con
\end{code}
\begin{code}
-mkConCodeAndInfo :: IntSwitchChecker
- -> Id -- Data constructor
+mkConCodeAndInfo :: Id -- Data constructor
-> (ClosureInfo, Code) -- The info table
-mkConCodeAndInfo isw_chkr con
- = case (dataReturnConvAlg isw_chkr con) of
+mkConCodeAndInfo con
+ = case (dataReturnConvAlg con) of
ReturnInRegs regs ->
let
(closure_info, regs_w_offsets)
- = layOutDynCon con kindFromMagicId regs
+ = layOutDynCon con magicIdPrimRep regs
body_code
= profCtrC SLIT("RET_OLD_IN_REGS") [mkIntCLit (length regs_w_offsets)] `thenC`
performReturn (mkAbstractCs (map move_to_reg regs_w_offsets))
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ emptyIdSet{-no live vars-}
in
(closure_info, body_code)
ReturnInHeap ->
let
- (_, _, arg_tys, _) = getDataConSig con
+ (_, _, arg_tys, _) = dataConSig con
(closure_info, arg_things)
- = layOutDynCon con primRepFromType arg_tys
+ = layOutDynCon con typePrimRep arg_tys
body_code
= -- NB: We don't set CC when entering data (WDP 94/06)
@@ -290,14 +279,14 @@ mkConCodeAndInfo isw_chkr con
performReturn AbsCNop -- Ptr to thing already in Node
(mkStaticAlgReturnCode con Nothing {- Info-ptr already loaded-})
- emptyUniqSet{-no live vars-}
+ emptyIdSet{-no live vars-}
in
(closure_info, body_code)
where
move_to_reg :: (MagicId, VirtualHeapOffset {-from Node-}) -> AbstractC
move_to_reg (reg, offset)
- = CAssign (CReg reg) (CVal (NodeRel offset) (kindFromMagicId reg))
+ = CAssign (CReg reg) (CVal (NodeRel offset) (magicIdPrimRep reg))
\end{code}
%************************************************************************
@@ -312,8 +301,8 @@ Generate the "phantom" info table and update code, iff the constructor returns i
genPhantomUpdInfo :: CompilationInfo -> TyCon -> Id{-data con-} -> AbstractC
-genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
- = case (dataReturnConvAlg isw_chkr data_con) of
+genPhantomUpdInfo comp_info tycon data_con
+ = case (dataReturnConvAlg data_con) of
ReturnInHeap -> AbsCNop -- No need for a phantom update
@@ -321,19 +310,19 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
let
phantom_itbl = CClosureInfoAndCode phantom_ci AbsCNop Nothing
upd_code con_descr
- (dataConLiveness isw_chkr phantom_ci)
+ (dataConLiveness phantom_ci)
phantom_ci = layOutPhantomClosure data_con (mkConLFInfo data_con)
con_descr = _UNPK_ (getOccurrenceName data_con)
- con_arity = getDataConArity data_con
+ con_arity = dataConArity data_con
upd_code = CLabelledCode upd_label (mkAbsCStmts build_closure perform_return)
upd_label = mkConUpdCodePtrVecLabel tycon tag
- tag = getDataConTag data_con
+ tag = dataConTag data_con
- updatee = CVal (SpBRel 0 (-uF_UPDATEE)) PtrRep
+ updatee = CVal (SpBRel 0 (- uF_UPDATEE)) PtrRep
perform_return = mkAbstractCs
[
@@ -352,7 +341,7 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
blame_cc = use_cc -- who to blame for allocation
do_move (reg, virt_offset) =
- CAssign (CVal (NodeRel virt_offset) (kindFromMagicId reg)) (CReg reg)
+ CAssign (CVal (NodeRel virt_offset) (magicIdPrimRep reg)) (CReg reg)
-- Code for building a new constructor in place over the updatee
@@ -402,9 +391,9 @@ genPhantomUpdInfo comp_info@(MkCompInfo _ isw_chkr _) tycon data_con
CAssign (CReg infoptr) (CLbl info_label DataPtrRep)
])
- (closure_info, regs_w_offsets) = layOutDynCon data_con kindFromMagicId regs
+ (closure_info, regs_w_offsets) = layOutDynCon data_con magicIdPrimRep regs
info_label = infoTableLabelFromCI closure_info
- liveness_mask = mkIntCLit (mkLiveRegsBitMask (node:regs))
+ liveness_mask = mkIntCLit (mkLiveRegsMask (node:regs))
build_closure =
if fitsMinUpdSize closure_info then
diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs
index 4713767f5a..6fed112402 100644
--- a/ghc/compiler/codeGen/CgExpr.lhs
+++ b/ghc/compiler/codeGen/CgExpr.lhs
@@ -10,40 +10,41 @@
\begin{code}
#include "HsVersions.h"
-module CgExpr (
- cgExpr, cgSccExpr, getPrimOpArgAmodes
+module CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes ) where
- -- and to make the interface self-sufficient...
- ) where
+import Ubiq{-uitous-}
+import CgLoop2 -- here for paranoia-checking
import StgSyn
import CgMonad
import AbsCSyn
-import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), HeapRequirement(..),
- primOpHeapReq, getPrimOpResultInfo, PrimRep,
- primOpCanTriggerGC
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
- )
-import Type ( isPrimType, getTyConDataCons )
-import CLabel ( CLabel, mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
-import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo )
-import CgBindery ( getAtomAmodes )
+import AbsCUtils ( mkAbsCStmts, mkAbstractCs )
+import CgBindery ( getArgAmodes )
import CgCase ( cgCase, saveVolatileVarsAndRegs )
import CgClosure ( cgRhsClosure )
import CgCon ( buildDynCon, cgReturnDataCon )
import CgHeapery ( allocHeap )
import CgLetNoEscape ( cgLetNoEscapeClosure )
-import CgRetConv -- various things...
-import CgTailCall ( cgTailCall, performReturn, mkDynamicAlgReturnCode,
- mkPrimReturnCode
+import CgRetConv ( dataReturnConvAlg, ctrlReturnConvAlg,
+ DataReturnConvention(..), CtrlReturnConvention(..),
+ assignPrimOpResultRegs, makePrimOpArgsRobust
+ )
+import CgTailCall ( cgTailCall, performReturn,
+ mkDynamicAlgReturnCode, mkPrimReturnCode
+ )
+import CLabel ( mkPhantomInfoTableLabel, mkInfoTableVecTblLabel )
+import ClosureInfo ( mkClosureLFInfo )
+import CostCentre ( setToAbleCostCentre, isDupdCC )
+import HeapOffs ( VirtualSpBOffset(..) )
+import Id ( mkIdSet, unionIdSets, GenId{-instance Outputable-} )
+import PprStyle ( PprStyle(..) )
+import PrimOp ( primOpCanTriggerGC, primOpHeapReq, HeapRequirement(..),
+ getPrimOpResultInfo, PrimOp(..), PrimOpResultInfo(..)
)
-import CostCentre ( setToAbleCostCentre, isDupdCC, CostCentre )
-import Maybes ( Maybe(..) )
-import PrimRep ( getPrimRepSize )
-import UniqSet
-import Util
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import TyCon ( tyConDataCons )
+import Util ( panic, pprPanic )
\end{code}
This module provides the support code for @StgToAbstractC@ to deal
@@ -77,7 +78,7 @@ cgExpr (StgApp fun args live_vars) = cgTailCall fun args live_vars
\begin{code}
cgExpr (StgCon con args live_vars)
- = getAtomAmodes args `thenFC` \ amodes ->
+ = getArgAmodes args `thenFC` \ amodes ->
cgReturnDataCon con amodes (all zero_size args) live_vars
where
zero_size atom = getPrimRepSize (getArgPrimRep atom) == 0
@@ -93,10 +94,9 @@ Here is where we insert real live machine instructions.
\begin{code}
cgExpr x@(StgPrim op args live_vars)
- = getIntSwitchChkrC `thenFC` \ isw_chkr ->
- getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
+ = getPrimOpArgAmodes op args `thenFC` \ arg_amodes ->
let
- result_regs = assignPrimOpResultRegs {-NO:isw_chkr-} op
+ result_regs = assignPrimOpResultRegs op
result_amodes = map CReg result_regs
may_gc = primOpCanTriggerGC op
dyn_tag = head result_amodes
@@ -108,7 +108,7 @@ cgExpr x@(StgPrim op args live_vars)
-- (Can-trigger-gc primops guarantee to have their args in regs)
let
(arg_robust_amodes, liveness_mask, arg_assts)
- = makePrimOpArgsRobust {-NO:isw_chkr-} op arg_amodes
+ = makePrimOpArgsRobust op arg_amodes
liveness_arg = mkIntCLit liveness_mask
in
@@ -172,10 +172,10 @@ cgExpr x@(StgPrim op args live_vars)
vec_lbl = CTableEntry (CLbl (mkInfoTableVecTblLabel tycon) DataPtrRep)
dyn_tag DataPtrRep
- data_con = head (getTyConDataCons tycon)
+ data_con = head (tyConDataCons tycon)
(dir_lbl, num_of_fields)
- = case (dataReturnConvAlg fake_isw_chkr data_con) of
+ = case (dataReturnConvAlg data_con) of
ReturnInRegs rs
-> (CLbl (mkPhantomInfoTableLabel data_con) DataPtrRep,
mkIntCLit (length rs)) -- for ticky-ticky only
@@ -184,8 +184,6 @@ cgExpr x@(StgPrim op args live_vars)
-> pprPanic "CgExpr: can't return prim in heap:" (ppr PprDebug data_con)
-- Never used, and no point in generating
-- the code for it!
-
- fake_isw_chkr x = Nothing
where
-- for all PrimOps except ccalls, we pin the liveness info
-- on as the first "argument"
@@ -314,7 +312,7 @@ cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along so a binding can be set up
cgRhs name (StgRhsCon maybe_cc con args)
- = getAtomAmodes args `thenFC` \ amodes ->
+ = getArgAmodes args `thenFC` \ amodes ->
buildDynCon name maybe_cc con amodes (all zero_size args)
`thenFC` \ idinfo ->
returnFC (name, idinfo)
@@ -344,7 +342,7 @@ cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
where
-- We add the binders to the live-in-rhss set so that we don't
-- delete the bindings for the binder from the environment!
- full_live_in_rhss = live_in_rhss `unionUniqSets` (mkUniqSet [b | (b,r) <- pairs])
+ full_live_in_rhss = live_in_rhss `unionIdSets` (mkIdSet [b | (b,r) <- pairs])
cgLetNoEscapeRhs
:: StgLiveVars -- Live in rhss
@@ -386,10 +384,9 @@ Main current use: allocating SynchVars.
\begin{code}
getPrimOpArgAmodes op args
- = getAtomAmodes args `thenFC` \ arg_amodes ->
+ = getArgAmodes args `thenFC` \ arg_amodes ->
case primOpHeapReq op of
-
FixedHeapRequired size -> allocHeap size `thenFC` \ amode ->
returnFC (amode : arg_amodes)
diff --git a/ghc/compiler/codeGen/CgHeapery.lhs b/ghc/compiler/codeGen/CgHeapery.lhs
index 98aed044e4..798c6ba16e 100644
--- a/ghc/compiler/codeGen/CgHeapery.lhs
+++ b/ghc/compiler/codeGen/CgHeapery.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgHeapery]{Heap management functions}
@@ -8,30 +8,31 @@
module CgHeapery (
heapCheck,
- allocHeap, allocDynClosure,
+ allocHeap, allocDynClosure
#ifdef GRAN
-- new for GrAnSim HWL
- heapCheckOnly, fetchAndReschedule,
+ , heapCheckOnly, fetchAndReschedule
#endif {- GRAN -}
-
- -- and to make the interface self-sufficient...
- AbstractC, CAddrMode, HeapOffset,
- CgState, ClosureInfo, Id
) where
+import Ubiq{-uitous-}
+
import AbsCSyn
import CgMonad
-import CgRetConv ( mkLiveRegsBitMask )
+import AbsCUtils ( mkAbstractCs, getAmodeRep )
+import CgRetConv ( mkLiveRegsMask )
import CgUsages ( getVirtAndRealHp, setVirtHp, setRealHp,
initHeapUsage
)
-import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize, slopSize,
- layOutDynClosure,
- allocProfilingMsg, closureKind
+import ClosureInfo ( closureSize, closureHdrSize, closureGoodStuffSize,
+ slopSize, allocProfilingMsg, closureKind
+ )
+import HeapOffs ( isZeroOff, addOff, intOff,
+ VirtualHeapOffset(..)
)
-import Util
+import PrimRep ( PrimRep(..) )
\end{code}
%************************************************************************
@@ -70,7 +71,7 @@ heapCheck regs node_reqd code
-- at once or not.
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
checking_code = CMacroStmt HEAP_CHK [
mkIntCLit liveness_mask,
@@ -149,7 +150,7 @@ heapCheck' do_context_switch regs node_reqd code
-- at once or not.
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
maybe_context_switch = if do_context_switch
then context_switch_code
@@ -177,7 +178,7 @@ fetchAndReschedule regs node_reqd =
else absC AbsCNop
where
all_regs = if node_reqd then node:regs else regs
- liveness_mask = mkLiveRegsBitMask all_regs
+ liveness_mask = mkLiveRegsMask all_regs
reschedule_code = absC (CMacroStmt GRAN_RESCHEDULE [
mkIntCLit liveness_mask,
diff --git a/ghc/compiler/codeGen/CgLetNoEscape.lhs b/ghc/compiler/codeGen/CgLetNoEscape.lhs
index 5480e93497..f59ef4eb7c 100644
--- a/ghc/compiler/codeGen/CgLetNoEscape.lhs
+++ b/ghc/compiler/codeGen/CgLetNoEscape.lhs
@@ -12,20 +12,24 @@
module CgLetNoEscape ( cgLetNoEscapeClosure ) where
+import Ubiq{-uitious-}
+import CgLoop2 ( cgExpr )
+
import StgSyn
import CgMonad
import AbsCSyn
-import CgBindery -- various things
-import CgExpr ( cgExpr )
+import CgBindery ( letNoEscapeIdInfo, bindArgsToRegs,
+ bindNewToAStack, bindNewToBStack
+ )
import CgHeapery ( heapCheck )
import CgRetConv ( assignRegs )
import CgStackery ( mkVirtStkOffsets )
import CgUsages ( setRealAndVirtualSps, getVirtSps )
-import CLabel ( mkStdEntryLabel )
+import CLabel ( mkStdEntryLabel )
import ClosureInfo ( mkLFLetNoEscape )
-import Id ( getIdPrimRep )
-import Util
+import HeapOffs ( VirtualSpBOffset(..) )
+import Id ( idPrimRep )
\end{code}
%************************************************************************
@@ -164,10 +168,9 @@ cgLetNoEscapeBody :: [Id] -- Args
cgLetNoEscapeBody all_args rhs
= getVirtSps `thenFC` \ (vA, vB) ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
let
- arg_kinds = map getIdPrimRep all_args
- (arg_regs, _) = assignRegs isw_chkr [{-nothing live-}] arg_kinds
+ arg_kinds = map idPrimRep all_args
+ (arg_regs, _) = assignRegs [{-nothing live-}] arg_kinds
stk_args = drop (length arg_regs) all_args
-- stk_args is the args which are passed on the stack at the fast-entry point
@@ -175,7 +178,7 @@ cgLetNoEscapeBody all_args rhs
(spA_stk_args, spB_stk_args, stk_bxd_w_offsets, stk_ubxd_w_offsets)
= mkVirtStkOffsets
vA vB -- Initial virtual SpA, SpB
- getIdPrimRep
+ idPrimRep
stk_args
in
diff --git a/ghc/compiler/codeGen/CgLoop1.lhi b/ghc/compiler/codeGen/CgLoop1.lhi
new file mode 100644
index 0000000000..ef8dd2d669
--- /dev/null
+++ b/ghc/compiler/codeGen/CgLoop1.lhi
@@ -0,0 +1,35 @@
+\begin{code}
+interface CgLoop1 where
+import PreludeStdIO ( Maybe )
+
+import CgBindery ( CgBindings(..), CgIdInfo(..),
+ VolatileLoc, StableLoc,
+ nukeVolatileBinds,
+ maybeAStkLoc, maybeBStkLoc
+ )
+import CgUsages ( getSpBRelOffset )
+
+import AbsCSyn ( RegRelative )
+import CgMonad ( FCode(..) )
+import ClosureInfo ( LambdaFormInfo )
+import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) )
+import Id ( IdEnv(..), Id(..) )
+
+type CgBindings = IdEnv CgIdInfo
+
+data CgIdInfo
+ = MkCgIdInfo Id -- Id that this is the info for
+ VolatileLoc
+ StableLoc
+ LambdaFormInfo
+
+data VolatileLoc
+data StableLoc
+data LambdaFormInfo
+
+nukeVolatileBinds :: CgBindings -> CgBindings
+maybeAStkLoc :: StableLoc -> Maybe VirtualSpAOffset
+maybeBStkLoc :: StableLoc -> Maybe VirtualSpBOffset
+
+getSpBRelOffset :: VirtualSpBOffset -> FCode RegRelative
+\end{code}
diff --git a/ghc/compiler/codeGen/CgLoop2.lhi b/ghc/compiler/codeGen/CgLoop2.lhi
new file mode 100644
index 0000000000..feda847f2c
--- /dev/null
+++ b/ghc/compiler/codeGen/CgLoop2.lhi
@@ -0,0 +1,15 @@
+Break loops caused by cgExpr and getPrimOpArgAmodes.
+\begin{code}
+interface CgLoop2 where
+
+import CgExpr ( cgExpr, cgSccExpr, getPrimOpArgAmodes )
+
+import AbsCSyn ( CAddrMode )
+import CgMonad ( Code(..), FCode(..) )
+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/CgMonad.lhs b/ghc/compiler/codeGen/CgMonad.lhs
index 65c4217917..428d6f6881 100644
--- a/ghc/compiler/codeGen/CgMonad.lhs
+++ b/ghc/compiler/codeGen/CgMonad.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgMonad]{The code generation monad}
@@ -34,8 +34,6 @@ module CgMonad (
-- addFreeASlots, -- no need to export it
addFreeBSlots, -- ToDo: Belong elsewhere
- isSwitchSetC, isStringSwitchSetC, getIntSwitchChkrC,
-
noBlackHolingFlag,
profCtrC,
@@ -45,31 +43,35 @@ module CgMonad (
sequelToAmode,
-- out of general friendliness, we also export ...
- CgBindings(..),
CgInfoDownwards(..), CgState(..), -- non-abstract
- CgIdInfo, -- abstract
- CompilationInfo(..), IntSwitchChecker(..),
-
- stableAmodeIdInfo, heapIdInfo
-
- -- and to make the interface self-sufficient...
+ CompilationInfo(..)
) where
+import Ubiq{-uitous-}
+import CgLoop1 -- stuff from CgBindery and CgUsages
+
import AbsCSyn
-import Type ( primRepFromType, Type
- IF_ATTACK_PRAGMAS(COMMA cmpUniType)
+import AbsCUtils ( mkAbsCStmts )
+import CmdLineOpts ( opt_SccProfilingOn, opt_DoTickyProfiling,
+ opt_OmitBlackHoling
+ )
+import HeapOffs ( maxOff,
+ VirtualSpAOffset(..), VirtualSpBOffset(..)
+ )
+import Id ( idType,
+ nullIdEnv, mkIdEnv, addOneToIdEnv,
+ modifyIdEnv, lookupIdEnv, rngIdEnv, IdEnv(..),
+ ConTag(..), GenId{-instance Outputable-}
)
-import CgBindery
-import CgUsages ( getSpBRelOffset )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( idType, ConTag(..), DataCon(..) )
-import Maybes ( catMaybes, maybeToBool, Maybe(..) )
-import Pretty -- debugging only?
-import PrimRep ( getPrimRepSize, retPrimRepSize )
-import UniqSet -- ( elementOfUniqSet, UniqSet(..) )
-import CostCentre -- profiling stuff
-import StgSyn ( StgArg(..), StgLiveVars(..) )
-import Util
+import Maybes ( maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import Pretty ( ppAboves, ppCat, ppStr )
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import StgSyn ( StgLiveVars(..) )
+import Type ( typePrimRep )
+import UniqSet ( elementOfUniqSet )
+import Util ( sortLt, panic, pprPanic )
infixr 9 `thenC` -- Right-associative!
infixr 9 `thenFC`
@@ -108,43 +110,42 @@ data CgState
CgStksAndHeapUsage
\end{code}
-@EndOfBlockInfo@ tells what to do at the end of this block of code
-or, if the expression is a @case@, what to do at the end of each alternative.
+@EndOfBlockInfo@ tells what to do at the end of this block of code or,
+if the expression is a @case@, what to do at the end of each
+alternative.
\begin{code}
data EndOfBlockInfo
= EndOfBlockInfo
- VirtualSpAOffset -- Args SpA: trim the A stack to this point at a return;
- -- push arguments starting just above this point on
- -- a tail call.
-
- -- This is therefore the A-stk ptr as seen
- -- by a case alternative.
-
- -- Args SpA is used when we want to stub any
- -- currently-unstubbed dead A-stack (ptr) slots;
- -- we want to know what SpA in the continuation is
- -- so that we don't stub any slots which are off the
- -- top of the continuation's stack!
-
- VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
-
- -- Two main differences:
- -- 1. If Sequel isn't OnStack, then Args SpB points
- -- just below the slot in which the return address
- -- should be put. In effect, the Sequel is
- -- a pending argument. If it is OnStack, Args SpB
- -- points to the top word of the return address.
- --
- -- 2. It ain't used for stubbing because there are
- -- no ptrs on B stk.
-
+ VirtualSpAOffset -- Args SpA: trim the A stack to this point at a
+ -- return; push arguments starting just
+ -- above this point on a tail call.
+
+ -- This is therefore the A-stk ptr as seen
+ -- by a case alternative.
+
+ -- Args SpA is used when we want to stub any
+ -- currently-unstubbed dead A-stack (ptr)
+ -- slots; we want to know what SpA in the
+ -- continuation is so that we don't stub any
+ -- slots which are off the top of the
+ -- continuation's stack!
+
+ VirtualSpBOffset -- Args SpB: Very similar to Args SpA.
+ -- Two main differences:
+ -- 1. If Sequel isn't OnStack, then Args SpB points
+ -- just below the slot in which the return address
+ -- should be put. In effect, the Sequel
+ -- is a pending argument. If it is
+ -- OnStack, Args SpB
+ -- points to the top word of the return
+ -- address.
+ --
+ -- 2. It ain't used for stubbing because there are
+ -- no ptrs on B stk.
Sequel
-
initEobInfo = EndOfBlockInfo 0 0 InRetReg
-
-
\end{code}
Any addressing modes inside @Sequel@ must be ``robust,'' in the sense
@@ -153,21 +154,21 @@ block.
\begin{code}
data Sequel
- = InRetReg -- The continuation is in RetReg
-
- | OnStack VirtualSpBOffset
- -- Continuation is on the stack, at the
- -- specified location
+ = InRetReg -- The continuation is in RetReg
- | UpdateCode CAddrMode -- May be standard update code, or might be
- -- the data-type-specific one.
+ | OnStack VirtualSpBOffset
+ -- Continuation is on the stack, at the
+ -- specified location
- | CaseAlts
- CAddrMode -- Jump to this; if the continuation is for a vectored
- -- case this might be the label of a return vector
- -- Guaranteed to be a non-volatile addressing mode (I think)
+ | UpdateCode CAddrMode -- May be standard update code, or might be
+ -- the data-type-specific one.
- SemiTaggingStuff
+ | CaseAlts
+ CAddrMode -- Jump to this; if the continuation is for a vectored
+ -- case this might be the label of a return
+ -- vector Guaranteed to be a non-volatile
+ -- addressing mode (I think)
+ SemiTaggingStuff
type SemiTaggingStuff
= Maybe -- Maybe[1] we don't have any semi-tagging stuff...
@@ -182,17 +183,17 @@ type SemiTaggingStuff
type JoinDetails
= (AbstractC, CLabel) -- Code to load regs from heap object + profiling macros,
-- and join point label
--- The abstract C is executed only from a successful
--- semitagging venture, when a case has looked at a variable, found
--- that it's evaluated, and wants to load up the contents and go to the
--- join point.
+-- The abstract C is executed only from a successful semitagging
+-- venture, when a case has looked at a variable, found that it's
+-- evaluated, and wants to load up the contents and go to the join
+-- point.
-- DIRE WARNING.
--- The OnStack case of sequelToAmode delivers an Amode which is only valid
--- just before the final control transfer, because it assumes that
--- SpB is pointing to the top word of the return address.
--- This seems unclean but there you go.
+-- The OnStack case of sequelToAmode delivers an Amode which is only
+-- valid just before the final control transfer, because it assumes
+-- that SpB is pointing to the top word of the return address. This
+-- seems unclean but there you go.
sequelToAmode :: Sequel -> FCode CAddrMode
@@ -576,17 +577,15 @@ nothing.
\begin{code}
costCentresC :: FAST_STRING -> [CAddrMode] -> Code
-costCentresC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
- state@(MkCgState absC binds usage)
- = if sw_chkr SccProfilingOn
+costCentresC macro args _ state@(MkCgState absC binds usage)
+ = if opt_SccProfilingOn
then MkCgState (mkAbsCStmts absC (CCallProfCCMacro macro args)) binds usage
else state
profCtrC :: FAST_STRING -> [CAddrMode] -> Code
-profCtrC macro args (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _)
- state@(MkCgState absC binds usage)
- = if not (sw_chkr DoTickyProfiling)
+profCtrC macro args _ state@(MkCgState absC binds usage)
+ = if not opt_DoTickyProfiling
then state
else MkCgState (mkAbsCStmts absC (CCallProfCtrMacro macro args)) binds usage
@@ -616,17 +615,14 @@ getAbsC code info_down (MkCgState absC binds usage)
\begin{code}
noBlackHolingFlag, costCentresFlag :: FCode Bool
-noBlackHolingFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr OmitBlackHoling, state)
-
-costCentresFlag (MkCgInfoDown (MkCompInfo sw_chkr _ _) _ _) state
- = (sw_chkr SccProfilingOn, state)
+noBlackHolingFlag _ state = (opt_OmitBlackHoling, state)
+costCentresFlag _ state = (opt_SccProfilingOn, state)
\end{code}
\begin{code}
moduleName :: FCode FAST_STRING
-moduleName (MkCgInfoDown (MkCompInfo _ _ mod_name) _ _) state
+moduleName (MkCgInfoDown (MkCompInfo mod_name) _ _) state
= (mod_name, state)
\end{code}
@@ -802,7 +798,7 @@ dead_slots live_vars fbs das dbs ((v,i):bs)
_ -> dead_slots live_vars fbs das dbs bs
where
size :: Int
- size = (getPrimRepSize . primRepFromType . idType) v
+ size = (getPrimRepSize . typePrimRep . idType) v
-- addFreeSlots expects *both* args to be in increasing order
addFreeASlots :: [(Int,StubFlag)] -> [(Int,StubFlag)] -> [(Int,StubFlag)]
diff --git a/ghc/compiler/codeGen/CgRetConv.lhs b/ghc/compiler/codeGen/CgRetConv.lhs
index 5881fb1f1e..f1a35f6ab0 100644
--- a/ghc/compiler/codeGen/CgRetConv.lhs
+++ b/ghc/compiler/codeGen/CgRetConv.lhs
@@ -15,8 +15,6 @@ module CgRetConv (
ctrlReturnConvAlg,
dataReturnConvAlg,
- mkLiveRegsBitMask, noLiveRegsMask,
-
dataReturnConvPrim,
assignPrimOpResultRegs,
@@ -26,27 +24,35 @@ module CgRetConv (
-- and to make the interface self-sufficient...
) where
-import AbsCSyn
+import Ubiq{-uitous-}
+import AbsCLoop -- paranoia checking
-import PrelInfo ( PrimOp(..), PrimOpResultInfo(..), primOpCanTriggerGC,
- getPrimOpResultInfo, integerDataCon
- IF_ATTACK_PRAGMAS(COMMA tagOf_PrimOp)
- IF_ATTACK_PRAGMAS(COMMA pprPrimOp)
+import AbsCSyn -- quite a few things
+import AbsCUtils ( mkAbstractCs, getAmodeRep,
+ amodeCanSurviveGC
+ )
+import CgCompInfo ( mAX_FAMILY_SIZE_FOR_VEC_RETURNS,
+ mAX_Vanilla_REG, mAX_Float_REG,
+ mAX_Double_REG
+ )
+import CmdLineOpts ( opt_ReturnInRegsThreshold )
+import Id ( isDataCon, dataConSig,
+ DataCon(..), GenId{-instance Eq-}
)
-import Type ( getTyConFamilySize, primRepFromType, getTyConDataCons,
- TyVarTemplate, TyCon, Class,
- TauType(..), ThetaType(..), Type
+import Maybes ( catMaybes )
+import PprStyle ( PprStyle(..) )
+import PprType ( TyCon{-instance Outputable-} )
+import PrelInfo ( integerDataCon )
+import PrimOp ( primOpCanTriggerGC,
+ getPrimOpResultInfo, PrimOpResultInfo(..),
+ PrimOp{-instance Outputable-}
)
-import CgCompInfo -- various things
-import CgMonad ( IntSwitchChecker(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( Id, getDataConSig, fIRST_TAG, isDataCon,
- DataCon(..), ConTag(..)
+import PrimRep ( isFloatingRep, PrimRep(..) )
+import TyCon ( tyConDataCons, tyConFamilySize )
+import Type ( typePrimRep )
+import Util ( zipWithEqual, mapAccumL, isn'tIn,
+ pprError, pprTrace, panic, assertPanic
)
-import Maybes ( catMaybes, Maybe(..) )
-import PrimRep
-import Util
-import Pretty
\end{code}
%************************************************************************
@@ -88,11 +94,11 @@ The register assignment given by a @ReturnInRegs@ obeys three rules:
ctrlReturnConvAlg :: TyCon -> CtrlReturnConvention
ctrlReturnConvAlg tycon
- = case (getTyConFamilySize tycon) of
- Nothing -> -- pprPanic "ctrlReturnConvAlg:" (ppr PprDebug tycon)
- UnvectoredReturn 0 -- e.g., w/ "data Bin"
+ = case (tyConFamilySize tycon) of
+ 0 -> pprTrace "ctrlReturnConvAlg:" (ppr PprDebug tycon) $
+ UnvectoredReturn 0 -- e.g., w/ "data Bin"
- Just size -> -- we're supposed to know...
+ size -> -- we're supposed to know...
if (size > (1::Int) && size <= mAX_FAMILY_SIZE_FOR_VEC_RETURNS) then
VectoredReturn size
else
@@ -110,68 +116,23 @@ types. If @assign_reg@ runs out of a particular kind of register,
then it gives up, returning @ReturnInHeap@.
\begin{code}
-dataReturnConvAlg :: IntSwitchChecker -> DataCon -> DataReturnConvention
+dataReturnConvAlg :: DataCon -> DataReturnConvention
-dataReturnConvAlg isw_chkr data_con
+dataReturnConvAlg data_con
= ASSERT(isDataCon data_con)
case leftover_kinds of
[] -> ReturnInRegs reg_assignment
other -> ReturnInHeap -- Didn't fit in registers
where
- (_, _, arg_tys, _) = getDataConSig data_con
+ (_, _, arg_tys, _) = dataConSig data_con
(reg_assignment, leftover_kinds)
- = assignRegs isw_chkr_to_use
- [node, infoptr] -- taken...
- (map primRepFromType arg_tys)
-
- isw_chkr_to_use = isw_chkr
+ = assignRegs [node, infoptr] -- taken...
+ (map typePrimRep arg_tys)
is_prim_result_ty = data_con == integerDataCon -- ***HACK***! (WDP 95/11)
\end{code}
-\begin{code}
-noLiveRegsMask :: Int -- Mask indicating nothing live
-noLiveRegsMask = 0
-
-mkLiveRegsBitMask
- :: [MagicId] -- Candidate live regs; depends what they have in them
- -> Int
-
-mkLiveRegsBitMask regs
- = foldl do_reg noLiveRegsMask regs
- where
- do_reg acc (VanillaReg kind reg_no)
- | isFollowableRep kind
- = acc + (reg_tbl !! IBOX(reg_no _SUB_ ILIT(1)))
-
- do_reg acc anything_else = acc
-
- reg_tbl -- ToDo: mk Array!
- = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
- lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
-
-{-
--- Completely opaque code. ADR
--- What's wrong with: (untested)
-
-mkLiveRegsBitMask regs
- = foldl (+) noLiveRegsMask (map liveness_bit regs)
- where
- liveness_bit (VanillaReg kind reg_no)
- | isFollowableRep kind
- = reg_tbl !! (reg_no - 1)
-
- liveness_bit anything_else
- = noLiveRegsBitMask
-
- reg_tbl
- = [lIVENESS_R1, lIVENESS_R2, lIVENESS_R3, lIVENESS_R4,
- lIVENESS_R5, lIVENESS_R6, lIVENESS_R7, lIVENESS_R8]
--}
-\end{code}
-
-
%************************************************************************
%* *
\subsection[CgRetConv-prim]{Return conventions for primitive datatypes}
@@ -224,7 +185,7 @@ assignPrimOpResultRegs op
ReturnsAlg tycon
-> let
- cons = getTyConDataCons tycon
+ cons = tyConDataCons tycon
result_regs = concat (map get_return_regs cons)
in
-- As R1 is dead, it can hold the tag if necessary
@@ -233,12 +194,9 @@ assignPrimOpResultRegs op
other -> (VanillaReg IntRep ILIT(1)) : result_regs
where
get_return_regs con
- = case (dataReturnConvAlg fake_isw_chkr con) of
+ = case (dataReturnConvAlg con) of
ReturnInRegs regs -> regs
ReturnInHeap -> panic "getPrimOpAlgResultRegs"
-
- fake_isw_chkr :: IntSwitchChecker
- fake_isw_chkr x = Nothing
\end{code}
@assignPrimOpArgsRobust@ is used only for primitive ops which may
@@ -269,12 +227,12 @@ makePrimOpArgsRobust op arg_amodes
arg_kinds = map getAmodeRep non_robust_amodes
(arg_regs, extra_args)
- = assignRegs fake_isw_chkr [{-nothing live-}] arg_kinds
+ = assignRegs [{-nothing live-}] arg_kinds
-- Check that all the args fit before returning arg_regs
final_arg_regs = case extra_args of
[] -> arg_regs
- other -> error ("Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?) " ++ ppShow 80 (ppr PprDebug op))
+ other -> pprError "Cannot allocate enough registers for primop (try rearranging code or reducing number of arguments?)" (ppr PprDebug op)
arg_assts
= mkAbstractCs (zipWithEqual assign_to_reg final_arg_regs non_robust_amodes)
@@ -286,12 +244,9 @@ makePrimOpArgsRobust op arg_amodes
| otherwise = (tail regs, CReg (head regs))
safe_amodes = snd (mapAccumL safe_arg final_arg_regs arg_amodes)
- liveness_mask = mkLiveRegsBitMask final_arg_regs
+ liveness_mask = mkLiveRegsMask final_arg_regs
in
(safe_amodes, liveness_mask, arg_assts)
- where
- fake_isw_chkr :: IntSwitchChecker
- fake_isw_chkr x = Nothing
\end{code}
%************************************************************************
@@ -308,15 +263,14 @@ any further registers (even though we might have run out of only one kind of
register); we just return immediately with the left-overs specified.
\begin{code}
-assignRegs :: IntSwitchChecker
- -> [MagicId] -- Unavailable registers
+assignRegs :: [MagicId] -- Unavailable registers
-> [PrimRep] -- Arg or result kinds to assign
-> ([MagicId], -- Register assignment in same order
-- for *initial segment of* input list
[PrimRep])-- leftover kinds
-assignRegs isw_chkr regs_in_use kinds
- = assign_reg kinds [] (mkRegTbl isw_chkr regs_in_use)
+assignRegs regs_in_use kinds
+ = assign_reg kinds [] (mkRegTbl regs_in_use)
where
assign_reg :: [PrimRep] -- arg kinds being scrutinized
@@ -360,9 +314,9 @@ floatRegNos, doubleRegNos :: [Int]
floatRegNos = [1 .. mAX_Float_REG]
doubleRegNos = [1 .. mAX_Double_REG]
-mkRegTbl :: IntSwitchChecker -> [MagicId] -> ([Int], [Int], [Int])
+mkRegTbl :: [MagicId] -> ([Int], [Int], [Int])
-mkRegTbl isw_chkr regs_in_use
+mkRegTbl regs_in_use
= (ok_vanilla, ok_float, ok_double)
where
ok_vanilla = catMaybes (map (select (VanillaReg VoidRep)) (taker vanillaRegNos))
@@ -371,7 +325,7 @@ mkRegTbl isw_chkr regs_in_use
taker :: [Int] -> [Int]
taker rs
- = case (isw_chkr ReturnInRegsThreshold) of
+ = case (opt_ReturnInRegsThreshold) of
Nothing -> rs -- no flag set; use all of them
Just n -> take n rs
diff --git a/ghc/compiler/codeGen/CgStackery.lhs b/ghc/compiler/codeGen/CgStackery.lhs
index 3759aa41e4..0ad6fc52fb 100644
--- a/ghc/compiler/codeGen/CgStackery.lhs
+++ b/ghc/compiler/codeGen/CgStackery.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgStackery]{Stack management functions}
@@ -13,18 +13,19 @@ module CgStackery (
allocAStack, allocBStack, allocUpdateFrame,
adjustRealSps, getFinalStackHW,
mkVirtStkOffsets, mkStkAmodes
-
- -- and to make the interface self-sufficient...
) where
-import StgSyn
+import Ubiq{-uitous-}
+
import CgMonad
import AbsCSyn
-import CgUsages ( getSpBRelOffset )
-import Maybes ( Maybe(..) )
-import PrimRep ( getPrimRepSize, retPrimRepSize, separateByPtrFollowness )
-import Util
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import HeapOffs ( VirtualSpAOffset(..), VirtualSpBOffset(..) )
+import PrimRep ( getPrimRepSize, separateByPtrFollowness,
+ PrimRep(..)
+ )
+import Util ( mapAccumR, panic )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/CgTailCall.lhs b/ghc/compiler/codeGen/CgTailCall.lhs
index a22ca46a2a..560adde93b 100644
--- a/ghc/compiler/codeGen/CgTailCall.lhs
+++ b/ghc/compiler/codeGen/CgTailCall.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
%********************************************************
%* *
@@ -17,37 +17,36 @@ module CgTailCall (
mkPrimReturnCode,
tailCallBusiness
-
- -- and to make the interface self-sufficient...
) where
-IMPORT_Trace
-import Pretty -- Pretty/Outputable: rm (debugging only) ToDo
-import Outputable
+import Ubiq{-uitous-}
-import StgSyn
import CgMonad
import AbsCSyn
-import Type ( isPrimType, Type )
-import CgBindery ( getAtomAmodes, getCAddrMode, getCAddrModeAndInfo )
-import CgCompInfo ( oTHER_TAG, iND_TAG )
-import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg, dataReturnConvAlg,
- mkLiveRegsBitMask,
- CtrlReturnConvention(..), DataReturnConvention(..)
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, getAmodeRep )
+import CgBindery ( getArgAmodes, getCAddrMode, getCAddrModeAndInfo )
+import CgRetConv ( dataReturnConvPrim, dataReturnConvAlg,
+ ctrlReturnConvAlg, CtrlReturnConvention(..),
+ DataReturnConvention(..)
)
import CgStackery ( adjustRealSps, mkStkAmodes )
-import CgUsages ( getSpARelOffset, getSpBRelOffset )
-import CLabel ( CLabel, mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
-import ClosureInfo ( nodeMustPointToIt, getEntryConvention, EntryConvention(..) )
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id ( getDataConTyCon, getDataConTag,
- idType, getIdPrimRep, fIRST_TAG, Id,
- ConTag(..)
+import CgUsages ( getSpARelOffset )
+import CLabel ( mkStdUpdCodePtrVecLabel, mkConUpdCodePtrVecLabel )
+import ClosureInfo ( nodeMustPointToIt,
+ getEntryConvention, EntryConvention(..)
+ )
+import CmdLineOpts ( opt_EmitArityChecks, opt_DoSemiTagging )
+import HeapOffs ( zeroOff, VirtualSpAOffset(..) )
+import Id ( idType, dataConTyCon, dataConTag,
+ fIRST_TAG
)
-import Maybes ( assocMaybe, maybeToBool, Maybe(..) )
-import PrimRep ( retPrimRepSize )
-import Util
+import Literal ( mkMachInt )
+import Maybes ( assocMaybe )
+import PrimRep ( PrimRep(..) )
+import StgSyn ( StgArg(..), GenStgArg(..), StgLiveVars(..) )
+import Type ( isPrimType )
+import Util ( zipWithEqual, panic, assertPanic )
\end{code}
%************************************************************************
@@ -191,8 +190,7 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel
-- Set the info pointer, and jump
set_info_ptr `thenC`
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
- absC (CJump (CLbl (update_label isw_chkr) CodePtrRep))
+ absC (CJump (CLbl update_label CodePtrRep))
CaseAlts _ (Just (alts, _)) -> -- Ho! We know the constructor so
-- we can go right to the alternative
@@ -216,14 +214,14 @@ mkStaticAlgReturnCode con maybe_info_lbl sequel
)
where
- tag = getDataConTag con
- tycon = getDataConTyCon con
+ tag = dataConTag con
+ tycon = dataConTyCon con
return_convention = ctrlReturnConvAlg tycon
zero_indexed_tag = tag - fIRST_TAG -- Adjust tag to be zero-indexed
-- cf AbsCUtils.mkAlgAltsCSwitch
- update_label isw_chkr
- = case (dataReturnConvAlg isw_chkr con) of
+ update_label
+ = case (dataReturnConvAlg con) of
ReturnInHeap -> mkStdUpdCodePtrVecLabel tycon tag
ReturnInRegs _ -> mkConUpdCodePtrVecLabel tycon tag
@@ -296,7 +294,7 @@ performTailCall fun args live_vars
= -- Get all the info we have about the function and args and go on to
-- the business end
getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
- getAtomAmodes args `thenFC` \ arg_amodes ->
+ getArgAmodes args `thenFC` \ arg_amodes ->
tailCallBusiness
fun fun_amode lf_info arg_amodes
@@ -316,8 +314,9 @@ tailCallBusiness :: Id -> CAddrMode -- Function and its amode
-> Code
tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
- = isSwitchSetC EmitArityChecks `thenFC` \ do_arity_chks ->
-
+ = let
+ do_arity_chks = opt_EmitArityChecks
+ in
nodeMustPointToIt lf_info `thenFC` \ node_points ->
getEntryConvention fun lf_info
(map getAmodeRep arg_amodes) `thenFC` \ entry_conv ->
@@ -407,7 +406,9 @@ tailCallBusiness fun fun_amode lf_info arg_amodes live_vars pending_assts
adjustRealSps final_spa final_spb `thenC`
-- Now decide about semi-tagging
- isSwitchSetC DoSemiTagging `thenFC` \ semi_tagging_on ->
+ let
+ semi_tagging_on = opt_DoSemiTagging
+ in
case (semi_tagging_on, arg_amodes, node_points, sequel) of
--
diff --git a/ghc/compiler/codeGen/CgUpdate.lhs b/ghc/compiler/codeGen/CgUpdate.lhs
index 92ceaa474c..ff1a5546b9 100644
--- a/ghc/compiler/codeGen/CgUpdate.lhs
+++ b/ghc/compiler/codeGen/CgUpdate.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1994
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CgUpdate]{Manipulating update frames}
@@ -8,18 +8,15 @@
module CgUpdate ( pushUpdateFrame ) where
-import StgSyn
+import Ubiq{-uitous-}
+
import CgMonad
import AbsCSyn
-import CgCompInfo ( sTD_UF_SIZE, cON_UF_SIZE,
- sCC_STD_UF_SIZE, sCC_CON_UF_SIZE,
- spARelToInt, spBRelToInt
- )
+import CgCompInfo ( sTD_UF_SIZE, sCC_STD_UF_SIZE )
import CgStackery ( allocUpdateFrame )
-import CgUsages
-import CmdLineOpts ( GlobalSwitch(..) )
-import Util
+import CmdLineOpts ( opt_SccProfilingOn )
+import Util ( assertPanic )
\end{code}
@@ -41,8 +38,9 @@ to reflect the frame pushed.
pushUpdateFrame :: CAddrMode -> CAddrMode -> Code -> Code
pushUpdateFrame updatee vector code
- = isSwitchSetC SccProfilingOn `thenFC` \ profiling_on ->
- let
+ = let
+ profiling_on = opt_SccProfilingOn
+
-- frame_size *includes* the return address
frame_size = if profiling_on
then sCC_STD_UF_SIZE
diff --git a/ghc/compiler/codeGen/CgUsages.lhs b/ghc/compiler/codeGen/CgUsages.lhs
index 2e3fec3c06..eec6be6067 100644
--- a/ghc/compiler/codeGen/CgUsages.lhs
+++ b/ghc/compiler/codeGen/CgUsages.lhs
@@ -15,15 +15,20 @@ module CgUsages (
getHpRelOffset, getSpARelOffset, getSpBRelOffset,
- freeBStkSlot,
-
- -- and to make the interface self-sufficient...
- AbstractC, HeapOffset, RegRelative, CgState
+ freeBStkSlot
) where
-import AbsCSyn
+import Ubiq{-uitous-}
+import CgLoop1 -- here for paranoia-checking
+
+import AbsCSyn ( RegRelative(..), AbstractC, CAddrMode )
import CgMonad
-import Util
+import HeapOffs ( zeroOff,
+ VirtualHeapOffset(..),
+ VirtualSpAOffset(..),
+ VirtualSpBOffset(..)
+ )
+import Id ( IdEnv(..) )
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index dddeddf471..ae3bc5cd04 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -1,5 +1,5 @@
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[ClosureInfo]{Data structures which describe closures}
@@ -43,35 +43,61 @@ module ClosureInfo (
closureKind, closureTypeDescr, -- profiling
- isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps?
isStaticClosure, allocProfilingMsg,
blackHoleClosureInfo,
- getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr,
maybeSelectorInfo,
dataConLiveness -- concurrency
-
- -- and to make the interface self-sufficient...
) where
+import Ubiq{-uitous-}
+import AbsCLoop -- here for paranoia-checking
+
import AbsCSyn
-import CgMonad
-import SMRep
import StgSyn
+import CgMonad
-import Type
-import CgCompInfo -- some magic constants
-import CgRetConv
-import CLabel -- Lots of label-making things
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id
-import IdInfo -- SIGH
-import Maybes ( maybeToBool, assocMaybe, Maybe(..) )
-import Outputable -- needed for INCLUDE_FRC_METHOD
-import Pretty -- ( ppStr, Pretty(..) )
-import PrimRep ( PrimRep, getPrimRepSize, separateByPtrFollowness )
-import Util
+import CgCompInfo ( mAX_SPEC_SELECTEE_SIZE,
+ mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
+ mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
+ mAX_SPEC_ALL_NONPTRS,
+ oTHER_TAG
+ )
+import CgRetConv ( assignRegs, dataReturnConvAlg,
+ DataReturnConvention(..)
+ )
+import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
+ mkPhantomInfoTableLabel, mkInfoTableLabel,
+ mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
+ mkStaticInfoTableLabel, mkStaticConEntryLabel,
+ mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
+ )
+import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent )
+import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
+ intOffsetIntoGoods,
+ VirtualHeapOffset(..)
+ )
+import Id ( idType, idPrimRep, getIdArity,
+ externallyVisibleId, dataConSig,
+ dataConTag, fIRST_TAG,
+ isDataCon, dataConArity, dataConTyCon,
+ isTupleCon, DataCon(..),
+ GenId{-instance Eq-}
+ )
+import IdInfo ( arityMaybe )
+import Maybes ( assocMaybe, maybeToBool )
+import PprStyle ( PprStyle(..) )
+import PprType ( GenType{-instance Outputable-} )
+import PrimRep ( getPrimRepSize, separateByPtrFollowness )
+import SMRep -- all of it
+import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
+import Type ( isPrimType, splitForAllTy, splitFunTy, mkFunTys )
+import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
+
+maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)"
+maybeIntLikeTyCon = panic "ClosureInfo.maybeIntLikeTyCon (ToDo)"
+getDataSpecTyCon_maybe = panic "ClosureInfo.getDataSpecTyCon_maybe (ToDo)"
+getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
\end{code}
The ``wrapper'' data type for closure information:
@@ -392,13 +418,13 @@ mkClosureLFInfo False -- don't bother if at top-level
-- ASSERT(is_single_constructor) -- Should be true, by causes error for SpecTyCon
LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
where
- (_, params_w_offsets) = layOutDynCon con getIdPrimRep params
+ (_, params_w_offsets) = layOutDynCon con idPrimRep params
maybe_offset = assocMaybe params_w_offsets selectee
Just the_offset = maybe_offset
offset_into_int_maybe = intOffsetIntoGoods the_offset
Just offset_into_int = offset_into_int_maybe
- is_single_constructor = maybeToBool (maybeSingleConstructorTyCon tycon)
- (_,_,_, tycon) = getDataConSig con
+ is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
+ (_,_,_, tycon) = dataConSig con
\end{code}
Same kind of thing, looking for vector-apply thunks, of the form:
@@ -452,7 +478,7 @@ mkConLFInfo :: DataCon -> LambdaFormInfo
mkConLFInfo con
= ASSERT(isDataCon con)
let
- arity = getDataConArity con
+ arity = dataConArity con
in
if isTupleCon con then
LFTuple con (arity == 0)
@@ -691,7 +717,7 @@ chooseDynSMRep lf_info tot_wds ptr_wds
else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep
else SpecRep
where
- tycon = getDataConTyCon con
+ tycon = dataConTyCon con
_ -> SpecRep
in
@@ -712,14 +738,15 @@ smaller offsets than the unboxed things, and furthermore, the offsets in
the result list
\begin{code}
-mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
+mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
-> (a -> PrimRep) -- To be able to grab kinds;
- -- w/ a kind, we can find boxedness
- -> [a] -- Things to make offsets for
- -> (Int, -- *Total* number of words allocated
- Int, -- Number of words allocated for *pointers*
- [(a, VirtualHeapOffset)]) -- Things with their offsets from start of object
- -- in order of increasing offset
+ -- w/ a kind, we can find boxedness
+ -> [a] -- Things to make offsets for
+ -> (Int, -- *Total* number of words allocated
+ Int, -- Number of words allocated for *pointers*
+ [(a, VirtualHeapOffset)])
+ -- Things with their offsets from start of object
+ -- in order of increasing offset
-- First in list gets lowest offset, which is initial offset + 1.
@@ -748,8 +775,9 @@ Be sure to see the stg-details notes about these...
\begin{code}
nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
nodeMustPointToIt lf_info
- = isSwitchSetC SccProfilingOn `thenFC` \ do_profiling ->
-
+ = let
+ do_profiling = opt_SccProfilingOn
+ in
case lf_info of
LFReEntrant top arity no_fvs -> returnFC (
not no_fvs || -- Certainly if it has fvs we need to point to it
@@ -843,8 +871,9 @@ getEntryConvention :: Id -- Function being applied
getEntryConvention id lf_info arg_kinds
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
+ let
+ is_concurrent = opt_ForConcurrent
+ in
returnFC (
if (node_points && is_concurrent) then ViaNode else
@@ -857,7 +886,7 @@ getEntryConvention id lf_info arg_kinds
else
DirectEntry (mkFastEntryLabel id arity) arity arg_regs
where
- (arg_regs, _) = assignRegs isw_chkr live_regs (take arity arg_kinds)
+ (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
live_regs = if node_points then [node] else []
LFCon con zero_arity
@@ -887,7 +916,7 @@ getEntryConvention id lf_info arg_kinds
-> ASSERT(arity == length arg_kinds)
DirectEntry (mkStdEntryLabel id) arity arg_regs
where
- (arg_regs, _) = assignRegs isw_chkr live_regs arg_kinds
+ (arg_regs, _) = assignRegs live_regs arg_kinds
live_regs = if node_points then [node] else []
)
@@ -1067,21 +1096,6 @@ noUpdVapRequired binder_info
%************************************************************************
\begin{code}
-isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool
-isConstantRep (SpecialisedRep ConstantRep _ _ _) = True
-isConstantRep other = False
-
-isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures
-isSpecRep other = False -- True indicates that the _VHS is 0 !
-
-isStaticRep (StaticRep _ _) = True
-isStaticRep _ = False
-
-isPhantomRep PhantomRep = True
-isPhantomRep _ = False
-
-isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True
-isIntLikeRep other = False
isStaticClosure :: ClosureInfo -> Bool
isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep
@@ -1121,11 +1135,9 @@ closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
-- rather than take it from the Id. The Id is probably just "f"!
closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
- = getUniDataSpecTyCon_maybe (funResultTy de_foralld_ty (length args))
- where
- (_, de_foralld_ty) = splitForalls (idType fun_id)
+ = getDataSpecTyCon_maybe (fun_result_ty (length args) fun_id)
-closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (idType id)
+closureType (MkClosureInfo id lf _) = getDataSpecTyCon_maybe (idType id)
\end{code}
@closureReturnsUnboxedType@ is used to check whether a closure, {\em
@@ -1140,13 +1152,20 @@ overflow checks.
closureReturnsUnboxedType :: ClosureInfo -> Bool
closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
- = isPrimType (funResultTy de_foralld_ty arity)
- where
- (_, de_foralld_ty) = splitForalls (idType fun_id)
+ = isPrimType (fun_result_ty arity fun_id)
closureReturnsUnboxedType other_closure = False
-- All non-function closures aren't functions,
-- and hence are boxed, since they are heap alloc'd
+
+-- ToDo: need anything like this in Type.lhs?
+fun_result_ty arity id
+ = let
+ (_, de_foralld_ty) = splitForAllTy (idType id)
+ (arg_tys, res_ty) = splitFunTy{-w/ dicts as args?-} de_foralld_ty
+ in
+ ASSERT(arity >= 0 && length arg_tys >= arity)
+ mkFunTys (drop arity arg_tys) res_ty
\end{code}
\begin{code}
@@ -1154,7 +1173,7 @@ closureSemiTag :: ClosureInfo -> Int
closureSemiTag (MkClosureInfo _ lf_info _)
= case lf_info of
- LFCon data_con _ -> getDataConTag data_con - fIRST_TAG
+ LFCon data_con _ -> dataConTag data_con - fIRST_TAG
LFTuple _ _ -> 0
_ -> fromInteger oTHER_TAG
\end{code}
@@ -1248,26 +1267,26 @@ allocProfilingMsg (MkClosureInfo _ lf_info _)
LFImported -> panic "ALLOC_IMP"
\end{code}
-We need a black-hole closure info to pass to @allocDynClosure@
-when we want to allocate the black hole on entry to a CAF.
+We need a black-hole closure info to pass to @allocDynClosure@ when we
+want to allocate the black hole on entry to a CAF.
\begin{code}
-blackHoleClosureInfo (MkClosureInfo id _ _) = MkClosureInfo id LFBlackHole BlackHoleRep
+blackHoleClosureInfo (MkClosureInfo id _ _)
+ = MkClosureInfo id LFBlackHole BlackHoleRep
\end{code}
-The register liveness when returning from a constructor. For simplicity,
-we claim just [node] is live for all but PhantomRep's. In truth, this means
-that non-constructor info tables also claim node, but since their liveness
-information is never used, we don't care.
+The register liveness when returning from a constructor. For
+simplicity, we claim just [node] is live for all but PhantomRep's. In
+truth, this means that non-constructor info tables also claim node,
+but since their liveness information is never used, we don't care.
\begin{code}
-
-dataConLiveness isw_chkr (MkClosureInfo con _ PhantomRep)
- = case (dataReturnConvAlg isw_chkr con) of
- ReturnInRegs regs -> mkLiveRegsBitMask regs
+dataConLiveness (MkClosureInfo con _ PhantomRep)
+ = case (dataReturnConvAlg con) of
+ ReturnInRegs regs -> mkLiveRegsMask regs
ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
-dataConLiveness _ _ = mkLiveRegsBitMask [node]
+dataConLiveness _ = mkLiveRegsMask [node]
\end{code}
%************************************************************************
@@ -1303,8 +1322,7 @@ closureKind (MkClosureInfo _ lf _)
closureTypeDescr :: ClosureInfo -> String
closureTypeDescr (MkClosureInfo id lf _)
= if (isDataCon id) then -- DataCon has function types
- _UNPK_ (getOccurrenceName (getDataConTyCon id)) -- We want the TyCon not the ->
+ _UNPK_ (getOccurrenceName (dataConTyCon id)) -- We want the TyCon not the ->
else
- getUniTyDescription (idType id)
+ getTyDescription (idType id)
\end{code}
-
diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs
index d8112a8bd2..2b193da6e5 100644
--- a/ghc/compiler/codeGen/CodeGen.lhs
+++ b/ghc/compiler/codeGen/CodeGen.lhs
@@ -1,5 +1,5 @@
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CodeGen]{@CodeGen@: main module of the code generator}
@@ -19,28 +19,32 @@ functions drive the mangling of top-level bindings.
module CodeGen ( codeGen ) where
+import Ubiq{-uitous-}
+
import StgSyn
import CgMonad
import AbsCSyn
-import CLabel ( modnameToC )
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts )
+import Bag ( foldBag )
import CgClosure ( cgTopRhsClosure )
import CgCon ( cgTopRhsCon )
-import CgConTbls ( genStaticConBits, TCE(..), UniqFM )
-import ClosureInfo ( LambdaFormInfo, mkClosureLFInfo )
-import CmdLineOpts
-import FiniteMap ( FiniteMap )
-import Maybes ( Maybe(..) )
-import Pretty -- debugging only
-import PrimRep ( getPrimRepSize )
-import Util
+import CgConTbls ( genStaticConBits )
+import ClosureInfo ( mkClosureLFInfo )
+import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude,
+ opt_EnsureSplittableC, opt_SccGroup
+ )
+import CStrings ( modnameToC )
+import Maybes ( maybeToBool )
+import PrimRep ( getPrimRepSize, PrimRep(..) )
+import Util ( panic, assertPanic )
\end{code}
\begin{code}
codeGen :: FAST_STRING -- module name
-> ([CostCentre], -- local cost-centres needing declaring/registering
[CostCentre]) -- "extern" cost-centres needing declaring
- -> [FAST_STRING] -- import names
+ -> Bag FAST_STRING -- import names
-> [TyCon] -- tycons with data constructors to convert
-> FiniteMap TyCon [(Bool, [Maybe Type])]
-- tycon specialisation info
@@ -51,11 +55,11 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg
= let
doing_profiling = opt_SccProfilingOn
compiling_prelude = opt_CompilingPrelude
- maybe_split = if (switch_is_on (EnsureSplittableC (panic "codeGen:esc")))
+ maybe_split = if maybeToBool (opt_EnsureSplittableC)
then CSplitMarker
else AbsCNop
- cinfo = MkCompInfo switch_is_on int_switch_set mod_name
+ cinfo = MkCompInfo mod_name
in
if not doing_profiling then
mkAbstractCs [
@@ -85,15 +89,16 @@ codeGen mod_name (local_CCs, extern_CCs) import_names gen_tycons tycon_specs stg
initC cinfo (cgTopBindings maybe_split stg_pgm) ]
where
-----------------
- grp_name = case (stringSwitchSet sw_lookup_fn SccGroup) of
- Just xx -> _PK_ xx
+ grp_name = case opt_SccGroup of
+ Just xx -> xx
Nothing -> mod_name -- default: module name
-----------------
mkCcRegister ccs import_names
= let
register_ccs = mkAbstractCs (map mk_register ccs)
- register_imports = mkAbstractCs (map mk_import_register import_names)
+ register_imports
+ = foldBag mkAbsCStmts mk_import_register AbsCNop import_names
in
mkAbstractCs [
CCallProfCCMacro SLIT("START_REGISTER_CCS") [CLitLit (modnameToC (SLIT("_reg") _APPEND_ mod_name)) AddrRep],
diff --git a/ghc/compiler/codeGen/SMRep.lhs b/ghc/compiler/codeGen/SMRep.lhs
index 4adcfd7f13..99432c7643 100644
--- a/ghc/compiler/codeGen/SMRep.lhs
+++ b/ghc/compiler/codeGen/SMRep.lhs
@@ -12,7 +12,9 @@ Other modules should access this info through ClosureInfo.
module SMRep (
SMRep(..), SMSpecRepKind(..), SMUpdateKind(..),
getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr
+ ltSMRepHdr,
+ isConstantRep, isSpecRep, isStaticRep, isPhantomRep,
+ isIntLikeRep
) where
import Ubiq{-uitous-}
@@ -129,7 +131,27 @@ MuTupleRep == MUTUPLE
--jim
-}
+\end{code}
+
+\begin{code}
+isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool
+isConstantRep (SpecialisedRep ConstantRep _ _ _) = True
+isConstantRep other = False
+
+isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures
+isSpecRep other = False -- True indicates that the _VHS is 0 !
+
+isStaticRep (StaticRep _ _) = True
+isStaticRep _ = False
+isPhantomRep PhantomRep = True
+isPhantomRep _ = False
+
+isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True
+isIntLikeRep other = False
+\end{code}
+
+\begin{code}
instance Eq SMRep where
(SpecialisedRep k1 a1 b1 _) == (SpecialisedRep k2 a2 b2 _) = (tagOf_SMSpecRepKind k1) _EQ_ (tagOf_SMSpecRepKind k2)
&& a1 == a2 && b1 == b2
View Lorry Controller Status