Fix problem with selectors for GADT records with unboxed fields

[ghc-hetmet.git] / compiler / simplCore / Simplify.lhs

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 85b4b49..f477038 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -44,7 +44,8 @@ import CoreUtils      ( exprIsDupable, exprIsTrivial, needsCaseBinding,
                          exprIsConApp_maybe, mkPiTypes, findAlt, 
                          exprType, exprIsHNF, findDefault, mergeAlts,
                          exprOkForSpeculation, exprArity, 
-                         mkCoerce, mkSCC, mkInlineMe, applyTypeToArg
+                         mkCoerce, mkSCC, mkInlineMe, applyTypeToArg,
+                          dataConRepInstPat
                        )
 import Rules           ( lookupRule )
 import BasicTypes      ( isMarkedStrict )
@@ -1552,7 +1553,10 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
 
        [con] ->        -- It matches exactly one constructor, so fill it in
                 do { tick (FillInCaseDefault case_bndr')
-                   ; con_alt <- mkDataConAlt con inst_tys rhs
+                    ; us <- getUniquesSmpl
+                    ; let (ex_tvs, co_tvs, arg_ids) =
+                              dataConRepInstPat us con inst_tys
+                    ; let con_alt = (DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs)
                    ; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
                        -- The simplAlt must succeed with Just because we have
                        -- already filtered out construtors that can't match
@@ -1696,7 +1700,7 @@ knownCon env scrut con args bndr alts cont
                                  simplExprF env rhs cont
 
        (DataAlt dc, bs, rhs)  
-               -> ASSERT( n_drop_tys + length bs == length args )
+               -> -- ASSERT( n_drop_tys + length bs == length args )
                   bind_args env dead_bndr bs (drop n_drop_tys args)    $ \ env ->
                   let
                        -- It's useful to bind bndr to scrut, rather than to a fresh