Fix CodingStyle#Warnings URLs

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

diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index 7b4861a..398441e 100644 (file)
--- a/compiler/codeGen/CgCase.lhs
+++ b/compiler/codeGen/CgCase.lhs
@@ -1,15 +1,16 @@
 %
 %

+% (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}
 
 \begin{code}

+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
+-- for details
+

 module CgCase (        cgCase, saveVolatileVarsAndRegs, 
                restoreCurrentCostCentre
        ) where
 module CgCase (        cgCase, saveVolatileVarsAndRegs, 
                restoreCurrentCostCentre
        ) where

@@ -19,43 +20,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}
 

@@ -111,7 +102,6 @@ cgCase      :: StgExpr
        -> StgLiveVars
        -> StgLiveVars
        -> Id
        -> StgLiveVars
        -> StgLiveVars
        -> Id

-       -> SRT

        -> AltType
        -> [StgAlt]
        -> Code
        -> AltType
        -> [StgAlt]
        -> Code

@@ -120,12 +110,12 @@ cgCase    :: StgExpr
 Special case #1: case of literal.
 
 \begin{code}
 Special case #1: case of literal.
 
 \begin{code}

-cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt 
+cgCase (StgLit lit) live_in_whole_case live_in_alts bndr

        alt_type@(PrimAlt tycon) alts
   = do { tmp_reg <- bindNewToTemp bndr
        ; cm_lit <- cgLit lit
        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 }
+       ; stmtC (CmmAssign (CmmLocal tmp_reg) (CmmLit cm_lit))
+       ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }

 \end{code}
 
 Special case #2: scrutinising a primitive-typed variable.      No
 \end{code}
 
 Special case #2: scrutinising a primitive-typed variable.      No

@@ -136,7 +126,7 @@ allocating more heap than strictly necessary, but it will sometimes
 eliminate a heap check altogether.
 
 \begin{code}
 eliminate a heap check altogether.
 
 \begin{code}

-cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
+cgCase (StgApp v []) live_in_whole_case live_in_alts bndr

        alt_type@(PrimAlt tycon) alts
   = 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
        alt_type@(PrimAlt tycon) alts
   = 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

@@ -145,15 +135,15 @@ cgCase (StgApp v []) live_in_whole_case live_in_alts bndr srt
          v_info <- getCgIdInfo v
        ; amode <- idInfoToAmode v_info
        ; tmp_reg <- bindNewToTemp bndr
          v_info <- getCgIdInfo v
        ; amode <- idInfoToAmode v_info
        ; tmp_reg <- bindNewToTemp bndr

-       ; stmtC (CmmAssign tmp_reg amode)
-       ; cgPrimAlts NoGC alt_type tmp_reg alts }
+       ; stmtC (CmmAssign (CmmLocal tmp_reg) amode)
+       ; cgPrimAlts NoGC alt_type (CmmLocal tmp_reg) alts }

 \end{code}
 
 Special case #3: inline PrimOps and foreign calls.
 
 \begin{code}
 cgCase (StgOpApp op@(StgPrimOp primop) args _) 
 \end{code}
 
 Special case #3: inline PrimOps and foreign calls.
 
 \begin{code}
 cgCase (StgOpApp op@(StgPrimOp primop) args _) 

-       live_in_whole_case live_in_alts bndr srt alt_type alts
+       live_in_whole_case live_in_alts bndr alt_type alts

   | not (primOpOutOfLine primop)
   = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
 \end{code}
   | not (primOpOutOfLine primop)
   = cgInlinePrimOp primop args bndr alt_type live_in_alts alts
 \end{code}

@@ -168,7 +158,7 @@ right here, just like an inline primop.
 
 \begin{code}
 cgCase (StgOpApp op@(StgFCallOp fcall _) args _) 
 
 \begin{code}
 cgCase (StgOpApp op@(StgFCallOp fcall _) args _) 

-       live_in_whole_case live_in_alts bndr srt alt_type alts
+       live_in_whole_case live_in_alts bndr alt_type alts

   | unsafe_foreign_call
   = ASSERT( isSingleton alts )
     do --  *must* be an unboxed tuple alt.
   | unsafe_foreign_call
   = ASSERT( isSingleton alts )
     do --  *must* be an unboxed tuple alt.

@@ -184,7 +174,7 @@ cgCase (StgOpApp op@(StgFCallOp fcall _) args _)
    unsafe_foreign_call
         = case fcall of
                CCall (CCallSpec _ _ s) -> not (playSafe s)
    unsafe_foreign_call
         = case fcall of
                CCall (CCallSpec _ _ s) -> not (playSafe s)

-               _other                  -> False                                
+               _other                  -> False

 \end{code}
 
 Special case: scrutinising a non-primitive variable.
 \end{code}
 
 Special case: scrutinising a non-primitive variable.

@@ -193,7 +183,7 @@ we can reuse/trim the stack slot holding the variable (if it is in one).
 
 \begin{code}
 cgCase (StgApp fun args)
 
 \begin{code}
 cgCase (StgApp fun args)

