diff options
Diffstat (limited to 'ghc/compiler/codeGen')
| -rw-r--r-- | ghc/compiler/codeGen/CgBindery.lhs | 60 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgCase.lhs | 166 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgClosure.lhs | 133 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgCompInfo.lhs | 3 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgCon.lhs | 92 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgConTbls.lhs | 125 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgExpr.lhs | 67 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgHeapery.lhs | 31 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgLetNoEscape.lhs | 21 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgLoop1.lhi | 35 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgLoop2.lhi | 15 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgMonad.lhs | 168 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgRetConv.lhs | 136 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgStackery.lhs | 17 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgTailCall.lhs | 67 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgUpdate.lhs | 20 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CgUsages.lhs | 17 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/ClosureInfo.lhs | 170 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/CodeGen.lhs | 37 | ||||
| -rw-r--r-- | ghc/compiler/codeGen/SMRep.lhs | 24 |
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 |