%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgCase.lhs,v 1.75 2005/06/21 10:44:41 simonmar Exp $
-%
-%********************************************************
-%* *
-\section[CgCase]{Converting @StgCase@ expressions}
-%* *
-%********************************************************
\begin{code}
module CgCase ( cgCase, saveVolatileVarsAndRegs,
import {-# SOURCE #-} CgExpr ( cgExpr )
import CgMonad
-import StgSyn
-import CgBindery ( getArgAmodes,
- bindNewToReg, bindNewToTemp,
- getCgIdInfo, getArgAmode,
- rebindToStack, getCAddrModeIfVolatile,
- nukeDeadBindings, idInfoToAmode
- )
-import CgCon ( bindConArgs, bindUnboxedTupleComponents )
-import CgHeapery ( altHeapCheck, unbxTupleHeapCheck )
-import CgCallConv ( dataReturnConvPrim, ctrlReturnConvAlg,
- CtrlReturnConvention(..)
- )
-import CgStackery ( allocPrimStack, allocStackTop, getSpRelOffset,
- deAllocStackTop, freeStackSlots
- )
-import CgTailCall ( performTailCall )
-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 CgBindery
+import CgCon
+import CgHeapery
+import CgCallConv
+import CgStackery
+import CgTailCall
+import CgPrimOp
+import CgForeignCall
+import CgUtils
+import CgProf
+import CgInfoTbls
+
+import ClosureInfo
+import SMRep
+import CmmUtils
import Cmm
-import MachOp ( wordRep )
-import ClosureInfo ( mkLFArgument )
-import StaticFlags ( opt_SccProfilingOn )
-import Id ( Id, idName, isDeadBinder, idType )
-import ForeignCall ( ForeignCall(..), CCallSpec(..), playSafe )
-import VarSet ( varSetElems )
-import CoreSyn ( AltCon(..) )
-import PrimOp ( PrimOp(..), primOpOutOfLine )
-import TyCon ( isEnumerationTyCon, tyConFamilySize )
-import Util ( isSingleton )
+import MachOp
+
+import StgSyn
+import StaticFlags
+import Id
+import ForeignCall
+import VarSet
+import CoreSyn
+import PrimOp
+import TyCon
+import Util
import Outputable
\end{code}
(do { deAllocStackTop retAddrSizeW
; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
- ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)
+ ; setEndOfBlockInfo scrut_eob_info
(performTailCall fun_info arg_amodes save_assts) }
\end{code}
(do { deAllocStackTop retAddrSizeW
; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
- ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)
- (cgExpr expr)
+ ; setEndOfBlockInfo scrut_eob_info (cgExpr expr)
}
\end{code}
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 bndr _))
- = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True)
-maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
-\end{code}
-
-
%************************************************************************
%* *
Inline primops
; restoreCurrentCostCentre cc_slot True
; cgPrimAlts GCMayHappen alt_type reg alts }
- ; lbl <- emitDirectReturnTarget (idName bndr) abs_c srt
- ; returnFC (CaseAlts lbl Nothing bndr False) }
+ ; lbl <- emitReturnTarget (idName bndr) abs_c srt
+ ; returnFC (CaseAlts lbl Nothing bndr) }
cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
= -- Unboxed tuple case
ASSERT2( case con of { DataAlt _ -> True; other -> False },
text "cgEvalAlts: dodgy case of unboxed tuple type" )
do { -- forkAbsC for the RHS, so that the envt is
- -- not changed for the emitDirectReturn call
+ -- not changed for the emitReturn call
abs_c <- forkProc $ do
{ (live_regs, ptrs, nptrs, _) <- bindUnboxedTupleComponents args
-- Restore the CC *after* binding the tuple components,
-- 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) }
+ ; lbl <- emitReturnTarget (idName bndr) abs_c srt
+ ; returnFC (CaseAlts lbl Nothing bndr) }
cgEvalAlts cc_slot bndr srt alt_type alts
= -- Algebraic and polymorphic case
; (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot alt_type alts
; (lbl, branches) <- emitAlgReturnTarget (idName bndr)
- alts mb_deflt srt ret_conv
+ alts mb_deflt srt fam_sz
- ; returnFC (CaseAlts lbl branches bndr False) }
+ ; returnFC (CaseAlts lbl branches bndr) }
where
- ret_conv = case alt_type of
- AlgAlt tc -> ctrlReturnConvAlg tc
- PolyAlt -> UnvectoredReturn 0
+ fam_sz = case alt_type of
+ AlgAlt tc -> tyConFamilySize tc
+ PolyAlt -> 0
\end{code}