-       live_in_whole_case live_in_alts bndr srt alt_type alts
+       live_in_whole_case live_in_alts bndr alt_type alts

   = do { fun_info <- getCgIdInfo fun
        ; arg_amodes <- getArgAmodes args
 
   = do { fun_info <- getCgIdInfo fun
        ; arg_amodes <- getArgAmodes args
 

@@ -211,9 +201,9 @@ cgCase (StgApp fun args)
            <- forkEval alts_eob_info 
                        (allocStackTop retAddrSizeW >> nopC)
                        (do { deAllocStackTop retAddrSizeW
            <- forkEval alts_eob_info 
                        (allocStackTop retAddrSizeW >> nopC)
                        (do { deAllocStackTop retAddrSizeW

-                           ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+                           ; cgEvalAlts maybe_cc_slot bndr 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}
 

@@ -231,7 +221,7 @@ deAllocStackTop call is doing above.
 Finally, here is the general case.
 
 \begin{code}
 Finally, here is the general case.
 
 \begin{code}

-cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
+cgCase expr live_in_whole_case live_in_alts bndr alt_type alts

   = do {       -- Figure out what volatile variables to save
          nukeDeadBindings live_in_whole_case
     
   = do {       -- Figure out what volatile variables to save
          nukeDeadBindings live_in_whole_case
     

@@ -248,10 +238,9 @@ cgCase expr live_in_whole_case live_in_alts bndr srt alt_type alts
                                ; allocStackTop retAddrSizeW   -- space for retn address 
                                ; nopC })
                           (do  { deAllocStackTop retAddrSizeW
                                ; allocStackTop retAddrSizeW   -- space for retn address 
                                ; nopC })
                           (do  { deAllocStackTop retAddrSizeW

-                               ; cgEvalAlts maybe_cc_slot bndr srt alt_type alts })
+                               ; cgEvalAlts maybe_cc_slot bndr alt_type alts })

 
 

-       ; setEndOfBlockInfo (maybeReserveSeqFrame alt_type scrut_eob_info)
-                           (cgExpr expr)
+       ; setEndOfBlockInfo scrut_eob_info (cgExpr expr)

     }
 \end{code}
 
     }
 \end{code}
 

@@ -281,13 +270,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

@@ -309,7 +291,7 @@ 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
   = 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 }
+       ; cgPrimAlts NoGC (PrimAlt tycon) (CmmLocal tmp_reg) alts }

 
 cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts
   = ASSERT( isSingleton alts )
 
 cgInlinePrimOp primop args bndr (UbxTupAlt tycon) live_in_alts alts
   = ASSERT( isSingleton alts )

@@ -339,7 +321,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
        ; this_pkg <- getThisPackage
        ; whenC (not (isDeadBinder bndr))
                (do { tmp_reg <- bindNewToTemp bndr
        ; this_pkg <- getThisPackage
        ; whenC (not (isDeadBinder bndr))
                (do { tmp_reg <- bindNewToTemp bndr

-                   ; stmtC (CmmAssign tmp_reg (tagToClosure this_pkg tycon tag_amode)) })
+                   ; stmtC (CmmAssign
+                             (CmmLocal tmp_reg)
+                             (tagToClosure tycon tag_amode)) })

 
                -- Compile the alts
        ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}
 
                -- Compile the alts
        ; (branches, mb_deflt) <- cgAlgAlts NoGC Nothing{-cc_slot-}

@@ -356,9 +340,9 @@ cgInlinePrimOp primop args bndr (AlgAlt tycon) live_in_alts alts
          (_,e) <- getArgAmode arg
         return e
     do_enum_primop primop
          (_,e) <- getArgAmode arg
         return e
     do_enum_primop primop

-      = do tmp <- newTemp wordRep
+      = do tmp <- newNonPtrTemp wordRep

           cgPrimOp [tmp] primop args live_in_alts
           cgPrimOp [tmp] primop args live_in_alts

-          returnFC (CmmReg tmp)
+          returnFC (CmmReg (CmmLocal tmp))

 
 cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
   = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)
 
 cgInlinePrimOp primop arg_amodes bndr PolyAlt live_in_alts alts
   = pprPanic "cgCase: case of primop has polymorphic type" (ppr bndr)

@@ -377,14 +361,13 @@ is some evaluation to be done.
 \begin{code}
 cgEvalAlts :: Maybe VirtualSpOffset    -- Offset of cost-centre to be restored, if any
           -> Id
 \begin{code}
 cgEvalAlts :: Maybe VirtualSpOffset    -- Offset of cost-centre to be restored, if any
           -> Id

-          -> SRT                       -- SRT for the continuation

           -> 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
 
           -> 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 alt_type@(PrimAlt tycon) alts
+cgEvalAlts cc_slot bndr alt_type@(PrimAlt tycon) alts

   = do { let   rep = tyConCgRep tycon
                reg = dataReturnConvPrim rep    -- Bottom for voidRep
 
   = do { let   rep = tyConCgRep tycon
                reg = dataReturnConvPrim rep    -- Bottom for voidRep
 

@@ -396,10 +379,10 @@ 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
+       ; returnFC (CaseAlts lbl Nothing bndr) }

 
 

-cgEvalAlts cc_slot bndr srt (UbxTupAlt _) [(con,args,_,rhs)]
+cgEvalAlts cc_slot bndr (UbxTupAlt _) [(con,args,_,rhs)]

   =    -- Unboxed tuple case
        -- By now, the simplifier should have have turned it
        -- into         case e of (# a,b #) -> e
   =    -- Unboxed tuple case
        -- By now, the simplifier should have have turned it
        -- into         case e of (# a,b #) -> e

@@ -408,7 +391,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,10 +401,10 @@ 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
+       ; returnFC (CaseAlts lbl Nothing bndr) }

 
 

-cgEvalAlts cc_slot bndr srt alt_type alts
+cgEvalAlts cc_slot bndr alt_type alts

   =    -- Algebraic and polymorphic case
     do {       -- Bind the default binder
          bindNewToReg bndr nodeReg (mkLFArgument bndr)
   =    -- Algebraic and polymorphic case
     do {       -- Bind the default binder
          bindNewToReg bndr nodeReg (mkLFArgument bndr)

@@ -438,13 +421,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 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}