X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmExpr.hs;h=0c958b38051ddb00e3c97cc3253e450bacd14543;hb=609e7ddfb10bc04762b820e70e0487ad6c514c2e;hp=065005caf793325a99e3e10d5ef389c7a7e3c1a0;hpb=617eb195e67525ffda967099fa8d9899e2b15ce8;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 065005c..0c958b3 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 _ (PrimAlt _) _ 
+  | 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)
@@ -320,8 +343,8 @@ isSimpleScrut _		       _           = False
 isSimpleOp :: StgOp -> Bool
 -- True iff the op cannot block or allocate
 isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) = not (playSafe safe)
-isSimpleOp (StgFCallOp (DNCall _) _)                   = False         -- Safe!
 isSimpleOp (StgPrimOp op)      			       = not (primOpOutOfLine op)
+isSimpleOp (StgPrimCallOp _)                           = False
 
 -----------------
 chooseReturnBndrs :: Id -> AltType -> [StgAlt] -> [NonVoid Id]
@@ -407,7 +430,7 @@ cgAltRhss gc_plan bndr alts
     cg_alt (con, bndrs, _uses, rhs)
       = getCodeR		  $
 	maybeAltHeapCheck gc_plan $
-	do { bindConArgs con base_reg bndrs
+	do { _ <- bindConArgs con base_reg bndrs
 	   ; cgExpr rhs
 	   ; return con }