X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcodeGen%2FStgCmmExpr.hs;h=50d500bc8c04a69024a4671f9b85b8e3d51479e0;hb=0d657c49385c1dd0896c02ae979da4f858c2ceb3;hp=0c958b38051ddb00e3c97cc3253e450bacd14543;hpb=c55eee3add067dd0372ed8eede64b84791f7a9b9;p=ghc-hetmet.git

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 0c958b3..50d500b 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -40,6 +40,7 @@ import SMRep
 import TyCon
 import Type
 import CostCentre	( CostCentreStack, currentCCS )
+import Control.Monad (when)
 import Maybes
 import Util
 import FastString
@@ -292,19 +293,39 @@ cgCase (OpApp ) bndr srt AlgAlt [(DataAlt flase, a2]
   -- 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
-  =
+  --
+  -- However, we also want to allow an assignment to be generated
+  -- in the case when the types are compatible, because this allows
+  -- some slightly-dodgy but occasionally-useful casts to be used,
+  -- such as in RtClosureInspect where we cast an HValue to a MutVar#
+  -- so we can print out the contents of the MutVar#.  If we generate
+  -- code that enters the HValue, then we'll get a runtime panic, because
+  -- the HValue really is a MutVar#.  The types are compatible though,
+  -- so we can just generate an assignment.
+cgCase (StgApp v []) bndr _ alt_type@(PrimAlt _) alts
+  | isUnLiftedType (idType v)
+  || reps_compatible
+  = -- assignment suffices for unlifted types
+    do { when (not reps_compatible) $
+           panic "cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
+       ; v_info <- getCgIdInfo v
+       ; emit (mkAssign (CmmLocal (idToReg (NonVoid bndr))) (idInfoToAmode v_info))
+       ; _ <- bindArgsToRegs [NonVoid bndr]
+       ; cgAlts NoGcInAlts (NonVoid bndr) alt_type alts }
+  where
+    reps_compatible = idCgRep v == idCgRep bndr
+
+cgCase scrut@(StgApp v []) _ _ (PrimAlt _) _ 
+  = -- fail at run-time, not compile-time
     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
+  = -- the general case
+    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