[project @ 2002-04-29 14:03:38 by simonmar]

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

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index d9dc5c8..df2e165 100644 (file)
--- a/ghc/compiler/codeGen/CgCase.lhs
+++ b/ghc/compiler/codeGen/CgCase.lhs
@@ -1,7 +1,7 @@
 %
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
-% $Id: CgCase.lhs,v 1.52 2001/05/22 13:43:15 simonpj Exp $
+% $Id: CgCase.lhs,v 1.57 2002/04/29 14:03:41 simonmar Exp $
 %
 %********************************************************
 %*                                                     *
@@ -156,7 +156,8 @@ cgCase (StgOpApp op args _)
                tag_amode = CTemp (newTagUnique (getUnique bndr) 'C') IntRep
              in
              getVolatileRegs live_in_alts                      `thenFC` \ vol_regs ->
-             absC (COpStmt [tag_amode] op arg_amodes vol_regs) `thenC`
+             absC (COpStmt [tag_amode] op arg_amodes vol_regs)
+                                                               `thenC`
                                -- NB: no liveness arg
              returnFC tag_amode
     }                                          `thenFC` \ tag_amode ->
@@ -184,7 +185,17 @@ cgCase (StgOpApp op args _)
     absC (mkAlgAltsCSwitch tag_amode tagged_alts deflt_c)
 \end{code}
 
-Special case #2: inline PrimOps.
+Special case #2: case of literal.
+
+\begin{code}
+cgCase (StgLit lit) live_in_whole_case live_in_alts bndr srt alts =
+  absC (CAssign (CTemp (getUnique bndr) (idPrimRep bndr)) (CLit lit)) `thenC`
+  case alts of 
+      StgPrimAlts tycon alts deflt -> cgPrimInlineAlts bndr tycon alts deflt
+      other -> pprPanic "cgCase: case of literal has strange alts" (pprStgAlts alts)
+\end{code}
+
+Special case #3: inline PrimOps.
 
 \begin{code}
 cgCase (StgOpApp op@(StgPrimOp primop) args _) 
@@ -396,17 +407,22 @@ cgEvalAlts cc_slot bndr srt alts
                Just spec_tycon = maybe_tycon
        in
 
-       -- deal with the unboxed tuple case
+       -- Deal with the unboxed tuple case
        if is_alg && isUnboxedTupleTyCon spec_tycon then
-           case alts of 
-               [alt] -> let lbl = mkReturnInfoLabel uniq in
-                        cgUnboxedTupleAlt uniq cc_slot True alt
-                               `thenFC` \ abs_c ->
-                        getSRTLabel `thenFC` \srt_label -> 
-                        absC (CRetDirect uniq abs_c (srt_label, srt) 
-                                       liveness_mask) `thenC`
-                       returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
-               _ -> panic "cgEvalAlts: dodgy case of unboxed tuple type"
+               -- By now, the simplifier should have have turned it
+               -- into         case e of (# a,b #) -> e
+               -- There shouldn't be a 
+               --              case e of DEFAULT -> e
+           ASSERT2( case (alts, deflt) of { ([_],StgNoDefault) -> True; other -> False },
+                    text "cgEvalAlts: dodgy case of unboxed tuple type" )
+           let
+               alt = head alts
+               lbl = mkReturnInfoLabel uniq
+           in
+           cgUnboxedTupleAlt uniq cc_slot True alt             `thenFC` \ abs_c ->
+           getSRTInfo srt                                      `thenFC` \ srt_info -> 
+           absC (CRetDirect uniq abs_c srt_info liveness_mask) `thenC`
+           returnFC (CaseAlts (CLbl lbl RetRep) Nothing)
 
        -- normal algebraic (or polymorphic) case alternatives
        else let
@@ -442,9 +458,9 @@ cgEvalAlts cc_slot bndr srt alts
        getAbsC (cgPrimEvalAlts bndr tycon alts deflt)  `thenFC` \ abs_c ->
 
        -- Generate the labelled block, starting with restore-cost-centre
-       getSRTLabel                                     `thenFC` \srt_label ->
+       getSRTInfo srt                                  `thenFC` \srt_info ->
        absC (CRetDirect uniq (cc_restore `mkAbsCStmts` abs_c) 
-                       (srt_label,srt) liveness_mask)  `thenC`
+                        srt_info liveness_mask)        `thenC`
 
        -- Return an amode for the block
        returnFC (CaseAlts (CLbl (mkReturnInfoLabel uniq) RetRep) Nothing)
@@ -622,14 +638,14 @@ cgSemiTaggedAlts binder alts deflt
 
     st_deflt (StgBindDefault _)
       = Just (Just binder,
-             (CCallProfCtrMacro SLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
+             (CCallProfCtrMacro FSLIT("RET_SEMI_BY_DEFAULT") [], -- ToDo: monadise?
               mkDefaultLabel uniq)
             )
 
     st_alt (con, args, use_mask, _)
       =  -- Ha!  Nothing to do; Node already points to the thing
         (con_tag,
-          (CCallProfCtrMacro SLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
+          (CCallProfCtrMacro FSLIT("RET_SEMI_IN_HEAP") -- ToDo: monadise?
                [mkIntCLit (length args)], -- how big the thing in the heap is
             join_label)
            )
@@ -782,7 +798,7 @@ restoreCurrentCostCentre Nothing = returnFC AbsCNop
 restoreCurrentCostCentre (Just slot)
  = getSpRelOffset slot                          `thenFC` \ sp_rel ->
    freeStackSlots [slot]                        `thenC`
-   returnFC (CCallProfCCMacro SLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
+   returnFC (CCallProfCCMacro FSLIT("RESTORE_CCCS") [CVal sp_rel CostCentreRep])
     -- we use the RESTORE_CCCS macro, rather than just
     -- assigning into CurCostCentre, in case RESTORE_CCCS
     -- has some sanity-checking in it.
@@ -807,7 +823,7 @@ mkReturnVector :: Unique
               -> FCode CAddrMode
 
 mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
-  = getSRTLabel `thenFC` \srt_label ->
+  = getSRTInfo srt             `thenFC` \ srt_info ->
     let
      (return_vec_amode, vtbl_body) = case ret_conv of {
 
@@ -815,7 +831,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
       UnvectoredReturn 0 ->
        ASSERT(null tagged_alt_absCs)
        (CLbl ret_label RetRep,
-        absC (CRetDirect uniq deflt_absC (srt_label, srt) liveness));
+        absC (CRetDirect uniq deflt_absC srt_info liveness));
 
       UnvectoredReturn n ->
         -- find the tag explicitly rather than using tag_reg for now.
@@ -827,7 +843,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
        (CLbl ret_label RetRep,
         absC (CRetDirect uniq 
                            (mkAlgAltsCSwitch tag tagged_alt_absCs deflt_absC)
-                           (srt_label, srt)
+                           srt_info
                            liveness));
 
       VectoredReturn table_size ->
@@ -835,9 +851,7 @@ mkReturnVector uniq tagged_alt_absCs deflt_absC srt liveness ret_conv
          (vector_table, alts_absC) = 
            unzip (map mk_vector_entry [fIRST_TAG .. (table_size+fIRST_TAG-1)])
 
-         ret_vector = CRetVector vtbl_label
-                         vector_table
-                         (srt_label, srt) liveness
+         ret_vector = CRetVector vtbl_label vector_table srt_info liveness
        in
        (CLbl vtbl_label DataPtrRep, 
         -- alts come first, because we don't want to declare all the symbols