GADT selector bugfix, bits of cleanup

Mon Sep 18 16:48:32 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * GADT selector bugfix, bits of cleanup
  Sun Aug  6 19:43:47 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * GADT selector bugfix, bits of cleanup
    Thu Jul 27 08:10:58 EDT 2006  kevind@bu.edu

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index c621e5b..5fe7dc0 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -47,6 +47,7 @@ import TysPrim                ( openAlphaTyVars, alphaTyVar, alphaTy,
 import TysWiredIn      ( charTy, mkListTy )
 import PrelRules       ( primOpRules )
 import Type            ( TyThing(..), mkForAllTy, tyVarsOfTypes, newTyConInstRhs, coreEqType,
+                          PredType(..),
                          mkTopTvSubst, substTyVar )
 import Coercion         ( mkSymCoercion, mkUnsafeCoercion, 
                           splitNewTypeRepCo_maybe, isEqPred )
@@ -554,7 +555,7 @@ mkRecordSelId tycon field_label
     mk_alt data_con 
       =        -- In the non-vanilla case, the pattern must bind type variables and
                -- the context stuff; hence the arg_prefix binding below
-         pprTrace "mkReboxingAlt" (ppr data_con <+> ppr (arg_prefix ++ arg_ids)) $ mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id)
+         mkReboxingAlt uniqs data_con (arg_prefix ++ arg_ids) (Var the_arg_id)
       where
        (arg_prefix, arg_ids)
           | isVanillaDataCon data_con          -- Instantiate from commmon base
@@ -566,7 +567,12 @@ mkRecordSelId tycon field_label
 
        (pre_dc_tvs, pre_dc_theta, dc_arg_tys) = dataConSig data_con
            -- again we need to pull the EqPreds out of dc_theta, into dc_tvs
-        dc_eqvars = map (mkWildCoVar . mkPredTy) (filter isEqPred pre_dc_theta)
+        dc_eqvars = map (mkWildCoVar . mkPredTy . fixEqPred) (filter isEqPred pre_dc_theta)
+          -- The type of the record selector Id does not contain the univ tvs
+          -- but rather their substitution according to the eq_spec.  Therefore
+          -- the coercion arguments bound in the case alternative will just
+          -- have reflexive coercion kinds
+        fixEqPred (EqPred ty1 ty2) = EqPred ty2 ty2
         dc_tvs    = drop (length (dataConUnivTyVars data_con)) pre_dc_tvs ++ dc_eqvars
         dc_theta  = filter (not . isEqPred) pre_dc_theta
        arg_base' = arg_base + length dc_theta

diff --git a/compiler/codeGen/SMRep.lhs b/compiler/codeGen/SMRep.lhs
index c807703..521b626 100644 (file)
--- a/compiler/codeGen/SMRep.lhs
+++ b/compiler/codeGen/SMRep.lhs
@@ -158,13 +158,13 @@ primRepHint FloatRep      = FloatHint
 primRepHint DoubleRep  = FloatHint
 
 idCgRep :: Id -> CgRep
-idCgRep = typeCgRep . idType
+idCgRep x = typeCgRep . idType $ x
 
 tyConCgRep :: TyCon -> CgRep
 tyConCgRep = primRepToCgRep . tyConPrimRep
 
 typeCgRep :: Type -> CgRep
-typeCgRep = primRepToCgRep . typePrimRep
+typeCgRep = primRepToCgRep . typePrimRep 
 
 typeHint :: Type -> MachHint
 typeHint = primRepHint . typePrimRep

diff --git a/compiler/coreSyn/CoreLint.lhs b/compiler/coreSyn/CoreLint.lhs
index 354b95c..a147ce2 100644 (file)
--- a/compiler/coreSyn/CoreLint.lhs
+++ b/compiler/coreSyn/CoreLint.lhs
@@ -509,8 +509,7 @@ lintCoreAlt scrut_ty alt_ty alt@(DataAlt con, args, rhs)
                 -- NB: args must be in scope here so that the lintCoreArgs line works.
                 -- NB: relies on existential type args coming *after* ordinary type args
 
-         ; con_result_ty <-  
-                               lintCoreArgs (dataConRepType con)
+         ; con_result_ty <- lintCoreArgs (dataConRepType con)
                                                (map Type tycon_arg_tys ++ varsToCoreExprs args)
          ; checkTys con_result_ty scrut_ty (mkBadPatMsg con_result_ty scrut_ty) 
          }