Remove vectored returns.

[ghc-hetmet.git] / compiler / codeGen / CgCase.lhs

diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index 7b4861a..b8f3141 100644 (file)
--- a/compiler/codeGen/CgCase.lhs
+++ b/compiler/codeGen/CgCase.lhs
@@ -1,13 +1,7 @@
 %
+% (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, 
@@ -19,43 +13,33 @@ 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}
 
@@ -213,7 +197,7 @@ cgCase (StgApp fun args)
                        (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}
 
@@ -250,8 +234,7 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
                           (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}
 
@@ -281,13 +264,6 @@ 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 bndr _))
-   = EndOfBlockInfo (args_sp + retAddrSizeW) (CaseAlts amode stuff bndr True)
-maybeReserveSeqFrame other scrut_eob_info = scrut_eob_info
-\end{code}
-
-
 %************************************************************************
 %*                                                                     *
                Inline primops
@@ -396,8 +372,8 @@ cgEvalAlts cc_slot bndr srt alt_type@(PrimAlt tycon) alts
                ; 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
@@ -408,7 +384,7 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
     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, 
@@ -418,8 +394,8 @@ cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
                        -- 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
@@ -438,13 +414,13 @@ cgEvalAlts cc_slot bndr srt alt_type alts
        ; (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}