Fix for T3286 in new codegen (related to T3132); plus formatting

[ghc-hetmet.git] / compiler / codeGen / StgCmmExpr.hs

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 8952f92..002e1b2 100644 (file)
--- 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)