module CgCase ( cgCase, saveVolatileVarsAndRegs ) where
-import Ubiq{-uitous-}
-import CgLoop2 ( cgExpr, getPrimOpArgAmodes )
+IMP_Ubiq(){-uitous-}
+IMPORT_DELOOPER(CgLoop2) ( cgExpr, getPrimOpArgAmodes )
import CgMonad
import StgSyn
idInfoToAmode
)
import CgCon ( buildDynCon, bindConArgs )
-import CgHeapery ( heapCheck )
+import CgHeapery ( heapCheck, yield )
import CgRetConv ( dataReturnConvAlg, dataReturnConvPrim,
ctrlReturnConvAlg,
DataReturnConvention(..), CtrlReturnConvention(..),
assignPrimOpResultRegs,
makePrimOpArgsRobust
)
-import CgStackery ( allocAStack, allocBStack )
+import CgStackery ( allocAStack, allocBStack, allocAStackTop, allocBStackTop )
import CgTailCall ( tailCallBusiness, performReturn )
import CgUsages ( getSpARelOffset, getSpBRelOffset, freeBStkSlot )
import CLabel ( mkVecTblLabel, mkReturnPtLabel, mkDefaultLabel,
- mkAltLabel, mkClosureLabel
+ mkAltLabel
)
import ClosureInfo ( mkConLFInfo, mkLFArgument, layOutDynCon )
-import CmdLineOpts ( opt_SccProfilingOn )
+import CmdLineOpts ( opt_SccProfilingOn, opt_GranMacros )
import CostCentre ( useCurrentCostCentre )
-import HeapOffs ( VirtualSpBOffset(..), VirtualHeapOffset(..) )
+import HeapOffs ( SYN_IE(VirtualSpBOffset), SYN_IE(VirtualHeapOffset) )
import Id ( idPrimRep, toplevelishId,
- dataConTag, fIRST_TAG, ConTag(..),
- isDataCon, DataCon(..),
- idSetToList, GenId{-instance NamedThing,Eq-}
+ dataConTag, fIRST_TAG, SYN_IE(ConTag),
+ isDataCon, SYN_IE(DataCon),
+ idSetToList, GenId{-instance Uniquable,Eq-}
)
import Maybes ( catMaybes )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
-import PrimOp ( primOpCanTriggerGC, PrimOp(..) )
+import PrimOp ( primOpCanTriggerGC, PrimOp(..),
+ primOpStackRequired, StackRequirement(..)
+ )
import PrimRep ( getPrimRepSize, isFollowableRep, retPrimRepSize,
PrimRep(..)
)
import TyCon ( isEnumerationTyCon )
import Type ( typePrimRep,
- getDataSpecTyCon, getDataSpecTyCon_maybe,
- isEnumerationTyCon
+ getAppSpecDataTyConExpandingDicts,
+ maybeAppSpecDataTyConExpandingDicts
)
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}
panic "cgCase: case on PrimOp with default *and* alts\n"
-- For now, die if alts are non-empty
else
-#if 0
- pprTrace "cgCase:prim app returning alg data type: bad code!" (ppr PprDebug scrut) $
- -- See above TO DO TO DO
-#endif
cgExpr (StgLet (StgNonRec id scrut_rhs) deflt_rhs)
where
scrut_rhs = StgRhsClosure useCurrentCostCentre stgArgOcc{-safe-} scrut_free_vars
-- Perform the operation
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
+ -- seq cannot happen here => no additional B Stack alloc
+
absC (COpStmt result_amodes op
arg_amodes -- note: no liveness arg
liveness_mask vol_regs) `thenC`
nukeDeadBindings live_in_whole_case `thenC`
saveVolatileVars live_in_alts `thenFC` \ volatile_var_save_assts ->
- getEndOfBlockInfo `thenFC` \ eob_info ->
- forkEval eob_info nopC
- (getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
+ -- Allocate stack words for the prim-op itself,
+ -- these are guaranteed to be ON TOP OF the stack.
+ -- Currently this is used *only* by the seq# primitive op.
+ let
+ (a_req,b_req) = case (primOpStackRequired op) of
+ NoStackRequired -> (0, 0)
+ FixedStackRequired a b -> (a, b)
+ VariableStackRequired -> (0, 0) -- i.e. don't care
+ in
+ allocAStackTop a_req `thenFC` \ a_slot ->
+ allocBStackTop b_req `thenFC` \ b_slot ->
+
+ getEndOfBlockInfo `thenFC` \ eob_info@(EndOfBlockInfo args_spa args_spb sequel) ->
+ -- a_req and b_req allocate stack space that is taken care of by the
+ -- macros generated for the primops; thus, we there is no need to adjust
+ -- this part of the stacks later on (=> +a_req in EndOfBlockInfo)
+ -- currently all this is only used for SeqOp
+ forkEval (if True {- a_req==0 && b_req==0 -}
+ then eob_info
+ else (EndOfBlockInfo (args_spa+a_req)
+ (args_spb+b_req) sequel)) nopC
+ (
+ getAbsC (cgInlineAlts GCMayHappen uniq alts) `thenFC` \ abs_c ->
absC (CRetUnVector vtbl_label (CLabelledCode return_label abs_c))
`thenC`
returnFC (CaseAlts (CUnVecLbl return_label vtbl_label)
-- 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, _, _) = getDataSpecTyCon ty
+ (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
getPrimAppResultAmodes uniq (StgAlgAlts ty alts other_default)
-- Default is either StgNoDefault or StgBindDefault with unused binder
-- Turn them into amodes
arg_amodes = concat (map mk_amodes sorted_alts)
mk_amodes (con, args, use_mask, rhs)
- = [ CTemp (getItsUnique arg) (idPrimRep arg) | arg <- args ]
+ = [ CTemp (uniqueOf arg) (idPrimRep arg) | arg <- args ]
\end{code}
The situation is simpler for primitive
-- which is worse than having the alt code in the switch statement
let
- (spec_tycon, _, _) = getDataSpecTyCon ty
+ (spec_tycon, _, _) = getAppSpecDataTyConExpandingDicts ty
use_labelled_alts
= case ctrlReturnConvAlg spec_tycon of
else
cgSemiTaggedAlts uniq alts deflt -- Just <something>
in
- cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt
+ cgAlgAlts GCMayHappen uniq cc_restore use_labelled_alts ty alts deflt True
`thenFC` \ (tagged_alt_absCs, deflt_absC) ->
mkReturnVector uniq ty tagged_alt_absCs deflt_absC `thenFC` \ return_vec ->
-> Code
\end{code}
+HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): If
+we do an inlining of the case no separate functions for returning are
+created, so we don't have to generate a GRAN_YIELD in that case. This info
+must be propagated to cgAlgAltRhs (where the GRAN_YIELD macro might be
+emitted). Hence, the new Bool arg to cgAlgAltRhs.
+
First case: algebraic case, exactly one alternative, no default.
In this case the primitive op will not have set a temporary to the
tag, so we shouldn't generate a switch statment. Instead we just
\begin{code}
cgInlineAlts gc_flag uniq (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
- = cgAlgAltRhs gc_flag con args use_mask rhs
+ = cgAlgAltRhs gc_flag con args use_mask rhs False{-no yield macro if alt gets inlined-}
\end{code}
Second case: algebraic case, several alternatives.
\begin{code}
cgInlineAlts gc_flag uniq (StgAlgAlts ty alts deflt)
= cgAlgAlts gc_flag uniq AbsCNop{-restore_cc-} False{-no semi-tagging-}
- ty alts deflt `thenFC` \ (tagged_alts, deflt_c) ->
+ ty alts deflt
+ False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
-- Do the switch
absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
In @cgAlgAlts@, none of the binders in the alternatives are
assumed to be yet bound.
+HWL comment on {\em GrAnSim\/} (adding GRAN_YIELDs for context switch): The
+last arg of cgAlgAlts indicates if we want a context switch at the
+beginning of each alternative. Normally we want that. The only exception
+are inlined alternatives.
+
\begin{code}
cgAlgAlts :: GCFlag
-> Unique
-> Type -- From the case statement
-> [(Id, [Id], [Bool], StgExpr)] -- The alternatives
-> StgCaseDefault -- The default
+ -> Bool -- Context switch at alts?
-> FCode ([(ConTag, AbstractC)], -- The branches
AbstractC -- The default case
)
\begin{code}
cgAlgAlts gc_flag uniq restore_cc semi_tagging
ty alts deflt@(StgBindDefault binder True{-used-} _)
+ emit_yield{-should a yield macro be emitted?-}
= let
extra_branches :: [FCode (ConTag, AbstractC)]
extra_branches = catMaybes (map mk_extra_branch default_cons)
must_label_default = semi_tagging || not (null extra_branches)
in
- forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging) alts)
+ forkAlts (map (cgAlgAlt gc_flag uniq restore_cc semi_tagging emit_yield) alts)
extra_branches
- (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt)
+ (cgAlgDefault gc_flag uniq restore_cc must_label_default deflt emit_yield)
where
default_join_lbl = mkDefaultLabel uniq
jump_instruction = CJump (CLbl default_join_lbl CodePtrRep)
- (spec_tycon, _, spec_cons) = getDataSpecTyCon ty
+ (spec_tycon, _, spec_cons) = getAppSpecDataTyConExpandingDicts ty
alt_cons = [ con | (con,_,_,_) <- alts ]
where
lf_info = mkConLFInfo con
tag = dataConTag con
- closure_lbl = mkClosureLabel con
-- alloc_code generates code to allocate constructor con, whose args are
-- in the arguments to alloc_code, assigning the result to Node.
\begin{code}
cgAlgAlts gc_flag uniq restore_cc must_label_branches ty alts deflt
{- The deflt is either StgNoDefault or a BindDefault which doesn't use the binder -}
- = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches) alts)
+ emit_yield{-should a yield macro be emitted?-}
+
+ = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
[{- No "extra branches" -}]
- (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt)
+ (cgAlgDefault gc_flag uniq restore_cc must_label_branches deflt emit_yield)
\end{code}
\begin{code}
cgAlgDefault :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state...
-> StgCaseDefault -- input
- -> FCode AbstractC -- output
+ -> Bool
+ -> FCode AbstractC -- output
cgAlgDefault gc_flag uniq restore_cc must_label_branch
- StgNoDefault
+ StgNoDefault _
= returnFC AbsCNop
cgAlgDefault gc_flag uniq restore_cc must_label_branch
(StgBindDefault _ False{-binder not used-} rhs)
+ emit_yield{-should a yield macro be emitted?-}
= getAbsC (absC restore_cc `thenC`
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ (if emit_gran_macros && emit_yield
+ then yield [] False
+ else absC AbsCNop) `thenC`
+ -- liveness same as in possibleHeapCheck below
possibleHeapCheck gc_flag [] False (cgExpr rhs)) `thenFC` \ abs_c ->
let
final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
cgAlgDefault gc_flag uniq restore_cc must_label_branch
(StgBindDefault binder True{-binder used-} rhs)
+ emit_yield{-should a yield macro be emitted?-}
= -- We have arranged that Node points to the thing, even
-- even if we return in registers
bindNewToReg binder node mkLFArgument `thenC`
getAbsC (absC restore_cc `thenC`
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ (if emit_gran_macros && emit_yield
+ then yield [node] False
+ else absC AbsCNop) `thenC`
+ -- liveness same as in possibleHeapCheck below
possibleHeapCheck gc_flag [node] False (cgExpr rhs)
-- Node is live, but doesn't need to point at the thing itself;
-- it's ok for Node to point to an indirection or FETCH_ME
where
lbl = mkDefaultLabel uniq
+-- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
cgAlgAlt :: GCFlag
-> Unique -> AbstractC -> Bool -- turgid state
+ -> Bool -- Context switch at alts?
-> (Id, [Id], [Bool], StgExpr)
-> FCode (ConTag, AbstractC)
-cgAlgAlt gc_flag uniq restore_cc must_label_branch (con, args, use_mask, rhs)
+cgAlgAlt gc_flag uniq restore_cc must_label_branch
+ emit_yield{-should a yield macro be emitted?-}
+ (con, args, use_mask, rhs)
= getAbsC (absC restore_cc `thenC`
- cgAlgAltRhs gc_flag con args use_mask rhs) `thenFC` \ abs_c ->
+ cgAlgAltRhs gc_flag con args use_mask rhs
+ emit_yield
+ ) `thenFC` \ abs_c ->
let
final_abs_c | must_label_branch = CJump (CLabelledCode lbl abs_c)
| otherwise = abs_c
tag = dataConTag con
lbl = mkAltLabel uniq tag
-cgAlgAltRhs :: GCFlag -> Id -> [Id] -> [Bool] -> StgExpr -> Code
-
-cgAlgAltRhs gc_flag con args use_mask rhs
+cgAlgAltRhs :: GCFlag
+ -> Id
+ -> [Id]
+ -> [Bool]
+ -> StgExpr
+ -> Bool -- context switch?
+ -> Code
+cgAlgAltRhs gc_flag con args use_mask rhs emit_yield
= let
(live_regs, node_reqd)
= case (dataReturnConvAlg con) of
ReturnInHeap -> ([], True)
- ReturnInRegs regs -> ([reg | (reg,True) <- regs `zipEqual` use_mask], False)
+ ReturnInRegs regs -> ([reg | (reg,True) <- zipEqual "cgAlgAltRhs" regs use_mask], False)
-- Pick the live registers using the use_mask
-- Doing so is IMPORTANT, because with semi-tagging
-- enabled only the live registers will have valid
-- pointers in them.
in
+ let
+ emit_gran_macros = opt_GranMacros
+ in
+ (if emit_gran_macros && emit_yield
+ then yield live_regs node_reqd
+ else absC AbsCNop) `thenC`
+ -- liveness same as in possibleHeapCheck below
possibleHeapCheck gc_flag live_regs node_reqd (
(case gc_flag of
NoGC -> mapFCs bindNewToTemp args `thenFC` \ _ ->
-- )
where
- (spec_tycon,_,_) = case (getDataSpecTyCon_maybe ty) of -- *must* be a real "data" type constructor
+ (spec_tycon,_,_) = case (maybeAppSpecDataTyConExpandingDicts ty) of -- *must* be a real "data" type constructor
Just xx -> xx
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)
projects / ghc-hetmet.git / blobdiff