From e4622dac19c0ea5ba60078667c57e03801cdc943 Mon Sep 17 00:00:00 2001
From: "dias@cs.tufts.edu" <unknown>
Date: Fri, 18 Sep 2009 18:31:22 +0000
Subject: [PATCH] Fix for T3286 in new codegen (related to T3132); plus
 formatting If the scrutinee is bottom, the generated Cmm
 code could have a type error when the case arm expected an
 unboxed floating-point value (even though the arm should
 never be reached). Now, we detect this case and avoid
 producing the type-incorrect assignment.

---
 compiler/codeGen/StgCmmExpr.hs |   53 ++++++++++++++++++++++++++++------------
 1 file changed, 38 insertions(+), 15 deletions(-)

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 8952f92..002e1b2 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -36,7 +36,9 @@ import DataCon
 import ForeignCall
 import Id
 import PrimOp
+import SMRep
 import TyCon
+import Type
 import CostCentre	( CostCentreStack, currentCCS )
 import Maybes
 import Util
@@ -280,24 +282,45 @@ cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
   = 
 -}
 
+  -- Note [ticket #3132]: we might be looking at a case of a lifted Id
+  -- that was cast to an unlifted type.  The Id will always be bottom,
+  -- but we don't want the code generator to fall over here.  If we
+  -- just emit an assignment here, the assignment will be
+  -- type-incorrect Cmm.  Hence, we emit the usual enter/return code,
+  -- (and because bottom must be untagged, it will be entered and the
+  -- program will crash).
+  -- The Sequel is a type-correct assignment, albeit bogus.
+  -- The (dead) continuation loops; it would be better to invoke some kind
+  -- of panic function here.
+cgCase scrut@(StgApp v []) bndr _ _ _ 
+  | not (isUnLiftedType (idType v)) && reps_incompatible
+  =
+    do { mb_cc <- maybeSaveCostCentre True
+       ; withSequel (AssignTo [idToReg (NonVoid v)] False) (cgExpr scrut)
+       ; restoreCurrentCostCentre mb_cc
+       ; emit $ mkComment $ mkFastString "should be unreachable code"
+       ; emit $ withFreshLabel "l" (\l -> mkLabel l <*> mkBranch l)}
+  where
+    reps_incompatible = idCgRep v /= idCgRep bndr
+
 cgCase scrut bndr srt alt_type alts 
-  = do	{ up_hp_usg <- getVirtHp	-- Upstream heap usage
-	; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
-	      alt_regs  = map idToReg ret_bndrs
-	      simple_scrut = isSimpleScrut scrut alt_type
-	      gcInAlts | not simple_scrut = True
-	               | isSingleton alts = False
-		       | up_hp_usg > 0    = False
-		       | otherwise        = True
-              gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts
-
-	; mb_cc <- maybeSaveCostCentre simple_scrut
-	; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut)
-	; restoreCurrentCostCentre mb_cc
+  = do { up_hp_usg <- getVirtHp        -- Upstream heap usage
+       ; let ret_bndrs = chooseReturnBndrs bndr alt_type alts
+             alt_regs  = map idToReg ret_bndrs
+             simple_scrut = isSimpleScrut scrut alt_type
+             gcInAlts | not simple_scrut = True
+                      | isSingleton alts = False
+                      | up_hp_usg > 0    = False
+                      | otherwise        = True
+             gc_plan = if gcInAlts then GcInAlts alt_regs srt else NoGcInAlts
+
+       ; mb_cc <- maybeSaveCostCentre simple_scrut
+       ; withSequel (AssignTo alt_regs gcInAlts) (cgExpr scrut)
+       ; restoreCurrentCostCentre mb_cc
 
   -- JD: We need Note: [Better Alt Heap Checks]
-	; _ <- bindArgsToRegs ret_bndrs
-	; cgAlts gc_plan (NonVoid bndr) alt_type alts }
+       ; _ <- bindArgsToRegs ret_bndrs
+       ; cgAlts gc_plan (NonVoid bndr) alt_type alts }
 
 -----------------
 maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
-- 
1.7.10.4