[project @ 2001-10-11 14:31:45 by sewardj]

Correctly handle unboxed tuples when converting DEFAULT alts to
  unboxed tuple constructors in case args.  (I'm sure this could
  be worded better).  Branch and HEAD have drifted too far apart
  for easy common commit for this, so is committed seperately for
  ghc-5-02-branch.

diff --git a/ghc/compiler/codeGen/CgCase.lhs b/ghc/compiler/codeGen/CgCase.lhs
index 43147e5..379c397 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.53 2001/09/26 15:11:50 simonpj Exp $
+% $Id: CgCase.lhs,v 1.54 2001/10/11 14:31:45 sewardj Exp $
 %
 %********************************************************
 %*                                                     *
@@ -396,17 +396,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 ->
-                        getSRTInfo srt          `thenFC` \ srt_info -> 
-                        absC (CRetDirect uniq abs_c srt_info
-                                       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

diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index fb70278..e53bc04 100644 (file)
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -41,7 +41,7 @@ import Type           ( Type, seqType,
                          splitRepFunTys, isStrictType
                        )
 import OccName         ( UserFS )
-import TyCon           ( tyConDataConsIfAvailable, isDataTyCon )
+import TyCon           ( tyConDataConsIfAvailable, isAlgTyCon, isNewTyCon )
 import DataCon         ( dataConRepArity, dataConSig, dataConArgTys )
 import Var             ( mkSysTyVar, tyVarKind )
 import Util            ( lengthExceeds, mapAccumL )
@@ -886,12 +886,14 @@ mkAlts scrut case_bndr alts@((con1,bndrs1,rhs1) : con_alts)
 
 mkAlts scrut case_bndr alts
   | Just (tycon, inst_tys) <- splitTyConApp_maybe (idType case_bndr),
-    isDataTyCon tycon,                 -- It's a data type
+    isAlgTyCon tycon,  -- It's a data type, tuple, or unboxed tuples.  
+                       -- We aren't expecting any newtypes at this point.
     (alts_no_deflt, Just rhs) <- findDefault alts,
                -- There is a DEFAULT case
     [missing_con] <- filter is_missing (tyConDataConsIfAvailable tycon)
                -- There is just one missing constructor!
-  = tick (FillInCaseDefault case_bndr) `thenSmpl_`
+  = ASSERT( not (isNewTyCon tycon) )
+    tick (FillInCaseDefault case_bndr) `thenSmpl_`
     getUniquesSmpl                     `thenSmpl` \ tv_uniqs ->
     getUniquesSmpl                     `thenSmpl` \ id_uniqs ->
     let