%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.47 2000/11/07 13:12:22 simonpj Exp $
+% $Id: CgCase.lhs,v 1.64 2003/07/02 13:18:24 simonpj Exp $
%
%********************************************************
%* *
%********************************************************
\begin{code}
-module CgCase ( cgCase, saveVolatileVarsAndRegs, restoreCurrentCostCentre
+module CgCase ( cgCase, saveVolatileVarsAndRegs,
+ mkRetDirectTarget, restoreCurrentCostCentre
) where
#include "HsVersions.h"
import StgSyn
import AbsCSyn
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- getAmodeRep, nonemptyAbsC
- )
-import CgUpdate ( reserveSeqFrame )
+import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch, getAmodeRep )
import CgBindery ( getVolatileRegs, getArgAmodes,
bindNewToReg, bindNewToTemp,
- bindNewPrimToAmode,
- rebindToStack, getCAddrMode,
- getCAddrModeAndInfo, getCAddrModeIfVolatile,
+ getCAddrModeAndInfo,
+ rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
buildContLivenessMask, nukeDeadBindings,
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
-import CgHeapery ( altHeapCheck )
+import CgHeapery ( altHeapCheck, unbxTupleHeapCheck )
import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
CtrlReturnConvention(..)
)
import CgStackery ( allocPrimStack, allocStackTop,
deAllocStackTop, freeStackSlots, dataStackSlots
)
-import CgTailCall ( tailCallFun )
+import CgTailCall ( performTailCall )
import CgUsages ( getSpRelOffset )
import CLabel ( mkVecTblLabel, mkClosureTblLabel,
mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
)
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn )
-import Id ( Id, idPrimRep, isDeadBinder )
-import DataCon ( DataCon, dataConTag, fIRST_TAG, ConTag,
- isUnboxedTupleCon )
+import Id ( Id, idName, isDeadBinder )
+import DataCon ( dataConTag, fIRST_TAG, ConTag )
import VarSet ( varSetElems )
-import Literal ( Literal )
+import CoreSyn ( AltCon(..) )
import PrimOp ( primOpOutOfLine, PrimOp(..) )
import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
)
-import TyCon ( TyCon, isEnumerationTyCon, isUnboxedTupleTyCon,
- isFunTyCon, isPrimTyCon,
- )
-import Type ( Type, typePrimRep, splitAlgTyConApp,
- splitTyConApp_maybe, repType )
+import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep )
import Unique ( Unique, Uniquable(..), newTagUnique )
-import Maybes ( maybeToBool )
-import Util
+import Util ( only )
+import List ( sortBy )
import Outputable
\end{code}
-> StgLiveVars
-> Id
-> SRT
- -> StgCaseAlts
+ -> AltType
+ -> [StgAlt]
-> Code
\end{code}
-Special case #1: PrimOps returning enumeration types.
-
-For enumeration types, we invent a temporary (builtin-unique 1) to
-hold the tag, and cross our fingers that this doesn't clash with
-anything else. Builtin-unique 0 is used for a similar reason when
-compiling enumerated-type primops in CgExpr.lhs. We can't use the
-unique from the case binder, because this is used to hold the actual
-closure (when the case binder is live, that is).
-
-There is an extra special case for
-
- case tagToEnum# x of
- ...
-
-which generates no code for the primop, unless x is used in the
-alternatives (in which case we lookup the tag in the relevant closure
-table to get the closure).
-
-Being a bit short of uniques for temporary variables here, we use
-newTagUnique to generate a new unique from the case binder. The case
-binder's unique will presumably have the 'c' tag (generated by
-CoreToStg), so we just change its tag to 'C' (for 'case') to ensure it
-doesn't clash with anything else.
+Special case #1: case of literal.
\begin{code}
-cgCase (StgPrimApp op args res_ty)
- live_in_whole_case live_in_alts bndr srt (StgAlgAlts ty alts deflt)
- | isEnumerationTyCon tycon
- = getArgAmodes args `thenFC` \ arg_amodes ->
-
- let tag_amode = case op of
- TagToEnumOp -> only arg_amodes
- _ -> CTemp (newTagUnique (getUnique bndr) 'C') IntRep
-
- closure = CVal (CIndex (CLbl (mkClosureTblLabel tycon) PtrRep) tag_amode PtrRep) PtrRep
- in
-
- case op of {
- TagToEnumOp -> nopC; -- no code!
-
- _ -> -- Perform the operation
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-
- absC (COpStmt [tag_amode] op
- arg_amodes -- note: no liveness arg
- vol_regs)
- } `thenC`
-
- -- bind the default binder if necessary
- -- The deadness info is set by StgVarInfo
- (if (isDeadBinder bndr)
- then nopC
- else bindNewToTemp bndr `thenFC` \ bndr_amode ->
- absC (CAssign bndr_amode closure))
- `thenC`
+cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt
+ alt_type@(PrimAlt tycon) alts
+ = bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode (CLit lit)) `thenC`
+ cgPrimAlts NoGC tmp_amode alts alt_type
+\end{code}
- -- compile the alts
- cgAlgAlts NoGC uniq Nothing{-cc_slot-} False{-no semi-tagging-}
- False{-not poly case-} alts deflt
- False{-don't emit yield-} `thenFC` \ (tagged_alts, deflt_c) ->
+Special case #2: scrutinising a primitive-typed variable. No
+evaluation required. We don't save volatile variables, nor do we do a
+heap-check in the alternatives. Instead, the heap usage of the
+alternatives is worst-cased and passed upstream. This can result in
+allocating more heap than strictly necessary, but it will sometimes
+eliminate a heap check altogether.
- -- Do the switch
- absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
+\begin{code}
+cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
+ alt_type@(PrimAlt tycon) alts
- where
- (Just (tycon,_)) = splitTyConApp_maybe res_ty
- uniq = getUnique bndr
-\end{code}
+ = -- Careful! we can't just bind the default binder to the same thing
+ -- as the scrutinee, since it might be a stack location, and having
+ -- two bindings pointing at the same stack locn doesn't work (it
+ -- confuses nukeDeadBindings). Hence, use a new temp.
+ getCAddrMode v `thenFC` \ amode ->
+ bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode amode) `thenC`
+ cgPrimAlts NoGC tmp_amode alts alt_type
+\end{code}
-Special case #2: inline PrimOps.
+Special case #3: inline PrimOps.
\begin{code}
-cgCase (StgPrimApp op args res_ty)
- live_in_whole_case live_in_alts bndr srt alts
- | not (primOpOutOfLine op)
- =
- -- Get amodes for the arguments and results
+cgCase (StgOpApp op@(StgPrimOp primop) args _)
+ live_in_whole_case live_in_alts bndr srt alt_type alts
+ | not (primOpOutOfLine primop)
+ = -- Get amodes for the arguments and results
getArgAmodes args `thenFC` \ arg_amodes ->
- let
- result_amodes = getPrimAppResultAmodes (getUnique bndr) alts
- in
- -- Perform the operation
getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
- absC (COpStmt result_amodes op
- arg_amodes -- note: no liveness arg
- vol_regs) `thenC`
-
- -- Scrutinise the result
- cgInlineAlts bndr alts
+ case alt_type of
+ PrimAlt tycon -- PRIMITIVE ALTS
+ -> bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (COpStmt [tmp_amode] op arg_amodes vol_regs) `thenC`
+ -- Note: no liveness arg
+ cgPrimAlts NoGC tmp_amode alts alt_type
+
+ UbxTupAlt tycon -- UNBOXED TUPLE ALTS
+ -> -- No heap check, no yield, just get in there and do it.
+ -- NB: the case binder isn't bound to anything;
+ -- it has a unboxed tuple type
+ mapFCs bindNewToTemp res_ids `thenFC` \ res_tmps ->
+ absC (COpStmt res_tmps op arg_amodes vol_regs) `thenC`
+ cgExpr rhs
+ where
+ [(_, res_ids, _, rhs)] = alts
+
+ AlgAlt tycon -- ENUMERATION TYPE RETURN
+ -> ASSERT( isEnumerationTyCon tycon )
+ do_enum_primop primop `thenFC` \ tag_amode ->
+
+ -- Bind the default binder if necessary
+ -- (avoiding it avoids the assignment)
+ -- The deadness info is set by StgVarInfo
+ (if (isDeadBinder bndr)
+ then nopC
+ else bindNewToTemp bndr `thenFC` \ tmp_amode ->
+ absC (CAssign tmp_amode (tagToClosure tycon tag_amode))
+ ) `thenC`
+
+ -- Compile the alts
+ cgAlgAlts NoGC (getUnique bndr)
+ Nothing{-cc_slot-} False{-no semi-tagging-}
+ (AlgAlt tycon) alts `thenFC` \ tagged_alts ->
+
+ -- Do the switch
+ absC (mkAlgAltsCSwitch tag_amode tagged_alts)
+ where
+ do_enum_primop :: PrimOp -> FCode CAddrMode -- Returns amode for result
+ do_enum_primop TagToEnumOp -- No code!
+ = returnFC (only arg_amodes)
+
+ do_enum_primop primop
+ = absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
+ returnFC tag_amode
+ where
+ tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
+ -- Being a bit short of uniques for temporary variables here,
+ -- we use newTagUnique to generate a new unique from the case
+ -- binder. The case binder's unique will presumably have
+ -- the 'c' tag (generated by CoreToStg), so we just change
+ -- its tag to 'C' (for 'case') to ensure it doesn't clash with
+ -- anything else.
+ -- We can't use the unique from the case binder, becaus e
+ -- this is used to hold the actual result closure
+ -- (via the call to bindNewToTemp)
+
+ other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
\end{code}
TODO: Case-of-case of primop can probably be done inline too (but
ghc/lib/misc/PackedString.lhs for examples where this crops up (with
4.02).
-Another special case: scrutinising a primitive-typed variable. No
-evaluation required. We don't save volatile variables, nor do we do a
-heap-check in the alternatives. Instead, the heap usage of the
-alternatives is worst-cased and passed upstream. This can result in
-allocating more heap than strictly necessary, but it will sometimes
-eliminate a heap check altogether.
-
-\begin{code}
-cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
- (StgPrimAlts ty alts deflt)
-
- =
- getCAddrMode v `thenFC` \amode ->
-
- {-
- Careful! we can't just bind the default binder to the same thing
- as the scrutinee, since it might be a stack location, and having
- two bindings pointing at the same stack locn doesn't work (it
- confuses nukeDeadBindings). Hence, use a new temp.
- -}
- bindNewToTemp bndr `thenFC` \deflt_amode ->
- absC (CAssign deflt_amode amode) `thenC`
-
- cgPrimAlts NoGC amode alts deflt []
-\end{code}
-
Special case: scrutinising a non-primitive variable.
This can be done a little better than the general case, because
we can reuse/trim the stack slot holding the variable (if it is in one).
\begin{code}
cgCase (StgApp fun args)
- live_in_whole_case live_in_alts bndr srt alts@(StgAlgAlts ty _ _)
- =
- getCAddrModeAndInfo fun `thenFC` \ (fun_amode, lf_info) ->
+ live_in_whole_case live_in_alts bndr srt alt_type alts
+ = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
getArgAmodes args `thenFC` \ arg_amodes ->
- -- Squish the environment
+ -- Nuking dead bindings *before* calculating the saves is the
+ -- value-add here. We might end up freeing up some slots currently
+ -- occupied by variables only required for the call.
+ -- NOTE: we need to look up the variables used in the call before
+ -- doing this, because some of them may not be in the environment
+ -- afterward.
nukeDeadBindings live_in_alts `thenC`
saveVolatileVarsAndRegs live_in_alts
`thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
- allocStackTop retPrimRepSize `thenFC` \_ ->
-
- forkEval alts_eob_info nopC (
- deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alts)
+ forkEval alts_eob_info
+ ( allocStackTop retPrimRepSize
+ `thenFC` \_ -> nopC )
+ ( deAllocStackTop retPrimRepSize `thenFC` \_ ->
+ cgEvalAlts maybe_cc_slot bndr srt alt_type alts )
`thenFC` \ scrut_eob_info ->
- let real_scrut_eob_info =
- if not_con_ty
- then reserveSeqFrame scrut_eob_info
- else scrut_eob_info
- in
-
- setEndOfBlockInfo real_scrut_eob_info (
- tailCallFun fun fun_amode lf_info arg_amodes save_assts
- )
-
- where
- not_con_ty = case (getScrutineeTyCon ty) of
- Just _ -> False
- other -> True
+ setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
+ performTailCall fun' fun_amode lf_info arg_amodes save_assts
\end{code}
Note about return addresses: we *always* push a return address, even
Finally, here is the general case.
\begin{code}
-cgCase expr live_in_whole_case live_in_alts bndr srt alts
+cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
= -- Figure out what volatile variables to save
nukeDeadBindings live_in_whole_case `thenC`
-- generate code for the alts
forkEval alts_eob_info
- (
- nukeDeadBindings live_in_alts `thenC`
+ (nukeDeadBindings live_in_alts `thenC`
allocStackTop retPrimRepSize -- space for retn address
`thenFC` \_ -> nopC
)
(deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alts) `thenFC` \ scrut_eob_info ->
-
- let real_scrut_eob_info =
- if not_con_ty
- then reserveSeqFrame scrut_eob_info
- else scrut_eob_info
- in
-
- setEndOfBlockInfo real_scrut_eob_info (cgExpr expr)
+ cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info ->
- where
- not_con_ty = case (getScrutineeTyCon (alts_ty alts)) of
- Just _ -> False
- other -> True
+ setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
+ cgExpr expr
\end{code}
There's a lot of machinery going on behind the scenes to manage the
could be anywhere within the record).
\begin{code}
-alts_ty (StgAlgAlts ty _ _) = ty
-alts_ty (StgPrimAlts ty _ _) = ty
+maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
+ = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
+maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\end{code}
%************************************************************************
%* *
-\subsection[CgCase-primops]{Primitive applications}
-%* *
-%************************************************************************
-
-Get result amodes for a primitive operation, in the case wher GC can't happen.
-The amodes are returned in canonical order, ready for the prim-op!
-
- Alg case: temporaries named as in the alternatives,
- plus (CTemp u) for the tag (if needed)
- Prim case: (CTemp u)
-
-This is all disgusting, because these amodes must be consistent with those
-invented by CgAlgAlts.
-
-\begin{code}
-getPrimAppResultAmodes
- :: Unique
- -> StgCaseAlts
- -> [CAddrMode]
-
-getPrimAppResultAmodes uniq (StgAlgAlts ty alts some_default)
-
- | isUnboxedTupleTyCon tycon =
- case alts of
- [(con, args, use_mask, rhs)] ->
- [ CTemp (getUnique arg) (idPrimRep arg) | arg <- args ]
- _ -> panic "getPrimAppResultAmodes: case of unboxed tuple has multiple branches"
-
- | otherwise = panic ("getPrimAppResultAmodes: case of primop has strange type: " ++ showSDoc (ppr ty))
-
- where (tycon, _, _) = splitAlgTyConApp ty
-
--- The situation is simpler for primitive results, because there is only
--- one!
-
-getPrimAppResultAmodes uniq (StgPrimAlts ty _ _)
- = [CTemp uniq (typePrimRep ty)]
-\end{code}
-
-
-%************************************************************************
-%* *
\subsection[CgCase-alts]{Alternatives}
%* *
%************************************************************************
cgEvalAlts :: Maybe VirtualSpOffset -- Offset of cost-centre to be restored, if any
-> Id
-> SRT -- SRT for the continuation
- -> StgCaseAlts
+ -> AltType
+ -> [StgAlt]
-> FCode Sequel -- Any addr modes inside are guaranteed
-- to be a label so that we can duplicate it
-- without risk of duplicating code
-cgEvalAlts cc_slot bndr srt alts
- =
- let uniq = getUnique bndr in
-
- buildContLivenessMask uniq `thenFC` \ liveness_mask ->
-
- case alts of
-
- -- algebraic alts ...
- (StgAlgAlts ty alts deflt) ->
+cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
+ = -- Unboxed tuple case
+ -- By now, the simplifier should have have turned it
+ -- into case e of (# a,b #) -> e
+ -- There shouldn't be a
+ -- case e of DEFAULT -> e
+ ASSERT2( case con of { DataAlt _ -> True; other -> False },
+ text "cgEvalAlts: dodgy case of unboxed tuple type" )
+
+ forkAbsC ( -- forkAbsC for the RHS, so that the envt is
+ -- not changed for the mkRetDirect call
+ restoreCurrentCostCentre cc_slot `thenC`
+ bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) ->
+ -- Generate a heap check if necessary
+ unbxTupleHeapCheck live_regs ptrs nptrs AbsCNop $
+ -- And finally the code for the alternative
+ cgExpr rhs
+ ) `thenFC` \ abs_c ->
+ mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
+ returnFC (CaseAlts lbl Nothing False)
+
+cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
+ = forkAbsC ( -- forkAbsC for the RHS, so that the envt is
+ -- not changed for the mkRetDirect call
+ restoreCurrentCostCentre cc_slot `thenC`
+ bindNewToReg bndr reg (mkLFArgument bndr) `thenC`
+ cgPrimAlts GCMayHappen (CReg reg) alts alt_type
+ ) `thenFC` \ abs_c ->
+ mkRetDirectTarget bndr abs_c srt `thenFC` \ lbl ->
+ returnFC (CaseAlts lbl Nothing False)
+ where
+ reg = dataReturnConvPrim kind
+ kind = tyConPrimRep tycon
- -- bind the default binder (it covers all the alternatives)
- bindNewToReg bndr node mkLFArgument `thenC`
+cgEvalAlts cc_slot bndr srt alt_type alts
+ = -- Algebraic and polymorphic case
+ -- Bind the default binder
+ bindNewToReg bndr node (mkLFArgument bndr) `thenC`
-- Generate sequel info for use downstream
-- At the moment, we only do it if the type is vector-returnable.
--
-- which is worse than having the alt code in the switch statement
- let tycon_info = getScrutineeTyCon ty
- is_alg = maybeToBool tycon_info
- Just spec_tycon = tycon_info
- in
-
- -- deal with the unboxed tuple case
- if is_alg && isUnboxedTupleTyCon spec_tycon then
- case alts of
- [alt] -> let lbl = mkReturnInfoLabel uniq in
- cgUnboxedTupleAlt uniq cc_slot True alt
- `thenFC` \ abs_c ->
- getSRTLabel `thenFC` \srt_label ->
- absC (CRetDirect uniq abs_c (srt_label, srt)
- liveness_mask) `thenC`
- returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
- _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
-
- -- normal algebraic (or polymorphic) case alternatives
- else let
- ret_conv | is_alg = ctrlReturnConvAlg spec_tycon
- | otherwise = UnvectoredReturn 0
-
- use_labelled_alts = case ret_conv of
- VectoredReturn _ -> True
- _ -> False
-
- semi_tagged_stuff
- = if use_labelled_alts then
- cgSemiTaggedAlts bndr alts deflt -- Just <something>
- else
- Nothing -- no semi-tagging info
-
- in
- cgAlgAlts GCMayHappen uniq cc_slot use_labelled_alts (not is_alg)
- alts deflt True `thenFC` \ (tagged_alt_absCs, deflt_absC) ->
-
- mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness_mask
- ret_conv `thenFC` \ return_vec ->
-
- returnFC (CaseAlts return_vec semi_tagged_stuff)
-
- -- primitive alts...
- (StgPrimAlts ty alts deflt) ->
-
- -- Restore the cost centre
- restoreCurrentCostCentre cc_slot `thenFC` \ cc_restore ->
-
- -- Generate the switch
- getAbsC (cgPrimEvalAlts bndr ty alts deflt) `thenFC` \ abs_c ->
-
- -- Generate the labelled block, starting with restore-cost-centre
- getSRTLabel `thenFC` \srt_label ->
- absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c)
- (srt_label,srt) liveness_mask) `thenC`
-
- -- Return an amode for the block
- returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
-\end{code}
+ let ret_conv = case alt_type of
+ AlgAlt tc -> ctrlReturnConvAlg tc
+ PolyAlt -> UnvectoredReturn 0
+ use_labelled_alts = case ret_conv of
+ VectoredReturn _ -> True
+ _ -> False
-\begin{code}
-cgInlineAlts :: Id
- -> StgCaseAlts
- -> Code
+ semi_tagged_stuff = cgSemiTaggedAlts use_labelled_alts bndr alts
+
+ in
+ cgAlgAlts GCMayHappen (getUnique bndr)
+ cc_slot use_labelled_alts
+ alt_type alts `thenFC` \ tagged_alt_absCs ->
+
+ mkRetVecTarget bndr tagged_alt_absCs
+ srt ret_conv `thenFC` \ return_vec ->
+
+ returnFC (CaseAlts return_vec semi_tagged_stuff False)
\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: primitive op returns an unboxed tuple.
-
-\begin{code}
-cgInlineAlts bndr (StgAlgAlts ty [alt@(con,args,use_mask,rhs)] StgNoDefault)
- | isUnboxedTupleCon con
- = -- no heap check, no yield, just get in there and do it.
- mapFCs bindNewToTemp args `thenFC` \ _ ->
- cgExpr rhs
-
- | otherwise
- = panic "cgInlineAlts: single alternative, not an unboxed tuple"
-\end{code}
-
-Third (real) case: primitive result type.
-
-\begin{code}
-cgInlineAlts bndr (StgPrimAlts ty alts deflt)
- = cgPrimInlineAlts bndr ty alts deflt
-\end{code}
-
%************************************************************************
%* *
\subsection[CgCase-alg-alts]{Algebraic alternatives}
\begin{code}
cgAlgAlts :: GCFlag
- -> Unique
- -> Maybe VirtualSpOffset
- -> Bool -- True <=> branches must be labelled
- -> Bool -- True <=> polymorphic case
- -> [(DataCon, [Id], [Bool], StgExpr)] -- The alternatives
- -> StgCaseDefault -- The default
- -> Bool -- Context switch at alts?
- -> FCode ([(ConTag, AbstractC)], -- The branches
- AbstractC -- The default case
- )
-
-cgAlgAlts gc_flag uniq restore_cc must_label_branches is_fun alts deflt
- emit_yield{-should a yield macro be emitted?-}
-
- = forkAlts (map (cgAlgAlt gc_flag uniq restore_cc must_label_branches emit_yield) alts)
- (cgAlgDefault gc_flag is_fun uniq restore_cc must_label_branches deflt emit_yield)
-\end{code}
-
-\begin{code}
-cgAlgDefault :: GCFlag
- -> Bool -- could be a function-typed result?
- -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state...
- -> StgCaseDefault -- input
- -> Bool
- -> FCode AbstractC -- output
-
-cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch StgNoDefault _
- = returnFC AbsCNop
-
-cgAlgDefault gc_flag is_fun uniq cc_slot must_label_branch
- (StgBindDefault rhs)
- emit_yield{-should a yield macro be emitted?-}
-
- = -- We have arranged that Node points to the thing
- restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
- getAbsC (absC restore_cc `thenC`
- -- HWL: maybe need yield here
- --(if emit_yield
- -- then yield [node] True
- -- else absC AbsCNop) `thenC`
- possibleHeapCheck gc_flag is_fun [node] [] Nothing (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
- -- Hence no need to re-enter Node.
- ) `thenFC` \ abs_c ->
-
- let
- final_abs_c | must_label_branch = CCodeBlock lbl abs_c
- | otherwise = abs_c
- in
- returnFC final_abs_c
- where
- lbl = mkDefaultLabel uniq
-
--- HWL comment on GrAnSim: GRAN_YIELDs needed; emitted in cgAlgAltRhs
+ -> Unique
+ -> Maybe VirtualSpOffset
+ -> Bool -- True <=> branches must be labelled
+ -- (used for semi-tagging)
+ -> AltType -- ** AlgAlt or PolyAlt only **
+ -> [StgAlt] -- The alternatives
+ -> FCode [(AltCon, AbstractC)] -- The branches
+
+cgAlgAlts gc_flag uniq restore_cc must_label_branches alt_type alts
+ = forkAlts [ cgAlgAlt gc_flag uniq restore_cc must_label_branches alt_type alt
+ | alt <- alts]
cgAlgAlt :: GCFlag
- -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
- -> Bool -- Context switch at alts?
- -> (DataCon, [Id], [Bool], StgExpr)
- -> FCode (ConTag, AbstractC)
-
-cgAlgAlt gc_flag uniq cc_slot must_label_branch
- emit_yield{-should a yield macro be emitted?-}
- (con, args, use_mask, rhs)
- =
- restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
- getAbsC (absC restore_cc `thenC`
- -- HWL: maybe need yield here
- -- (if emit_yield
- -- then yield [node] True -- XXX live regs wrong
- -- else absC AbsCNop) `thenC`
- (case gc_flag of
- NoGC -> mapFCs bindNewToTemp args `thenFC` \_ -> nopC
- GCMayHappen -> bindConArgs con args
- ) `thenC`
- possibleHeapCheck gc_flag False [node] [] Nothing (
- cgExpr rhs)
- ) `thenFC` \ abs_c ->
+ -> Unique -> Maybe VirtualSpOffset -> Bool -- turgid state
+ -> AltType -- ** AlgAlt or PolyAlt only **
+ -> StgAlt
+ -> FCode (AltCon, AbstractC)
+
+cgAlgAlt gc_flag uniq cc_slot must_label_branch
+ alt_type (con, args, use_mask, rhs)
+ = getAbsC (bind_con_args con args `thenFC` \ _ ->
+ restoreCurrentCostCentre cc_slot `thenC`
+ maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)
+ ) `thenFC` \ abs_c ->
let
final_abs_c | must_label_branch = CCodeBlock lbl abs_c
| otherwise = abs_c
in
- returnFC (tag, final_abs_c)
+ returnFC (con, final_abs_c)
where
- tag = dataConTag con
- lbl = mkAltLabel uniq tag
-
-cgUnboxedTupleAlt
- :: Unique -- unique for label of the alternative
- -> Maybe VirtualSpOffset -- Restore cost centre
- -> Bool -- ctxt switch
- -> (DataCon, [Id], [Bool], StgExpr) -- alternative
- -> FCode AbstractC
-
-cgUnboxedTupleAlt lbl cc_slot emit_yield (con,args,use_mask,rhs)
- = getAbsC (
- bindUnboxedTupleComponents args
- `thenFC` \ (live_regs,tags,stack_res) ->
-
- restoreCurrentCostCentre cc_slot `thenFC` \restore_cc ->
- absC restore_cc `thenC`
-
- -- HWL: maybe need yield here
- -- (if emit_yield
- -- then yield live_regs True -- XXX live regs wrong?
- -- else absC AbsCNop) `thenC`
- let
- -- ToDo: could maybe use Nothing here if stack_res is False
- -- since the heap-check can just return to the top of the
- -- stack.
- ret_addr = Just lbl
- in
-
- -- free up stack slots containing tags,
- freeStackSlots (map fst tags) `thenC`
-
- -- generate a heap check if necessary
- possibleHeapCheck GCMayHappen False live_regs tags ret_addr (
-
- -- and finally the code for the alternative
- cgExpr rhs)
- )
+ lbl = case con of
+ DataAlt dc -> mkAltLabel uniq (dataConTag dc)
+ DEFAULT -> mkDefaultLabel uniq
+ other -> pprPanic "cgAlgAlt" (ppr con)
+
+ bind_con_args DEFAULT args = nopC
+ bind_con_args (DataAlt dc) args = bindConArgs dc args
\end{code}
%************************************************************************
algebraic case alternatives for semi-tagging.
\begin{code}
-cgSemiTaggedAlts :: Id
- -> [(DataCon, [Id], [Bool], StgExpr)]
- -> GenStgCaseDefault Id Id
+cgSemiTaggedAlts :: Bool -- True <=> use semitagging: each alt will be labelled
+ -> Id
+ -> [StgAlt]
-> SemiTaggingStuff
-cgSemiTaggedAlts binder alts deflt
- = Just (map st_alt alts, st_deflt deflt)
+cgSemiTaggedAlts False binder alts
+ = Nothing
+cgSemiTaggedAlts True binder alts
+ = Just ([st_alt con args | (DataAlt con, args, _, _) <- alts],
+ case head alts of
+ (DEFAULT, _, _, _) -> Just st_deflt
+ other -> Nothing)
where
- uniq = getUnique binder
-
- st_deflt StgNoDefault = Nothing
+ uniq = getUnique binder
- st_deflt (StgBindDefault _)
- = Just (Just binder,
- (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
- mkDefaultLabel uniq)
- )
+ st_deflt = (binder,
+ (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
+ mkDefaultLabel uniq))
- st_alt (con, args, use_mask, _)
- = -- Ha! Nothing to do; Node already points to the thing
- (con_tag,
- (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
+ st_alt con args -- Ha! Nothing to do; Node already points to the thing
+ = (con_tag,
+ (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
[mkIntCLit (length args)], -- how big the thing in the heap is
join_label)
)
where
- con_tag = dataConTag con
- join_label = mkAltLabel uniq con_tag
+ con_tag = dataConTag con
+ join_label = mkAltLabel uniq con_tag
+
+
+tagToClosure :: TyCon -> CAddrMode -> CAddrMode
+-- Primops returning an enumeration type (notably Bool)
+-- actually return an index into
+-- the table of closures for the enumeration type
+tagToClosure tycon tag_amode
+ = CVal (CIndex closure_tbl tag_amode PtrRep) PtrRep
+ where
+ closure_tbl = CLbl (mkClosureTblLabel tycon) PtrRep
\end{code}
%************************************************************************
%* *
%************************************************************************
-@cgPrimEvalAlts@ and @cgPrimInlineAlts@ generate suitable @CSwitch@es
+@cgPrimAlts@ generates suitable a @CSwitch@
for dealing with the alternatives of a primitive @case@, given an
addressing mode for the thing to scrutinise. It also keeps track of
the maximum stack depth encountered down any branch.
As usual, no binders in the alternatives are yet bound.
\begin{code}
-cgPrimInlineAlts bndr ty alts deflt
- = cgPrimAltsWithDefault bndr NoGC (CTemp uniq kind) alts deflt []
- where
- uniq = getUnique bndr
- kind = typePrimRep ty
-
-cgPrimEvalAlts bndr ty alts deflt
- = cgPrimAltsWithDefault bndr GCMayHappen (CReg reg) alts deflt [reg]
- where
- reg = WARN( case kind of { PtrRep -> True; other -> False }, text "cgPrimEE" <+> ppr bndr <+> ppr ty )
- dataReturnConvPrim kind
- kind = typePrimRep ty
-
-cgPrimAltsWithDefault bndr gc_flag scrutinee alts deflt regs
- = -- first bind the default if necessary
- bindNewPrimToAmode bndr scrutinee `thenC`
- cgPrimAlts gc_flag scrutinee alts deflt regs
-
-cgPrimAlts gc_flag scrutinee alts deflt regs
- = forkAlts (map (cgPrimAlt gc_flag regs) alts)
- (cgPrimDefault gc_flag regs deflt)
- `thenFC` \ (alt_absCs, deflt_absC) ->
-
+cgPrimAlts :: GCFlag
+ -> CAddrMode -- Scrutinee
+ -> [StgAlt] -- Alternatives
+ -> AltType
+ -> Code
+-- INVARIANT: the default binder is already bound
+cgPrimAlts gc_flag scrutinee alts alt_type
+ = forkAlts (map (cgPrimAlt gc_flag alt_type) alts) `thenFC` \ tagged_absCs ->
+ let
+ ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default
+ alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
+ in
absC (CSwitch scrutinee alt_absCs deflt_absC)
-- CSwitch does sensible things with one or zero alternatives
-
cgPrimAlt :: GCFlag
- -> [MagicId] -- live registers
- -> (Literal, StgExpr) -- The alternative
- -> FCode (Literal, AbstractC) -- Its compiled form
-
-cgPrimAlt gc_flag regs (lit, rhs)
- = getAbsC rhs_code `thenFC` \ absC ->
- returnFC (lit,absC)
- where
- rhs_code = possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs)
-
-cgPrimDefault :: GCFlag
- -> [MagicId] -- live registers
- -> StgCaseDefault
- -> FCode AbstractC
-
-cgPrimDefault gc_flag regs StgNoDefault
- = panic "cgPrimDefault: No default in prim case"
-
-cgPrimDefault gc_flag regs (StgBindDefault rhs)
- = getAbsC (possibleHeapCheck gc_flag False regs [] Nothing (cgExpr rhs))
+ -> AltType
+ -> StgAlt -- The alternative
+ -> FCode (AltCon, AbstractC) -- Its compiled form
+
+cgPrimAlt gc_flag alt_type (con, [], [], rhs)
+ = ASSERT( case con of { DEFAULT -> True; LitAlt _ -> True; other -> False } )
+ getAbsC (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs)) `thenFC` \ abs_c ->
+ returnFC (con, abs_c)
\end{code}
%************************************************************************
\begin{code}
+maybeAltHeapCheck
+ :: GCFlag
+ -> AltType -- PolyAlt, PrimAlt, AlgAlt, but *not* UbxTupAlt
+ -> Code -- Continuation
+ -> Code
+maybeAltHeapCheck NoGC _ code = code
+maybeAltHeapCheck GCMayHappen alt_type code
+ = -- HWL: maybe need yield here
+ -- yield [node] True -- XXX live regs wrong
+ altHeapCheck alt_type code
+
saveVolatileVarsAndRegs
:: StgLiveVars -- Vars which should be made safe
-> FCode (AbstractC, -- Assignments to do the saves
EndOfBlockInfo, -- sequel for the alts
Maybe VirtualSpOffset) -- Slot for current cost centre
-
saveVolatileVarsAndRegs vars
= saveVolatileVars vars `thenFC` \ var_saves ->
saveCurrentCostCentre `thenFC` \ (maybe_cc_slot, cc_save) ->
maybe_cc_slot)
-saveVolatileVars :: StgLiveVars -- Vars which should be made safe
+saveVolatileVars :: StgLiveVars -- Vars which should be made safe
-> FCode AbstractC -- Assignments to to the saves
saveVolatileVars vars
returnFC (Just slot,
CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
-restoreCurrentCostCentre :: Maybe VirtualSpOffset -> FCode AbstractC
-restoreCurrentCostCentre Nothing = returnFC AbsCNop
+restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Code
+restoreCurrentCostCentre Nothing = nopC
restoreCurrentCostCentre (Just slot)
= getSpRelOffset slot `thenFC` \ sp_rel ->
freeStackSlots [slot] `thenC`
- returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+ absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
-- we use the RESTORE_CCCS macro, rather than just
- -- assigning into CurCostCentre, in case RESTORE_CCC
+ -- assigning into CurCostCentre, in case RESTORE_CCCS
-- has some sanity-checking in it.
\end{code}
mode for it.
\begin{code}
-mkReturnVector :: Unique
- -> [(ConTag, AbstractC)] -- Branch codes
- -> AbstractC -- Default case
- -> SRT -- continuation's SRT
- -> Liveness -- stack liveness
+mkRetDirectTarget :: Id -- Used for labelling only
+ -> AbstractC -- Return code
+ -> SRT -- Live CAFs in return code
+ -> FCode CAddrMode -- Emit the labelled return block,
+ -- and return its label
+mkRetDirectTarget bndr abs_c srt
+ = buildContLivenessMask bndr `thenFC` \ liveness ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ absC (CRetDirect uniq abs_c srt_info liveness) `thenC`
+ return lbl
+ where
+ name = idName bndr
+ uniq = getUnique name
+ lbl = CLbl (mkReturnInfoLabel uniq) RetRep
+\end{code}
+
+\begin{code}
+mkRetVecTarget :: Id -- Just for its unique
+ -> [(AltCon, AbstractC)] -- Branch codes
+ -> SRT -- Continuation's SRT
-> CtrlReturnConvention
-> FCode CAddrMode
-mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
- = getSRTLabel `thenFC` \srt_label ->
- let
- (return_vec_amode, vtbl_body) = case ret_conv of {
-
- -- might be a polymorphic case...
- UnvectoredReturn 0 ->
- ASSERT(null tagged_alt_absCs)
- (CLbl ret_label RetRep,
- absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
-
- UnvectoredReturn n ->
- -- find the tag explicitly rather than using tag_reg for now.
- -- on architectures with lots of regs the tag will be loaded
- -- into tag_reg by the code doing the returning.
- let
- tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
- in
- (CLbl ret_label RetRep,
- absC (CRetDirect uniq
- (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
- (srt_label, srt)
- liveness));
-
- VectoredReturn table_size ->
- let
- (vector_table, alts_absC) =
- unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
-
- ret_vector = CRetVector vtbl_label
- vector_table
- (srt_label, srt) liveness
- in
- (CLbl vtbl_label DataPtrRep,
- -- alts come first, because we don't want to declare all the symbols
- absC (mkAbstractCs (mkAbstractCs alts_absC : [deflt_absC,ret_vector]))
- )
-
- } in
- vtbl_body `thenC`
- returnFC return_vec_amode
- -- )
+mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn 0)
+ = ASSERT( null other_alts )
+ mkRetDirectTarget bndr deflt_absC srt
where
+ ((DEFAULT, deflt_absC) : other_alts) = tagged_alt_absCs
- vtbl_label = mkVecTblLabel uniq
- ret_label = mkReturnInfoLabel uniq
-
- deflt_lbl =
- case nonemptyAbsC deflt_absC of
- -- the simplifier might have eliminated a case
- Nothing -> mkIntCLit 0 -- CLbl mkErrorStdEntryLabel CodePtrRep
- Just absC@(CCodeBlock lbl _) -> CLbl lbl CodePtrRep
+mkRetVecTarget bndr tagged_alt_absCs srt (UnvectoredReturn n)
+ = mkRetDirectTarget bndr switch_absC srt
+ where
+ -- Find the tag explicitly rather than using tag_reg for now.
+ -- on architectures with lots of regs the tag will be loaded
+ -- into tag_reg by the code doing the returning.
+ tag = CMacroExpr WordRep GET_TAG [CVal (nodeRel 0) DataPtrRep]
+ switch_absC = mkAlgAltsCSwitch tag tagged_alt_absCs
+
+
+mkRetVecTarget bndr tagged_alt_absCs srt (VectoredReturn table_size)
+ = buildContLivenessMask bndr `thenFC` \ liveness ->
+ getSRTInfo name srt `thenFC` \ srt_info ->
+ let
+ ret_vector = CRetVector vtbl_lbl vector_table srt_info liveness
+ in
+ absC (mkAbstractCs alts_absCs `mkAbsCStmts` ret_vector) `thenC`
+ -- Alts come first, because we don't want to declare all the symbols
- mk_vector_entry :: ConTag -> (CAddrMode, AbstractC)
+ return (CLbl vtbl_lbl DataPtrRep)
+ where
+ tags = [fIRST_TAG .. (table_size+fIRST_TAG-1)]
+ vector_table = map mk_vector_entry tags
+ alts_absCs = map snd (sortBy cmp tagged_alt_absCs)
+ -- The sort is unnecessary; just there for now
+ -- to make the new order the same as the old
+ (DEFAULT,_) `cmp` (DEFAULT,_) = EQ
+ (DEFAULT,_) `cmp` _ = GT
+ (DataAlt d1,_) `cmp` (DataAlt d2,_) = dataConTag d1 `compare` dataConTag d2
+ (DataAlt d1,_) `cmp` (DEFAULT, _) = LT
+ -- Others impossible
+
+ name = idName bndr
+ uniq = getUnique name
+ vtbl_lbl = mkVecTblLabel uniq
+
+ deflt_lbl :: CAddrMode
+ deflt_lbl = case tagged_alt_absCs of
+ (DEFAULT, abs_c) : _ -> get_block_label abs_c
+ other -> mkIntCLit 0
+ -- 'other' case: the simplifier might have eliminated a case
+ -- so we may have e.g. case xs of
+ -- [] -> e
+ -- In that situation the default should never be taken,
+ -- so we just use '0' (=> seg fault if used)
+
+ mk_vector_entry :: ConTag -> CAddrMode
mk_vector_entry tag
- = case [ absC | (t, absC) <- tagged_alt_absCs, t == tag ] of
- [] -> (deflt_lbl, AbsCNop)
- [absC@(CCodeBlock lbl _)] -> (CLbl lbl CodePtrRep,absC)
- _ -> panic "mkReturnVector: too many"
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgCase-utils]{Utilities for handling case expressions}
-%* *
-%************************************************************************
+ = case [ absC | (DataAlt d, absC) <- tagged_alt_absCs, dataConTag d == tag ] of
+ -- The comprehension neatly, and correctly, ignores the DEFAULT
+ [] -> deflt_lbl
+ [abs_c] -> get_block_label abs_c
+ _ -> panic "mkReturnVector: too many"
-@possibleHeapCheck@ tests a flag passed in to decide whether to do a
-heap check or not. These heap checks are always in a case
-alternative, so we use altHeapCheck.
-
-\begin{code}
-possibleHeapCheck
- :: GCFlag
- -> Bool -- True <=> algebraic case
- -> [MagicId] -- live registers
- -> [(VirtualSpOffset,Int)] -- stack slots to tag
- -> Maybe Unique -- return address unique
- -> Code -- continuation
- -> Code
-
-possibleHeapCheck GCMayHappen is_alg regs tags lbl code
- = altHeapCheck is_alg regs tags AbsCNop lbl code
-possibleHeapCheck NoGC _ _ tags lbl code
- = code
-\end{code}
-
-\begin{code}
-getScrutineeTyCon :: Type -> Maybe TyCon
-getScrutineeTyCon ty =
- case splitTyConApp_maybe (repType ty) of
- Nothing -> Nothing
- Just (tc,_) ->
- if isFunTyCon tc then Nothing else -- not interested in funs
- if isPrimTyCon tc then Just tc else -- return primitive tycons
- -- otherwise (algebraic tycons) check the no. of constructors
- Just tc
+ get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep
\end{code}