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
 %
 % (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, 
 
 \begin{code}
 module CgCase (        cgCase, saveVolatileVarsAndRegs, 

@@ -19,43 +13,33 @@ module CgCase (     cgCase, saveVolatileVarsAndRegs,
 import {-# SOURCE #-} CgExpr  ( cgExpr )
 
 import CgMonad
 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 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}
 
 import Outputable
 \end{code}
 

@@ -213,7 +197,7 @@ cgCase (StgApp fun args)
                        (do { deAllocStackTop retAddrSizeW
                            ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
 
                        (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}
 
                            (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 })
 
                           (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}
 
     }
 \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).
 
 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
 %************************************************************************
 %*                                                                     *
                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 }
 
                ; 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
 
 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
     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, 
          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) }
                        -- 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
 
 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) <- 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
   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}
 
 
 \end{code}