%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.68 2004/08/10 09:02:38 simonmar Exp $
+% $Id: CgCase.lhs,v 1.69 2004/08/13 13:05:51 simonmar Exp $
%
%********************************************************
%* *
\begin{code}
module CgCase ( cgCase, saveVolatileVarsAndRegs,
- mkRetDirectTarget, restoreCurrentCostCentre
+ restoreCurrentCostCentre
) where
#include "HsVersions.h"
import CgMonad
import StgSyn
-import AbsCSyn
-
-import AbsCUtils ( mkAbstractCs, mkAbsCStmts, mkAlgAltsCSwitch,
- getAmodeRep, shimFCallArg )
-import CgBindery ( getVolatileRegs, getArgAmodes,
+import CgBindery ( getArgAmodes,
bindNewToReg, bindNewToTemp,
- getCAddrModeAndInfo,
- rebindToStack, getCAddrMode, getCAddrModeIfVolatile,
- buildContLivenessMask, nukeDeadBindings,
+ getCgIdInfo, getArgAmode,
+ rebindToStack, getCAddrModeIfVolatile,
+ nukeDeadBindings, idInfoToAmode
)
import CgCon ( bindConArgs, bindUnboxedTupleComponents )
import CgHeapery ( altHeapCheck, unbxTupleHeapCheck )
-import CgRetConv ( dataReturnConvPrim, ctrlReturnConvAlg,
+import CgCallConv ( dataReturnConvPrim, ctrlReturnConvAlg,
CtrlReturnConvention(..)
)
-import CgStackery ( allocPrimStack, allocStackTop,
- deAllocStackTop, freeStackSlots, dataStackSlots
+import CgStackery ( allocPrimStack, allocStackTop, getSpRelOffset,
+ deAllocStackTop, freeStackSlots
)
import CgTailCall ( performTailCall )
-import CgUsages ( getSpRelOffset )
-import CLabel ( mkVecTblLabel, mkClosureTblLabel,
- mkDefaultLabel, mkAltLabel, mkReturnInfoLabel
- )
+import CgPrimOp ( cgPrimOp )
+import CgForeignCall ( cgForeignCall )
+import CgUtils ( newTemp, cgLit, emitLitSwitch, emitSwitch,
+ tagToClosure )
+import CgProf ( curCCS, curCCSAddr )
+import CgInfoTbls ( emitDirectReturnTarget, emitAlgReturnTarget,
+ dataConTagZ )
+import SMRep ( CgRep(..), retAddrSizeW, nonVoidArg, isVoidArg,
+ idCgRep, tyConCgRep, typeHint )
+import CmmUtils ( CmmStmts, noStmts, oneStmt, plusStmts )
+import Cmm
+import MachOp ( wordRep )
import ClosureInfo ( mkLFArgument )
import CmdLineOpts ( opt_SccProfilingOn )
-import Id ( Id, idName, isDeadBinder )
-import DataCon ( dataConTag, fIRST_TAG, ConTag )
+import Id ( Id, idName, isDeadBinder, idType )
+import ForeignCall ( ForeignCall(..), CCallSpec(..), playSafe )
import VarSet ( varSetElems )
import CoreSyn ( AltCon(..) )
-import PrimOp ( primOpOutOfLine, PrimOp(..) )
-import PrimRep ( getPrimRepSize, retPrimRepSize, PrimRep(..)
- )
-import TyCon ( TyCon, isEnumerationTyCon, tyConPrimRep )
-import Unique ( Unique, Uniquable(..), newTagUnique )
-import ForeignCall
-import Util ( only )
-import List ( sortBy )
+import PrimOp ( PrimOp(..), primOpOutOfLine )
+import TyCon ( isEnumerationTyCon, tyConFamilySize )
+import Util ( isSingleton )
import Outputable
\end{code}
\begin{code}
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
+ alt_type@(PrimAlt tycon) alts
+ = do { tmp_reg <- bindNewToTemp bndr
+ ; cm_lit <- cgLit lit
+ ; stmtC (CmmAssign tmp_reg (CmmLit cm_lit))
+ ; cgPrimAlts NoGC alt_type tmp_reg alts }
\end{code}
Special case #2: scrutinising a primitive-typed variable. No
\begin{code}
cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
alt_type@(PrimAlt tycon) alts
-
- = -- 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
+ = do { -- 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.
+ v_info <- getCgIdInfo v
+ ; amode <- idInfoToAmode v_info
+ ; tmp_reg <- bindNewToTemp bndr
+ ; stmtC (CmmAssign tmp_reg amode)
+ ; cgPrimAlts NoGC alt_type tmp_reg alts }
\end{code}
Special case #3: inline PrimOps and foreign calls.
\begin{code}
cgCase (StgOpApp op args _)
live_in_whole_case live_in_alts bndr srt alt_type alts
- | inline_primop
- = -- Get amodes for the arguments and results
- getArgAmodes args `thenFC` \ arg_amodes1 ->
- let
- arg_amodes
- | StgFCallOp{} <- op = zipWith shimFCallArg args arg_amodes1
- | otherwise = arg_amodes1
- in
- getVolatileRegs live_in_alts `thenFC` \ vol_regs ->
-
- 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
- | StgPrimOp primop <- op
- -> ASSERT( isEnumerationTyCon tycon )
- let
- 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)
- in
- 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)
-
- other -> pprPanic "cgCase: case of primop has strange alt type" (ppr alt_type)
- where
- inline_primop = case op of
- StgPrimOp primop -> not (primOpOutOfLine primop)
- --StgFCallOp (CCall (CCallSpec _ _ PlayRisky)) _ -> True
- -- unsafe foreign calls are "inline"
- _otherwise -> False
-
+ | not (primOpOutOfLine primop)
+ = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
\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).
+Special case #4: inline foreign calls: an unsafe foreign call can be done
+right here, just like an inline primop.
+
+\begin{code}
+cgCase (StgOpApp op@(StgFCallOp fcall _) args _)
+ live_in_whole_case live_in_alts bndr srt alt_type alts
+ | unsafe_foreign_call
+ = ASSERT( isSingleton alts )
+ do -- *must* be an unboxed tuple alt.
+ -- exactly like the cgInlinePrimOp case for unboxed tuple alts..
+ { res_tmps <- mapFCs bindNewToTemp non_void_res_ids
+ ; let res_hints = map (typeHint.idType) non_void_res_ids
+ ; cgForeignCall (zip res_tmps res_hints) fcall args live_in_alts
+ ; cgExpr rhs }
+ where
+ (_, res_ids, _, rhs) = head alts
+ non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
+
+ unsafe_foreign_call
+ = case fcall of
+ CCall (CCallSpec _ _ s) -> not (playSafe s)
+ _other -> False
+\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 alt_type alts
- = getCAddrModeAndInfo fun `thenFC` \ (fun', fun_amode, lf_info) ->
- getArgAmodes args `thenFC` \ arg_amodes ->
+ = do { fun_info <- getCgIdInfo fun
+ ; arg_amodes <- getArgAmodes args
-- Nuking dead bindings *before* calculating the saves is the
-- value-add here. We might end up freeing up some slots currently
-- 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) ->
-
- forkEval alts_eob_info
- ( allocStackTop retPrimRepSize
- `thenFC` \_ -> nopC )
- ( deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alt_type alts )
- `thenFC` \ scrut_eob_info ->
-
- setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
- performTailCall fun' fun_amode lf_info arg_amodes save_assts
+ ; nukeDeadBindings live_in_alts
+ ; (save_assts, alts_eob_info, maybe_cc_slot)
+ <- saveVolatileVarsAndRegs live_in_alts
+
+ ; scrut_eob_info
+ <- forkEval alts_eob_info
+ (allocStackTop retAddrSizeW >> nopC)
+ (do { deAllocStackTop retAddrSizeW
+ ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+
+ ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)
+ (performTailCall fun_info arg_amodes save_assts) }
\end{code}
Note about return addresses: we *always* push a return address, even
\begin{code}
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`
+ = do { -- Figure out what volatile variables to save
+ nukeDeadBindings live_in_whole_case
- saveVolatileVarsAndRegs live_in_alts
- `thenFC` \ (save_assts, alts_eob_info, maybe_cc_slot) ->
-
- -- Save those variables right now!
- absC save_assts `thenC`
-
- -- generate code for the alts
- forkEval alts_eob_info
- (nukeDeadBindings live_in_alts `thenC`
- allocStackTop retPrimRepSize -- space for retn address
- `thenFC` \_ -> nopC
- )
- (deAllocStackTop retPrimRepSize `thenFC` \_ ->
- cgEvalAlts maybe_cc_slot bndr srt alt_type alts) `thenFC` \ scrut_eob_info ->
-
- setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info) $
- cgExpr expr
+ ; (save_assts, alts_eob_info, maybe_cc_slot)
+ <- saveVolatileVarsAndRegs live_in_alts
+
+ -- Save those variables right now!
+ ; emitStmts save_assts
+
+ -- generate code for the alts
+ ; scrut_eob_info
+ <- forkEval alts_eob_info
+ (do { nukeDeadBindings live_in_alts
+ ; allocStackTop retAddrSizeW -- space for retn address
+ ; nopC })
+ (do { deAllocStackTop retAddrSizeW
+ ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+
+ ; 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
TODO!! Problem: however, we have to save the current cost centre
stack somewhere, because at the eval point the current CCS might be
-different. So we pick a free stack slot and save CCCS in it. The
-problem with this is that this slot isn't recorded as free/unboxed in
-the environment, so a case expression in the scrutinee will have the
-wrong bitmap attached. Fortunately we don't ever seem to see
-case-of-case at the back end. One solution might be to shift the
-saved CCS to the correct place in the activation record just before
-the jump.
- --SDM
-
-(one consequence of the above is that activation records on the stack
-don't follow the layout of closures when we're profiling. The CCS
-could be anywhere within the record).
+different. So we pick a free stack slot and save CCCS in it. One
+consequence of this is that activation records on the stack don't
+follow the layout of closures when we're profiling. The CCS could be
+anywhere within the record).
\begin{code}
-maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff _))
- = EndOfBlockInfo (args_sp + retPrimRepSize) (CaseAlts amode stuff True)
+maybeReserveSeqFrame PolyAlt (EndOfBlockInfo args_sp (CaseAlts amode stuff bndr _))
+ = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True)
maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
\end{code}
+
+%************************************************************************
+%* *
+ Inline primops
+%* *
+%************************************************************************
+
+\begin{code}
+cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
+ | isVoidArg (idCgRep bndr)
+ = ASSERT( con == DEFAULT && isSingleton alts && null bs )
+ do { -- VOID RESULT; just sequencing,
+ -- so get in there and do it
+ cgPrimOp [] primop args live_in_alts
+ ; cgExpr rhs }
+ where
+ (con,bs,_,rhs) = head alts
+
+cgInlinePrimOp primop args bndr (PrimAlt tycon) live_in_alts alts
+ = do { -- PRIMITIVE ALTS, with non-void result
+ tmp_reg <- bindNewToTemp bndr
+ ; cgPrimOp [tmp_reg] primop args live_in_alts
+ ; cgPrimAlts NoGC (PrimAlt tycon) tmp_reg alts }
+
+cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts
+ = ASSERT( isSingleton alts )
+ do { -- 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
+
+ res_tmps <- mapFCs bindNewToTemp non_void_res_ids
+ ; cgPrimOp res_tmps primop args live_in_alts
+ ; cgExpr rhs }
+ where
+ (_, res_ids, _, rhs) = head alts
+ non_void_res_ids = filter (nonVoidArg . idCgRep) res_ids
+
+cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
+ = do { -- ENUMERATION TYPE RETURN
+ -- Typical: case a ># b of { True -> ..; False -> .. }
+ -- The primop itself returns an index into the table of
+ -- closures for the enumeration type.
+ tag_amode <- ASSERT( isEnumerationTyCon tycon )
+ do_enum_primop primop
+
+ -- Bind the default binder if necessary
+ -- (avoiding it avoids the assignment)
+ -- The deadness info is set by StgVarInfo
+ ; whenC (not (isDeadBinder bndr))
+ (do { tmp_reg <- bindNewToTemp bndr
+ ; stmtC (CmmAssign tmp_reg (tagToClosure tycon tag_amode)) })
+
+ -- Compile the alts
+ ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
+ (AlgAlt tycon) alts
+
+ -- Do the switch
+ ; emitSwitch tag_amode branches mb_deflt 0 (tyConFamilySize tycon - 1)
+ }
+ where
+
+ do_enum_primop :: PrimOp -> FCode CmmExpr -- Returns amode for result
+ do_enum_primop TagToEnumOp -- No code!
+ | [arg] <- args = do
+ (_,e) <- getArgAmode arg
+ return e
+ do_enum_primop primop
+ = do tmp <- newTemp wordRep
+ cgPrimOp [tmp] primop args live_in_alts
+ returnFC (CmmReg tmp)
+
+cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
+ = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
+\end{code}
+
%************************************************************************
%* *
\subsection[CgCase-alts]{Alternatives}
-- to be a label so that we can duplicate it
-- without risk of duplicating code
+cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
+ = do { let rep = tyConCgRep tycon
+ reg = dataReturnConvPrim rep -- Bottom for voidRep
+
+ ; abs_c <- forkProc $ do
+ { -- Bind the case binder, except if it's void
+ -- (reg is bottom in that case)
+ whenC (nonVoidArg rep) $
+ bindNewToReg bndr reg (mkLFArgument bndr)
+ ; restoreCurrentCostCentre cc_slot True
+ ; cgPrimAlts GCMayHappen alt_type reg alts }
+
+ ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt
+ ; returnFC (CaseAlts lbl Nothing bndr False) }
+
cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
= -- Unboxed tuple case
-- By now, the simplifier should have have turned it
-- 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
- bindUnboxedTupleComponents args `thenFC` \ (live_regs, ptrs, nptrs, _) ->
- -- restore the CC *after* binding the tuple components, so that we
- -- get the stack offset of the saved CC right.
- restoreCurrentCostCentre cc_slot True `thenC`
- -- 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 True `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
+ do { -- forkAbsC for the RHS, so that the envt is
+ -- not changed for the emitDirectReturn call
+ abs_c <- forkProc $ do
+ { (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args
+ -- Restore the CC *after* binding the tuple components,
+ -- so that we get the stack offset of the saved CC right.
+ ; restoreCurrentCostCentre cc_slot True
+ -- Generate a heap check if necessary
+ -- and finally the code for the alternative
+ ; unbxTupleHeapCheck live_regs ptrs nptrs noStmts
+ (cgExpr rhs) }
+ ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt
+ ; returnFC (CaseAlts lbl Nothing bndr False) }
cgEvalAlts cc_slot bndr srt alt_type alts
= -- Algebraic and polymorphic case
- -- Bind the default binder
- bindNewToReg bndr node (mkLFArgument bndr) `thenC`
+ do { -- Bind the default binder
+ bindNewToReg bndr nodeReg (mkLFArgument bndr)
-- 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 ret_conv = case alt_type of
- AlgAlt tc -> ctrlReturnConvAlg tc
- PolyAlt -> UnvectoredReturn 0
-
- use_labelled_alts = case ret_conv of
- VectoredReturn _ -> True
- _ -> False
-
- 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 ->
+ ; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
- mkRetVecTarget bndr tagged_alt_absCs
- srt ret_conv `thenFC` \ return_vec ->
+ ; (lbl, branches) <- emitAlgReturnTarget (idName bndr)
+ alts mb_deflt srt ret_conv
- returnFC (CaseAlts return_vec semi_tagged_stuff False)
+ ; returnFC (CaseAlts lbl branches bndr False) }
+ where
+ ret_conv = case alt_type of
+ AlgAlt tc -> ctrlReturnConvAlg tc
+ PolyAlt -> UnvectoredReturn 0
\end{code}
\begin{code}
cgAlgAlts :: GCFlag
- -> 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
+ -> AltType -- ** AlgAlt or PolyAlt only **
+ -> [StgAlt] -- The alternatives
+ -> FCode ( [(ConTagZ, CgStmts)], -- The branches
+ Maybe CgStmts ) -- The default case
+
+cgAlgAlts gc_flag cc_slot alt_type alts
+ = do alts <- forkAlts [ cgAlgAlt gc_flag cc_slot alt_type alt | alt <- alts]
+ let
+ mb_deflt = case alts of -- DEFAULT is always first, if present
+ ((DEFAULT,blks) : _) -> Just blks
+ other -> Nothing
+
+ branches = [(dataConTagZ con, blks)
+ | (DataAlt con, blks) <- alts]
+ -- in
+ return (branches, mb_deflt)
-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
- -> AltType -- ** AlgAlt or PolyAlt only **
+ -> Maybe VirtualSpOffset -- 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 True `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 (con, final_abs_c)
+ -> FCode (AltCon, CgStmts)
+
+cgAlgAlt gc_flag cc_slot alt_type (con, args, use_mask, rhs)
+ = do { abs_c <- getCgStmts $ do
+ { bind_con_args con args
+ ; restoreCurrentCostCentre cc_slot True
+ ; maybeAltHeapCheck gc_flag alt_type (cgExpr rhs) }
+ ; return (con, abs_c) }
where
- 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}
-%************************************************************************
-%* *
-\subsection[CgCase-semi-tagged-alts]{The code to deal with sem-tagging}
-%* *
-%************************************************************************
-
-Turgid-but-non-monadic code to conjure up the required info from
-algebraic case alternatives for semi-tagging.
-
-\begin{code}
-cgSemiTaggedAlts :: Bool -- True <=> use semitagging: each alt will be labelled
- -> Id
- -> [StgAlt]
- -> SemiTaggingStuff
-
-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 = (binder,
- (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
- mkDefaultLabel uniq))
-
- 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
-
-
-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}
%************************************************************************
%* *
\begin{code}
cgPrimAlts :: GCFlag
- -> CAddrMode -- Scrutinee
+ -> AltType -- Always PrimAlt, but passed to maybeAltHeapCheck
+ -> CmmReg -- Scrutinee
-> [StgAlt] -- Alternatives
- -> AltType
-> Code
+-- NB: cgPrimAlts emits code that does the case analysis.
+-- It's often used in inline situations, rather than to genearte
+-- a labelled return point. That's why its interface is a little
+-- different to cgAlgAlts
+--
-- 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
+cgPrimAlts gc_flag alt_type scrutinee alts
+ = do { tagged_absCs <- forkAlts (map (cgPrimAlt gc_flag alt_type) alts)
+ ; let ((DEFAULT, deflt_absC) : others) = tagged_absCs -- There is always a default
+ alt_absCs = [(lit,rhs) | (LitAlt lit, rhs) <- others]
+ ; emitLitSwitch (CmmReg scrutinee) alt_absCs deflt_absC }
cgPrimAlt :: GCFlag
-> AltType
- -> StgAlt -- The alternative
- -> FCode (AltCon, AbstractC) -- Its compiled form
+ -> StgAlt -- The alternative
+ -> FCode (AltCon, CgStmts) -- 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)
+ do { abs_c <- getCgStmts (maybeAltHeapCheck gc_flag alt_type (cgExpr rhs))
+ ; returnFC (con, abs_c) }
\end{code}
-> 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
+maybeAltHeapCheck GCMayHappen alt_type code = altHeapCheck alt_type code
saveVolatileVarsAndRegs
:: StgLiveVars -- Vars which should be made safe
- -> FCode (AbstractC, -- Assignments to do the saves
+ -> FCode (CmmStmts, -- 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) ->
- getEndOfBlockInfo `thenFC` \ eob_info ->
- returnFC (mkAbstractCs [var_saves, cc_save],
- eob_info,
- maybe_cc_slot)
+ = do { var_saves <- saveVolatileVars vars
+ ; (maybe_cc_slot, cc_save) <- saveCurrentCostCentre
+ ; eob_info <- getEndOfBlockInfo
+ ; returnFC (var_saves `plusStmts` cc_save,
+ eob_info,
+ maybe_cc_slot) }
saveVolatileVars :: StgLiveVars -- Vars which should be made safe
- -> FCode AbstractC -- Assignments to to the saves
+ -> FCode CmmStmts -- Assignments to to the saves
saveVolatileVars vars
- = save_em (varSetElems vars)
+ = do { stmts_s <- mapFCs save_it (varSetElems vars)
+ ; return (foldr plusStmts noStmts stmts_s) }
where
- save_em [] = returnFC AbsCNop
-
- save_em (var:vars)
- = getCAddrModeIfVolatile var `thenFC` \ v ->
- case v of
- Nothing -> save_em vars -- Non-volatile, so carry on
-
-
- Just vol_amode -> -- Aha! It's volatile
- save_var var vol_amode `thenFC` \ abs_c ->
- save_em vars `thenFC` \ abs_cs ->
- returnFC (abs_c `mkAbsCStmts` abs_cs)
+ save_it var
+ = do { v <- getCAddrModeIfVolatile var
+ ; case v of
+ Nothing -> return noStmts -- Non-volatile
+ Just vol_amode -> save_var var vol_amode -- Aha! It's volatile
+ }
save_var var vol_amode
- = allocPrimStack (getPrimRepSize kind) `thenFC` \ slot ->
- rebindToStack var slot `thenC`
- getSpRelOffset slot `thenFC` \ sp_rel ->
- returnFC (CAssign (CVal sp_rel kind) vol_amode)
- where
- kind = getAmodeRep vol_amode
+ = do { slot <- allocPrimStack (idCgRep var)
+ ; rebindToStack var slot
+ ; sp_rel <- getSpRelOffset slot
+ ; returnFC (oneStmt (CmmStore sp_rel vol_amode)) }
\end{code}
---------------------------------------------------------------------------
\begin{code}
saveCurrentCostCentre ::
FCode (Maybe VirtualSpOffset, -- Where we decide to store it
- AbstractC) -- Assignment to save it
+ CmmStmts) -- Assignment to save it
saveCurrentCostCentre
- = if not opt_SccProfilingOn then
- returnFC (Nothing, AbsCNop)
- else
- allocPrimStack (getPrimRepSize CostCentreRep) `thenFC` \ slot ->
- dataStackSlots [slot] `thenC`
- getSpRelOffset slot `thenFC` \ sp_rel ->
- returnFC (Just slot,
- CAssign (CVal sp_rel CostCentreRep) (CReg CurCostCentre))
+ | not opt_SccProfilingOn
+ = returnFC (Nothing, noStmts)
+ | otherwise
+ = do { slot <- allocPrimStack PtrArg
+ ; sp_rel <- getSpRelOffset slot
+ ; returnFC (Just slot,
+ oneStmt (CmmStore sp_rel curCCS)) }
-- Sometimes we don't free the slot containing the cost centre after restoring it
-- (see CgLetNoEscape.cgLetNoEscapeBody).
restoreCurrentCostCentre :: Maybe VirtualSpOffset -> Bool -> Code
restoreCurrentCostCentre Nothing _freeit = nopC
restoreCurrentCostCentre (Just slot) freeit
- = getSpRelOffset slot `thenFC` \ sp_rel ->
- (if freeit then freeStackSlots [slot] else nopC) `thenC`
- absC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
- -- we use the RESTORE_CCCS macro, rather than just
- -- assigning into CurCostCentre, in case RESTORE_CCCS
- -- has some sanity-checking in it.
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[CgCase-return-vec]{Building a return vector}
-%* *
-%************************************************************************
-
-Build a return vector, and return a suitable label addressing
-mode for it.
-
-\begin{code}
-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
+ = do { sp_rel <- getSpRelOffset slot
+ ; whenC freeit (freeStackSlots [slot])
+ ; stmtC (CmmStore curCCSAddr (CmmLoad sp_rel wordRep)) }
\end{code}
-\begin{code}
-mkRetVecTarget :: Id -- Just for its unique
- -> [(AltCon, AbstractC)] -- Branch codes
- -> SRT -- Continuation's SRT
- -> CtrlReturnConvention
- -> FCode CAddrMode
-
-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
-
-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
-
- 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 | (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"
-
- get_block_label (CCodeBlock lbl _) = CLbl lbl CodePtrRep
-\end{code}
projects / ghc-hetmet.git / blobdiff