Fix CodingStyle#Warnings URLs

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

diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index 7f440c1..398441e 100644 (file)
--- a/compiler/codeGen/CgCase.lhs
+++ b/compiler/codeGen/CgCase.lhs
@@ -4,12 +4,18 @@
 %
 
 \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
 
 #include "HsVersions.h"
 module CgCase (        cgCase, saveVolatileVarsAndRegs, 
                restoreCurrentCostCentre
        ) where
 
 #include "HsVersions.h"

-#include "../includes/ClosureTypes.h"

 
 import {-# SOURCE #-} CgExpr  ( cgExpr )
 
 
 import {-# SOURCE #-} CgExpr  ( cgExpr )
 

@@ -42,7 +48,6 @@ import PrimOp
 import TyCon
 import Util
 import Outputable
 import TyCon
 import Util
 import Outputable

-import Constants

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

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

-       -> SRT

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

@@ -106,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

@@ -122,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

@@ -131,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}

@@ -154,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.

@@ -170,61 +174,16 @@ 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                                
-\end{code}
-
-Special case: scrutinising a non-primitive variable.  This is where we
-want to do semi-tagging.  The code generated will be something like this:
-
-  save volatile vars
-  R1 = fun
-  jump c99_ret
-
-  <info table goes here>
-c99_ret:
-  infoptr = R1[0]
-  type = infoptr[-4] // or something
-  if (type > 8) goto no_cons
-  tag = infoptr[-6]
-  if (tag == 1) ... etc.
-no_cons
-  jump infoptr
-
-\begin{code}
-cgCase (StgApp fun [])
-       live_in_whole_case live_in_alts bndr srt (AlgAlt tycon) alts
-  = do { fun_info <- getCgIdInfo fun
-        ; fun_amode <- idInfoToAmode fun_info
-
-       ; 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
-                           ; cgEvalAltsSemiTag maybe_cc_slot bndr srt 
-                                                tycon alts })
-
-        -- jump to the continuation immediately
-        ; case scrut_eob_info of
-             EndOfBlockInfo sp (CaseAlts lbl _ _ _) -> do
-                let node_asst = oneStmt (CmmAssign nodeReg fun_amode)
-                emitSimultaneously (node_asst `plusStmts` save_assts)
-                let jmp = stmtC (CmmJump (CmmLit (CmmLabel lbl)) [])
-                setEndOfBlockInfo scrut_eob_info $
-                    doFinalJump sp False jmp
-        }
+               _other                  -> False

 \end{code}
 
 \end{code}
 

-Special case: scrutinising a non-primitive application.  This can be
-done a little better than the general case, because we can reuse/trim
-the stack slot holding the variables involved in the application.
+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)
 
 \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
 

@@ -242,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}
 

@@ -262,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
     

@@ -279,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}
 

@@ -312,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

@@ -340,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 )

@@ -370,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-}

@@ -387,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)

@@ -408,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
 

@@ -427,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

@@ -439,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, 

@@ -449,61 +401,33 @@ 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)
 

+       -- Generate sequel info for use downstream
+       -- At the moment, we only do it if the type is vector-returnable.
+       -- Reason: if not, then it costs extra to label the
+       -- alternatives, because we'd get return code like:
+       --
+       --      switch TagReg { 0 : JMP(alt_1); 1 : JMP(alt_2) ..etc }
+       --
+       -- which is worse than having the alt code in the switch statement
+

        ; (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
-
-
--- Alternatives for a semi-tagging case expression
-cgEvalAltsSemiTag cc_slot bndr srt tycon alts
-  = do -- Bind the default binder
-    bindNewToReg bndr nodeReg (mkLFArgument bndr)
-
-    blks <- getCgStmts $ cgEvalAltsSemiTag' cc_slot tycon alts
-    lbl <- emitDirectReturnTarget (idName bndr) blks srt
-    return (CaseAlts lbl Nothing bndr False)
-
-cgEvalAltsSemiTag' cc_slot tycon alts
-  = do
-    (alts, mb_deflt) <- cgAlgAlts GCMayHappen cc_slot (AlgAlt tycon) alts
-
-    iptr <- newTemp wordRep
-    stmtC (CmmAssign iptr (closureInfoPtr (CmmReg nodeReg)))
-        -- share the iptr between ctype and tag, below
-
-    -- we don't have a 1-indexed tag field, we have to use the type
-    -- field first to find out whether the closure is a constructor
-    not_constr <- newLabelC
-
-    let highCons = CmmLit (CmmInt CONSTR_NOCAF_STATIC halfWordRep)
-    stmtC (CmmCondBranch (CmmMachOp (MO_U_Gt halfWordRep)
-                            [infoTableClosureType (infoTable (CmmReg iptr)),
-                             highCons])
-                         not_constr)
-    
-    let tag_expr = CmmMachOp (MO_U_Conv halfWordRep wordRep) 
-                        [infoTableConstrTag (infoTable (CmmReg iptr))]
-
-    let family_size = tyConFamilySize tycon
-    emitSwitch tag_expr alts mb_deflt 0 (family_size - 1)
-    
-    labelC not_constr
-    stmtC (CmmJump (entryCode (CmmReg iptr)) [])
+    fam_sz = case alt_type of
+               AlgAlt tc -> tyConFamilySize tc
+               PolyAlt   -> 0

 \end{code}
 
 
 \end{code}