Fix problem with selectors for GADT records with unboxed fields

Mon Sep 18 17:13:11 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
  * Fix problem with selectors for GADT records with unboxed fields
  Sun Aug  6 20:47:11 EDT 2006  Manuel M T Chakravarty <chak@cse.unsw.edu.au>
    * Fix problem with selectors for GADT records with unboxed fields
    Wed Aug  2 05:37:38 EDT 2006  kevind@bu.edu

diff --git a/compiler/basicTypes/MkId.lhs b/compiler/basicTypes/MkId.lhs
index 4609959..8df6aa7 100644 (file)
--- a/compiler/basicTypes/MkId.lhs
+++ b/compiler/basicTypes/MkId.lhs
@@ -59,7 +59,7 @@ import TcType         ( Type, ThetaType, mkDictTy, mkPredTys, mkPredTy,
                          isUnLiftedType, mkForAllTys, mkTyVarTy, tyVarsOfType,
                          tcSplitFunTys, tcSplitForAllTys, dataConsStupidTheta
                        )
-import CoreUtils       ( exprType, dataConInstPat )
+import CoreUtils       ( exprType, dataConOrigInstPat )
 import CoreUnfold      ( mkTopUnfolding, mkCompulsoryUnfolding )
 import Literal         ( nullAddrLit, mkStringLit )
 import TyCon           ( TyCon, isNewTyCon, tyConDataCons, FieldLabel,
@@ -563,7 +563,7 @@ mkRecordSelId tycon field_label
                                -- in the types of the arguments of the pattern
           = (ex_tvs ++ co_tvs ++ dict_vs, field_vs)
 
-        (ex_tvs, co_tvs, arg_vs) = dataConInstPat uniqs' data_con res_tys
+        (ex_tvs, co_tvs, arg_vs) = dataConOrigInstPat uniqs' data_con res_tys
         (dict_vs, field_vs) = splitAt (length dc_theta) arg_vs
 
        (_, pre_dc_theta, dc_arg_tys) = dataConSig data_con

diff --git a/compiler/coreSyn/CoreUtils.lhs b/compiler/coreSyn/CoreUtils.lhs
index b5ba2a2..76d742c 100644 (file)
--- a/compiler/coreSyn/CoreUtils.lhs
+++ b/compiler/coreSyn/CoreUtils.lhs
@@ -33,7 +33,7 @@ module CoreUtils (
        -- Equality
        cheapEqExpr, tcEqExpr, tcEqExprX, applyTypeToArgs, applyTypeToArg,
 
-        dataConInstPat, dataConOccInstPat
+        dataConOrigInstPat, dataConRepInstPat, dataConRepOccInstPat
     ) where
 
 #include "HsVersions.h"
@@ -57,7 +57,8 @@ import Literal                ( hashLiteral, literalType, litIsDupable,
                          litIsTrivial, isZeroLit, Literal( MachLabel ) )
 import DataCon         ( DataCon, dataConRepArity, eqSpecPreds, 
                          isVanillaDataCon, dataConTyCon, dataConRepArgTys,
-                          dataConUnivTyVars, dataConExTyVars, dataConEqSpec )
+                          dataConUnivTyVars, dataConExTyVars, dataConEqSpec,
+                          dataConOrigArgTys )
 import PrimOp          ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
 import Id              ( Id, idType, globalIdDetails, idNewStrictness, 
                          mkWildId, idArity, idName, idUnfolding, idInfo,
@@ -679,8 +680,13 @@ deepCast ty tyVars co
     -- coArgs = [right (left (left co)), right (left co), right co]
     coArgs = decomposeCo (length tyVars) co
 
--- This goes here to avoid circularity between DataCon and Id
-dataConInstPat :: [Unique]                  -- A long enough list of uniques, at least one for each binder
+-- These InstPat functions go here to avoid circularity between DataCon and Id
+dataConOrigInstPat   = dataConInstPat dataConOrigArgTys
+dataConRepInstPat    = dataConInstPat dataConRepArgTys
+dataConRepOccInstPat = dataConOccInstPat dataConRepArgTys
+
+dataConInstPat :: (DataCon -> [Type])       -- function used to find arg tys
+               -> [Unique]                  -- A long enough list of uniques, at least one for each binder
                -> DataCon
               -> [Type]                    -- Types to instantiate the universally quantified tyvars
               -> ([TyVar], [CoVar], [Id])  -- Return instantiated variables
@@ -710,8 +716,8 @@ dataConInstPat :: [Unique]                  -- A long enough list of uniques, at
 --  ([a1'', a2'', b''],[c :: (a1',a2'):=:(a1'',a2'')],[x :: Int,y :: b''])
 --
 --  where the double-primed variables are created from the unique list input
-dataConInstPat uniqs con inst_tys 
-  = dataConOccInstPat uniqs occs con inst_tys
+dataConInstPat arg_fun uniqs con inst_tys 
+  = dataConOccInstPat arg_fun uniqs occs con inst_tys
   where
      -- dataConOccInstPat doesn't actually make use of the OccName directly for
      -- existential and coercion variable binders, so it is right to just
@@ -719,7 +725,8 @@ dataConInstPat uniqs con inst_tys
     occs      = mk_occs 1
     mk_occs n = mkVarOcc ("ipv" ++ show n) : mk_occs (n+1)
 
-dataConOccInstPat :: [Unique]                  -- A long enough list of uniques, at least one for each binder
+dataConOccInstPat :: (DataCon -> [Type])       -- function used to find arg tys
+                  -> [Unique]                  -- A long enough list of uniques, at least one for each binder
                   -> [OccName]                 -- An equally long list of OccNames to use
                   -> DataCon
                  -> [Type]                    -- Types to instantiate the universally quantified tyvars
@@ -727,12 +734,12 @@ dataConOccInstPat :: [Unique]                  -- A long enough list of uniques,
 -- This function actually does the job specified in the comment for 
 -- dataConInstPat, but uses the specified list of OccNames.  This is 
 -- is necessary for use in e.g. tcIfaceDataAlt
-dataConOccInstPat uniqs occs con inst_tys 
+dataConOccInstPat arg_fun uniqs occs con inst_tys 
   = (ex_bndrs, co_bndrs, id_bndrs)
   where 
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
-    arg_tys  = dataConRepArgTys con
+    arg_tys  = arg_fun con
     eq_spec  = dataConEqSpec con
     eq_preds = eqSpecPreds eq_spec
 
@@ -1161,8 +1168,7 @@ eta_expand n us expr ty
               Lam lam_tv (eta_expand n us2 (App expr (Type (mkTyVarTy lam_tv))) (substTyWith [tv] [mkTyVarTy lam_tv] ty'))
                   where 
                     lam_tv = mkTyVar (mkSysTvName uniq FSLIT("etaT")) (tyVarKind tv)
-                    (uniq:us2) = us
-
+                    (uniq:us2) = us 
        ; Nothing ->
   
        case splitFunTy_maybe ty of {

diff --git a/compiler/iface/TcIface.lhs b/compiler/iface/TcIface.lhs
index 051ec04..6d95d08 100644 (file)
--- a/compiler/iface/TcIface.lhs
+++ b/compiler/iface/TcIface.lhs
@@ -35,7 +35,7 @@ import HscTypes               ( ExternalPackageState(..),
                          emptyModDetails, lookupTypeEnv, lookupType, typeEnvIds )
 import InstEnv         ( Instance(..), mkImportedInstance )
 import CoreSyn
-import CoreUtils       ( exprType, dataConOccInstPat )
+import CoreUtils       ( exprType, dataConRepOccInstPat )
 import CoreUnfold
 import CoreLint                ( lintUnfolding )
 import WorkWrap                ( mkWrapper )

diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs
index 0dde73d..f477038 100644 (file)
--- a/compiler/simplCore/Simplify.lhs
+++ b/compiler/simplCore/Simplify.lhs
@@ -45,7 +45,7 @@ import CoreUtils      ( exprIsDupable, exprIsTrivial, needsCaseBinding,
                          exprType, exprIsHNF, findDefault, mergeAlts,
                          exprOkForSpeculation, exprArity, 
                          mkCoerce, mkSCC, mkInlineMe, applyTypeToArg,
-                          dataConInstPat
+                          dataConRepInstPat
                        )
 import Rules           ( lookupRule )
 import BasicTypes      ( isMarkedStrict )
@@ -1555,7 +1555,7 @@ simplDefault env case_bndr' imposs_cons cont (Just rhs)
                 do { tick (FillInCaseDefault case_bndr')
                     ; us <- getUniquesSmpl
                     ; let (ex_tvs, co_tvs, arg_ids) =
-                              dataConInstPat us con inst_tys
+                              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