Add several new record features

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

diff --git a/compiler/codeGen/CgCase.lhs b/compiler/codeGen/CgCase.lhs
index 7f440c1..b8f3141 100644 (file)
--- a/compiler/codeGen/CgCase.lhs
+++ b/compiler/codeGen/CgCase.lhs
@@ -9,7 +9,6 @@ module CgCase ( cgCase, saveVolatileVarsAndRegs,
        ) where
 
 #include "HsVersions.h"
        ) where
 
 #include "HsVersions.h"

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

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

@@ -42,7 +41,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}

@@ -173,54 +171,9 @@ cgCase (StgOpApp op@(StgFCallOp fcall _) args _)
                _other                  -> False                                
 \end{code}
 
                _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
-        }
-\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)

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

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

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

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

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

@@ -449,61 +394,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 srt
+       ; returnFC (CaseAlts lbl Nothing bndr) }

 
 cgEvalAlts cc_slot bndr srt alt_type alts
   =    -- Algebraic and polymorphic case
     do {       -- Bind the default binder
          bindNewToReg bndr nodeReg (mkLFArgument bndr)
 
 
 cgEvalAlts cc_slot bndr srt alt_type alts
   =    -- 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 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
-
-
--- 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}