Merge branch 'master' of http://darcs.haskell.org/ghc into ghc-generics
authorJose Pedro Magalhaes <jpm@cs.uu.nl>
Thu, 12 May 2011 11:26:03 +0000 (13:26 +0200)
committerJose Pedro Magalhaes <jpm@cs.uu.nl>
Thu, 12 May 2011 11:26:03 +0000 (13:26 +0200)
Resolved conflicts:
compiler/typecheck/TcTyClsDecls.lhs

136 files changed:
compiler/basicTypes/DataCon.lhs
compiler/basicTypes/Id.lhs
compiler/basicTypes/IdInfo.lhs
compiler/basicTypes/IdInfo.lhs-boot
compiler/basicTypes/MkId.lhs
compiler/basicTypes/Var.lhs
compiler/basicTypes/VarEnv.lhs
compiler/basicTypes/VarSet.lhs
compiler/cmm/CmmCPS.hs
compiler/cmm/CmmParse.y
compiler/coreSyn/CoreArity.lhs
compiler/coreSyn/CoreFVs.lhs
compiler/coreSyn/CoreLint.lhs
compiler/coreSyn/CorePrep.lhs
compiler/coreSyn/CoreSubst.lhs
compiler/coreSyn/CoreSyn.lhs
compiler/coreSyn/CoreTidy.lhs
compiler/coreSyn/CoreUnfold.lhs
compiler/coreSyn/CoreUtils.lhs
compiler/coreSyn/ExternalCore.lhs
compiler/coreSyn/MkCore.lhs
compiler/coreSyn/MkExternalCore.lhs
compiler/coreSyn/PprCore.lhs
compiler/coreSyn/PprExternalCore.lhs
compiler/deSugar/Check.lhs
compiler/deSugar/Desugar.lhs
compiler/deSugar/DsBinds.lhs
compiler/deSugar/DsCCall.lhs
compiler/deSugar/DsExpr.lhs
compiler/deSugar/DsForeign.lhs
compiler/deSugar/DsUtils.lhs
compiler/deSugar/Match.lhs
compiler/deSugar/MatchCon.lhs
compiler/ghc.cabal.in
compiler/ghci/ByteCodeGen.lhs
compiler/ghci/RtClosureInspect.hs
compiler/hsSyn/HsBinds.lhs
compiler/hsSyn/HsPat.lhs
compiler/hsSyn/HsUtils.lhs
compiler/iface/BinIface.hs
compiler/iface/BuildTyCl.lhs
compiler/iface/IfaceSyn.lhs
compiler/iface/IfaceType.lhs
compiler/iface/MkIface.lhs
compiler/iface/TcIface.lhs
compiler/main/DynFlags.hs
compiler/main/GHC.hs
compiler/main/HscTypes.lhs
compiler/main/PprTyThing.hs
compiler/main/TidyPgm.lhs
compiler/parser/ParserCore.y
compiler/prelude/PrelNames.lhs
compiler/prelude/PrelRules.lhs
compiler/prelude/TysPrim.lhs
compiler/prelude/TysWiredIn.lhs
compiler/rename/RnBinds.lhs
compiler/rename/RnNames.lhs
compiler/rename/RnTypes.lhs
compiler/simplCore/CSE.lhs
compiler/simplCore/FloatIn.lhs
compiler/simplCore/FloatOut.lhs
compiler/simplCore/LiberateCase.lhs
compiler/simplCore/OccurAnal.lhs
compiler/simplCore/SAT.lhs
compiler/simplCore/SetLevels.lhs
compiler/simplCore/SimplEnv.lhs
compiler/simplCore/SimplUtils.lhs
compiler/simplCore/Simplify.lhs
compiler/specialise/Rules.lhs
compiler/specialise/SpecConstr.lhs
compiler/specialise/Specialise.lhs
compiler/stgSyn/CoreToStg.lhs
compiler/stgSyn/StgSyn.lhs
compiler/stranal/DmdAnal.lhs
compiler/stranal/WorkWrap.lhs
compiler/stranal/WwLib.lhs
compiler/typecheck/FamInst.lhs
compiler/typecheck/Inst.lhs
compiler/typecheck/TcArrows.lhs
compiler/typecheck/TcBinds.lhs
compiler/typecheck/TcCanonical.lhs
compiler/typecheck/TcDeriv.lhs
compiler/typecheck/TcEnv.lhs
compiler/typecheck/TcErrors.lhs
compiler/typecheck/TcExpr.lhs
compiler/typecheck/TcGenDeriv.lhs
compiler/typecheck/TcHsSyn.lhs
compiler/typecheck/TcHsType.lhs
compiler/typecheck/TcInstDcls.lhs
compiler/typecheck/TcInteract.lhs
compiler/typecheck/TcMType.lhs
compiler/typecheck/TcMatches.lhs
compiler/typecheck/TcPat.lhs
compiler/typecheck/TcRnDriver.lhs
compiler/typecheck/TcRnMonad.lhs
compiler/typecheck/TcRnTypes.lhs
compiler/typecheck/TcRules.lhs
compiler/typecheck/TcSMonad.lhs
compiler/typecheck/TcSimplify.lhs
compiler/typecheck/TcSplice.lhs
compiler/typecheck/TcTyClsDecls.lhs
compiler/typecheck/TcTyDecls.lhs
compiler/typecheck/TcType.lhs
compiler/typecheck/TcUnify.lhs
compiler/typecheck/TcUnify.lhs-boot
compiler/types/Coercion.lhs
compiler/types/FamInstEnv.lhs
compiler/types/FunDeps.lhs
compiler/types/InstEnv.lhs
compiler/types/Kind.lhs [new file with mode: 0644]
compiler/types/OptCoercion.lhs
compiler/types/TyCon.lhs
compiler/types/Type.lhs
compiler/types/TypeRep.lhs
compiler/types/TypeRep.lhs-boot
compiler/types/Unify.lhs
compiler/utils/Pair.lhs [new file with mode: 0644]
compiler/vectorise/Vectorise.hs
compiler/vectorise/Vectorise/Builtins/Base.hs
compiler/vectorise/Vectorise/Builtins/Initialise.hs
compiler/vectorise/Vectorise/Exp.hs
compiler/vectorise/Vectorise/Type/Env.hs
compiler/vectorise/Vectorise/Type/PRepr.hs
compiler/vectorise/Vectorise/Type/Type.hs
compiler/vectorise/Vectorise/Utils.hs
compiler/vectorise/Vectorise/Utils/Base.hs
compiler/vectorise/Vectorise/Utils/Closure.hs
compiler/vectorise/Vectorise/Utils/Hoisting.hs
compiler/vectorise/Vectorise/Utils/PADict.hs
compiler/vectorise/Vectorise/Utils/Poly.hs
compiler/vectorise/Vectorise/Var.hs
docs/users_guide/debugging.xml
docs/users_guide/flags.xml
ghc/GhciTags.hs
rts/Schedule.c
rts/Stats.c

index 5a62326..312ae94 100644 (file)
@@ -18,7 +18,7 @@ module DataCon (
        dataConName, dataConIdentity, dataConTag, dataConTyCon, 
         dataConOrigTyCon, dataConUserType,
        dataConUnivTyVars, dataConExTyVars, dataConAllTyVars, 
-       dataConEqSpec, eqSpecPreds, dataConEqTheta, dataConDictTheta,
+       dataConEqSpec, eqSpecPreds, dataConTheta,
        dataConStupidTheta,  
        dataConInstArgTys, dataConOrigArgTys, dataConOrigResTy,
        dataConInstOrigArgTys, dataConRepArgTys, 
@@ -31,7 +31,7 @@ module DataCon (
        
        -- ** Predicates on DataCons
        isNullarySrcDataCon, isNullaryRepDataCon, isTupleCon, isUnboxedTupleCon,
-       isVanillaDataCon, classDataCon, 
+       isVanillaDataCon, classDataCon, dataConCannotMatch,
 
         -- * Splitting product types
        splitProductType_maybe, splitProductType, deepSplitProductType,
@@ -41,6 +41,7 @@ module DataCon (
 #include "HsVersions.h"
 
 import Type
+import Unify
 import Coercion
 import TyCon
 import Class
@@ -57,7 +58,6 @@ import Module
 import qualified Data.Data as Data
 import Data.Char
 import Data.Word
-import Data.List ( partition )
 \end{code}
 
 
@@ -256,8 +256,7 @@ data DataCon
        --      dcUnivTyVars  = [a]
        --      dcExTyVars    = [x,y]
        --      dcEqSpec      = [a~(x,y)]
-       --      dcEqTheta     = [x~y]   
-       --      dcDictTheta   = [Ord x]
+       --      dcOtherTheta  = [x~y, Ord x]    
        --      dcOrigArgTys  = [a,List b]
        --      dcRepTyCon       = T
 
@@ -265,7 +264,7 @@ data DataCon
                                --          Its type is of form
                                --              forall a1..an . t1 -> ... tm -> T a1..an
                                --          No existentials, no coercions, nothing.
-                               -- That is: dcExTyVars = dcEqSpec = dcEqTheta = dcDictTheta = []
+                               -- That is: dcExTyVars = dcEqSpec = dcOtherTheta = []
                -- NB 1: newtypes always have a vanilla data con
                -- NB 2: a vanilla constructor can still be declared in GADT-style 
                --       syntax, provided its type looks like the above.
@@ -300,8 +299,8 @@ data DataCon
                -- In GADT form, this is *exactly* what the programmer writes, even if
                -- the context constrains only universally quantified variables
                --      MkT :: forall a b. (a ~ b, Ord b) => a -> T a b
-       dcEqTheta   :: ThetaType,  -- The *equational* constraints
-       dcDictTheta :: ThetaType,  -- The *type-class and implicit-param* constraints
+       dcOtherTheta :: ThetaType,  -- The other constraints in the data con's type
+                                   -- other than those in the dcEqSpec
 
        dcStupidTheta :: ThetaType,     -- The context of the data type declaration 
                                        --      data Eq a => T a = ...
@@ -338,9 +337,9 @@ data DataCon
                -- length = 0 (if not a record) or dataConSourceArity.
 
        -- Constructor representation
-       dcRepArgTys :: [Type],          -- Final, representation argument types, 
-                                       -- after unboxing and flattening,
-                                       -- and *including* existential dictionaries
+       dcRepArgTys :: [Type],  -- Final, representation argument types, 
+                               -- after unboxing and flattening,
+                               -- and *including* all existential evidence args
 
        dcRepStrictness :: [StrictnessMark],
                 -- One for each *representation* *value* argument
@@ -519,8 +518,8 @@ mkDataCon name declared_infix
                  dcVanilla = is_vanilla, dcInfix = declared_infix,
                  dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, 
                  dcEqSpec = eq_spec, 
+                 dcOtherTheta = theta,
                  dcStupidTheta = stupid_theta, 
-                 dcEqTheta = eq_theta, dcDictTheta = dict_theta,
                  dcOrigArgTys = orig_arg_tys, dcOrigResTy = orig_res_ty,
                  dcRepTyCon = rep_tycon, 
                  dcRepArgTys = rep_arg_tys,
@@ -536,10 +535,9 @@ mkDataCon name declared_infix
        -- The 'arg_stricts' passed to mkDataCon are simply those for the
        -- source-language arguments.  We add extra ones for the
        -- dictionary arguments right here.
-    (eq_theta,dict_theta)  = partition isEqPred theta
-    dict_tys              = mkPredTys dict_theta
-    real_arg_tys          = dict_tys ++ orig_arg_tys
-    real_stricts          = map mk_dict_strict_mark dict_theta ++ arg_stricts
+    full_theta   = eqSpecPreds eq_spec ++ theta
+    real_arg_tys = mkPredTys full_theta               ++ orig_arg_tys
+    real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
 
        -- Representation arguments and demands
        -- To do: eliminate duplication with MkId
@@ -547,11 +545,6 @@ mkDataCon name declared_infix
 
     tag = assoc "mkDataCon" (tyConDataCons rep_tycon `zip` [fIRST_TAG..]) con
     ty  = mkForAllTys univ_tvs $ mkForAllTys ex_tvs $ 
-         mkFunTys (mkPredTys (eqSpecPreds eq_spec)) $
-         mkFunTys (mkPredTys eq_theta) $
-               -- NB:  the dict args are already in rep_arg_tys
-               --      because they might be flattened..
-               --      but the equality predicates are not
          mkFunTys rep_arg_tys $
          mkTyConApp rep_tycon (mkTyVarTys univ_tvs)
 
@@ -611,13 +604,10 @@ dataConAllTyVars (MkData { dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs })
 dataConEqSpec :: DataCon -> [(TyVar,Type)]
 dataConEqSpec = dcEqSpec
 
--- | The equational constraints on the data constructor type
-dataConEqTheta :: DataCon -> ThetaType
-dataConEqTheta = dcEqTheta
-
--- | The type class and implicit parameter contsraints on the data constructor type
-dataConDictTheta :: DataCon -> ThetaType
-dataConDictTheta = dcDictTheta
+-- | The *full* constraints on the constructor type
+dataConTheta :: DataCon -> ThetaType
+dataConTheta (MkData { dcEqSpec = eq_spec, dcOtherTheta = theta }) 
+  = eqSpecPreds eq_spec ++ theta
 
 -- | Get the Id of the 'DataCon' worker: a function that is the "actual"
 -- constructor and has no top level binding in the program. The type may
@@ -666,10 +656,10 @@ dataConFieldType con label
 dataConStrictMarks :: DataCon -> [HsBang]
 dataConStrictMarks = dcStrictMarks
 
--- | Strictness of /existential/ arguments only
+-- | Strictness of evidence arguments to the wrapper function
 dataConExStricts :: DataCon -> [HsBang]
 -- Usually empty, so we don't bother to cache this
-dataConExStricts dc = map mk_dict_strict_mark $ dcDictTheta dc
+dataConExStricts dc = map mk_dict_strict_mark $ (dataConTheta dc)
 
 -- | Source-level arity of the data constructor
 dataConSourceArity :: DataCon -> Arity
@@ -705,10 +695,10 @@ dataConRepStrictness dc = dcRepStrictness dc
 --
 -- 4) The /original/ result type of the 'DataCon'
 dataConSig :: DataCon -> ([TyVar], ThetaType, [Type], Type)
-dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
-                   dcEqTheta  = eq_theta, dcDictTheta = dict_theta, 
+dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, 
+                   dcEqSpec = eq_spec, dcOtherTheta  = theta, 
                    dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
-  = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ eq_theta ++ dict_theta, arg_tys, res_ty)
+  = (univ_tvs ++ ex_tvs, eqSpecPreds eq_spec ++ theta, arg_tys, res_ty)
 
 -- | The \"full signature\" of the 'DataCon' returns, in order:
 --
@@ -725,11 +715,11 @@ dataConSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_
 --
 -- 6) The original result type of the 'DataCon'
 dataConFullSig :: DataCon 
-              -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, ThetaType, [Type], Type)
-dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
-                       dcEqTheta = eq_theta, dcDictTheta = dict_theta, 
+              -> ([TyVar], [TyVar], [(TyVar,Type)], ThetaType, [Type], Type)
+dataConFullSig (MkData {dcUnivTyVars = univ_tvs, dcExTyVars = ex_tvs, 
+                       dcEqSpec = eq_spec, dcOtherTheta = theta,
                        dcOrigArgTys = arg_tys, dcOrigResTy = res_ty})
-  = (univ_tvs, ex_tvs, eq_spec, eq_theta, dict_theta, arg_tys, res_ty)
+  = (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, res_ty)
 
 dataConOrigResTy :: DataCon -> Type
 dataConOrigResTy dc = dcOrigResTy dc
@@ -754,11 +744,10 @@ dataConUserType :: DataCon -> Type
 -- mentions the family tycon, not the internal one.
 dataConUserType  (MkData { dcUnivTyVars = univ_tvs, 
                           dcExTyVars = ex_tvs, dcEqSpec = eq_spec,
-                          dcEqTheta = eq_theta, dcDictTheta = dict_theta, dcOrigArgTys = arg_tys,
+                          dcOtherTheta = theta, dcOrigArgTys = arg_tys,
                           dcOrigResTy = res_ty })
   = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
-    mkFunTys (mkPredTys eq_theta) $
-    mkFunTys (mkPredTys dict_theta) $
+    mkFunTys (mkPredTys theta) $
     mkFunTys arg_tys $
     res_ty
 
@@ -841,6 +830,25 @@ classDataCon clas = case tyConDataCons (classTyCon clas) of
                      [] -> panic "classDataCon"
 \end{code}
 
+\begin{code}
+dataConCannotMatch :: [Type] -> DataCon -> Bool
+-- Returns True iff the data con *definitely cannot* match a 
+--                 scrutinee of type (T tys)
+--                 where T is the type constructor for the data con
+-- NB: look at *all* equality constraints, not only those
+--     in dataConEqSpec; see Trac #5168
+dataConCannotMatch tys con
+  | null theta        = False  -- Common
+  | all isTyVarTy tys = False  -- Also common
+  | otherwise
+  = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
+                   | EqPred ty1 ty2 <- theta ]
+  where
+    dc_tvs  = dataConUnivTyVars con
+    theta   = dataConTheta con
+    subst   = zipTopTvSubst dc_tvs tys
+\end{code}
+
 %************************************************************************
 %*                                                                     *
 \subsection{Splitting products}
index fd65fe4..5ac2612 100644 (file)
@@ -23,7 +23,7 @@
 -- * 'Var.Var': see "Var#name_types"
 module Id (
         -- * The main types
-       Id, DictId,
+       Var, Id, isId,
 
        -- ** Simple construction
        mkGlobalId, mkVanillaGlobal, mkVanillaGlobalWithInfo,
@@ -34,8 +34,7 @@ module Id (
 
        -- ** Taking an Id apart
        idName, idType, idUnique, idInfo, idDetails,
-       isId, idPrimRep,
-       recordSelectorFieldLabel,
+       idPrimRep, recordSelectorFieldLabel,
 
        -- ** Modifying an Id
        setIdName, setIdUnique, Id.setIdType, 
@@ -46,7 +45,8 @@ module Id (
        
 
        -- ** Predicates on Ids
-       isImplicitId, isDeadBinder, isDictId, isStrictId,
+       isImplicitId, isDeadBinder, 
+        isStrictId,
        isExportedId, isLocalId, isGlobalId,
        isRecordSelector, isNaughtyRecordSelector,
         isClassOpId_maybe, isDFunId, dfunNSilent,
@@ -57,6 +57,9 @@ module Id (
         isTickBoxOp, isTickBoxOp_maybe,
        hasNoBinding, 
 
+       -- ** Evidence variables
+       DictId, isDictId, isEvVar, evVarPred,
+
        -- ** Inline pragma stuff
        idInlinePragma, setInlinePragma, modifyInlinePragma,
         idInlineActivation, setInlineActivation, idRuleMatchInfo,
@@ -95,8 +98,8 @@ import IdInfo
 import BasicTypes
 
 -- Imported and re-exported 
-import Var( Var, Id, DictId,
-            idInfo, idDetails, globaliseId,
+import Var( Var, Id, DictId, EvVar,
+            idInfo, idDetails, globaliseId, varType,
             isId, isLocalId, isGlobalId, isExportedId )
 import qualified Var
 
@@ -372,10 +375,6 @@ idDataCon :: Id -> DataCon
 -- INVARIANT: @idDataCon (dataConWrapId d) = d@: remember, 'dataConWrapId' can return either the wrapper or the worker
 idDataCon id = isDataConId_maybe id `orElse` pprPanic "idDataCon" (ppr id)
 
-
-isDictId :: Id -> Bool
-isDictId id = isDictTy (idType id)
-
 hasNoBinding :: Id -> Bool
 -- ^ Returns @True@ of an 'Id' which may not have a
 -- binding, even though it is defined in this module.
@@ -448,6 +447,26 @@ isTickBoxOp_maybe id =
 
 %************************************************************************
 %*                                                                     *
+              Evidence variables                                                                       
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+isEvVar :: Var -> Bool
+isEvVar var = isPredTy (varType var)
+
+isDictId :: Id -> Bool
+isDictId id = isDictTy (idType id)
+
+evVarPred :: EvVar -> PredType
+evVarPred var
+  = case splitPredTy_maybe (varType var) of
+      Just pred -> pred
+      Nothing   -> pprPanic "evVarPred" (ppr var <+> ppr (varType var))
+\end{code}
+
+%************************************************************************
+%*                                                                     *
 \subsection{IdInfo stuff}
 %*                                                                     *
 %************************************************************************
index ec1f122..c106f53 100644 (file)
@@ -10,7 +10,7 @@ Haskell. [WDP 94/11])
 \begin{code}
 module IdInfo (
         -- * The IdDetails type
-       IdDetails(..), pprIdDetails,
+       IdDetails(..), pprIdDetails, coVarDetails,
 
         -- * The IdInfo type
        IdInfo,         -- Abstract
@@ -141,6 +141,9 @@ data IdDetails
        --                  implemented with a newtype, so it might be bad
        --                  to be strict on this dictionary
 
+coVarDetails :: IdDetails
+coVarDetails = VanillaId
+
 instance Outputable IdDetails where
     ppr = pprIdDetails
 
index 4195156..257e1c6 100644 (file)
@@ -4,5 +4,7 @@ import Outputable
 data IdInfo
 data IdDetails
 
+vanillaIdInfo :: IdInfo
+coVarDetails :: IdDetails
 pprIdDetails :: IdDetails -> SDoc
 \end{code}
\ No newline at end of file
index a251734..c691f62 100644 (file)
@@ -25,13 +25,18 @@ module MkId (
         -- And some particular Ids; see below for why they are wired in
         wiredInIds, ghcPrimIds,
         unsafeCoerceName, unsafeCoerceId, realWorldPrimId, 
-        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey
+        voidArgId, nullAddrId, seqId, lazyId, lazyIdKey,
+        coercionTokenId,
+
+       -- Re-export error Ids
+       module PrelRules
     ) where
 
 #include "HsVersions.h"
 
 import Rules
 import TysPrim
+import TysWiredIn      ( unitTy )
 import PrelRules
 import Type
 import Coercion
@@ -48,7 +53,7 @@ import PrimOp
 import ForeignCall
 import DataCon
 import Id
-import Var              ( Var, TyVar, mkCoVar, mkExportedLocalVar )
+import Var              ( mkExportedLocalVar )
 import IdInfo
 import Demand
 import CoreSyn
@@ -56,6 +61,7 @@ import Unique
 import PrelNames
 import BasicTypes       hiding ( SuccessFlag(..) )
 import Util
+import Pair
 import Outputable
 import FastString
 import ListSetOps
@@ -224,7 +230,7 @@ mkDataConIds wrap_name wkr_name data_con
   = DCIds Nothing wrk_id
   where
     (univ_tvs, ex_tvs, eq_spec, 
-     eq_theta, dict_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
+     other_theta, orig_arg_tys, res_ty) = dataConFullSig data_con
     tycon = dataConTyCon data_con       -- The representation TyCon (not family)
 
         ----------- Worker (algebraic data types only) --------------
@@ -287,12 +293,10 @@ mkDataConIds wrap_name wkr_name data_con
         -- extra constraints where necessary.
     wrap_tvs    = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
     res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
-    eq_tys   = mkPredTys eq_theta
-    dict_tys = mkPredTys dict_theta
-    wrap_ty  = mkForAllTys wrap_tvs $ mkFunTys eq_tys $ mkFunTys dict_tys $
-               mkFunTys orig_arg_tys $ res_ty
-        -- NB: watch out here if you allow user-written equality 
-        --     constraints in data constructor signatures
+    ev_tys      = mkPredTys other_theta
+    wrap_ty     = mkForAllTys wrap_tvs $ 
+                  mkFunTys ev_tys $
+                  mkFunTys orig_arg_tys $ res_ty
 
         ----------- Wrappers for algebraic data types -------------- 
     alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
@@ -305,8 +309,9 @@ mkDataConIds wrap_name wkr_name data_con
                     `setStrictnessInfo` Just wrap_sig
 
     all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
-    wrap_sig = mkStrictSig (mkTopDmdType arg_dmds cpr_info)
-    arg_dmds = map mk_dmd all_strict_marks
+    wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
+    wrap_stricts = dropList eq_spec all_strict_marks
+    wrap_arg_dmds = map mk_dmd wrap_stricts
     mk_dmd str | isBanged str = evalDmd
                | otherwise    = lazyDmd
         -- The Cpr info can be important inside INLINE rhss, where the
@@ -318,32 +323,26 @@ mkDataConIds wrap_name wkr_name data_con
         --      ...(let w = C x in ...(w p q)...)...
         -- we want to see that w is strict in its two arguments
 
-    wrap_unf = mkInlineUnfolding (Just (length dict_args + length id_args)) wrap_rhs
+    wrap_unf = mkInlineUnfolding (Just (length ev_args + length id_args)) wrap_rhs
     wrap_rhs = mkLams wrap_tvs $ 
-               mkLams eq_args $
-               mkLams dict_args $ mkLams id_args $
+               mkLams ev_args $
+               mkLams id_args $
                foldr mk_case con_app 
-                     (zip (dict_args ++ id_args) all_strict_marks)
+                     (zip (ev_args ++ id_args) wrap_stricts)
                      i3 []
+            -- The ev_args is the evidence arguments *other than* the eq_spec
+            -- Because we are going to apply the eq_spec args manually in the
+            -- wrapper
 
     con_app _ rep_ids = wrapFamInstBody tycon res_ty_args $
                           Var wrk_id `mkTyApps`  res_ty_args
                                      `mkVarApps` ex_tvs                 
-                                     -- Equality evidence:
-                                     `mkTyApps`  map snd eq_spec
-                                     `mkVarApps` eq_args
+                                     `mkCoApps`  map (mkReflCo . snd) eq_spec
                                      `mkVarApps` reverse rep_ids
 
-    (dict_args,i2) = mkLocals 1  dict_tys
-    (id_args,i3)   = mkLocals i2 orig_arg_tys
-    wrap_arity     = i3-1
-    (eq_args,_)    = mkCoVarLocals i3 eq_tys
-
-    mkCoVarLocals i []     = ([],i)
-    mkCoVarLocals i (x:xs) = let (ys,j) = mkCoVarLocals (i+1) xs
-                                 y      = mkCoVar (mkSysTvName (mkBuiltinUnique i) 
-                                                  (fsLit "dc_co")) x
-                             in (y:ys,j)
+    (ev_args,i2) = mkLocals 1  ev_tys
+    (id_args,i3) = mkLocals i2 orig_arg_tys
+    wrap_arity   = i3-1
 
     mk_case 
            :: (Id, HsBang)      -- Arg, strictness
@@ -458,7 +457,7 @@ mkDictSelId no_unf name clas
                                     occNameFS (getOccName name)
                        , ru_fn    = name
                       , ru_nargs = n_ty_args + 1
-                       , ru_try   = dictSelRule val_index n_ty_args n_eq_args }
+                       , ru_try   = dictSelRule val_index n_ty_args }
 
         -- The strictness signature is of the form U(AAAVAAAA) -> T
         -- where the V depends on which item we are selecting
@@ -474,8 +473,6 @@ mkDictSelId no_unf name clas
     [data_con]            = tyConDataCons tycon
     tyvars                = dataConUnivTyVars data_con
     arg_tys               = dataConRepArgTys data_con  -- Includes the dictionary superclasses
-    eq_theta              = dataConEqTheta data_con
-    n_eq_args      = length eq_theta
 
     -- 'index' is a 0-index into the *value* arguments of the dictionary
     val_index      = assoc "MkId.mkDictSelId" sel_index_prs name
@@ -485,25 +482,23 @@ mkDictSelId no_unf name clas
     pred                  = mkClassPred clas (mkTyVarTys tyvars)
     dict_id               = mkTemplateLocal 1 $ mkPredTy pred
     arg_ids               = mkTemplateLocalsNum 2 arg_tys
-    eq_ids                = map mkWildEvBinder eq_theta
 
     rhs = mkLams tyvars  (Lam dict_id   rhs_body)
     rhs_body | new_tycon = unwrapNewTypeBody tycon (map mkTyVarTy tyvars) (Var dict_id)
              | otherwise = Case (Var dict_id) dict_id (idType the_arg_id)
-                                [(DataAlt data_con, eq_ids ++ arg_ids, Var the_arg_id)]
+                                [(DataAlt data_con, arg_ids, Var the_arg_id)]
 
-dictSelRule :: Int -> Arity -> Arity 
+dictSelRule :: Int -> Arity 
             -> IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
 -- Tries to persuade the argument to look like a constructor
 -- application, using exprIsConApp_maybe, and then selects
 -- from it
 --       sel_i t1..tk (D t1..tk op1 ... opm) = opi
 --
-dictSelRule val_index n_ty_args n_eq_args id_unf args
+dictSelRule val_index n_ty_args id_unf args
   | (dict_arg : _) <- drop n_ty_args args
   , Just (_, _, con_args) <- exprIsConApp_maybe id_unf dict_arg
-  , let val_args = drop n_eq_args con_args
-  = Just (val_args !! val_index)
+  = Just (con_args !! val_index)
   | otherwise
   = Nothing
 \end{code}
@@ -607,7 +602,7 @@ mkProductBox arg_ids ty
 mkReboxingAlt
   :: [Unique] -- Uniques for the new Ids
   -> DataCon
-  -> [Var]    -- Source-level args, including existential dicts
+  -> [Var]    -- Source-level args, *including* all evidence vars 
   -> CoreExpr -- RHS
   -> CoreAlt
 
@@ -628,15 +623,14 @@ mkReboxingAlt us con args rhs
 
     -- Type variable case
     go (arg:args) stricts us 
-      | isTyCoVar arg
+      | isTyVar arg
       = let (binds, args') = go args stricts us
         in  (binds, arg:args')
 
         -- Term variable case
     go (arg:args) (str:stricts) us
       | isMarkedUnboxed str
-      = 
-        let (binds, unpacked_args')        = go args stricts us'
+      = let (binds, unpacked_args')        = go args stricts us'
             (us', bind_rhs, unpacked_args) = reboxProduct us (idType arg)
         in
             (NonRec arg bind_rhs : binds, unpacked_args ++ unpacked_args')
@@ -674,13 +668,11 @@ wrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 -- coercion constructor of the newtype or applied by itself).
 
 wrapNewTypeBody tycon args result_expr
-  = wrapFamInstBody tycon args inner
+  = ASSERT( isNewTyCon tycon )
+    wrapFamInstBody tycon args $
+    mkCoerce (mkSymCo co) result_expr
   where
-    inner
-      | Just co_con <- newTyConCo_maybe tycon
-      = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) result_expr
-      | otherwise
-      = result_expr
+    co = mkAxInstCo (newTyConCo tycon) args
 
 -- When unwrapping, we do *not* apply any family coercion, because this will
 -- be done via a CoPat by the type checker.  We have to do it this way as
@@ -689,10 +681,8 @@ wrapNewTypeBody tycon args result_expr
 
 unwrapNewTypeBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapNewTypeBody tycon args result_expr
-  | Just co_con <- newTyConCo_maybe tycon
-  = mkCoerce (mkTyConApp co_con args) result_expr
-  | otherwise
-  = result_expr
+  = ASSERT( isNewTyCon tycon )
+    mkCoerce (mkAxInstCo (newTyConCo tycon) args) result_expr
 
 -- If the type constructor is a representation type of a data instance, wrap
 -- the expression into a cast adjusting the expression type, which is an
@@ -702,14 +692,14 @@ unwrapNewTypeBody tycon args result_expr
 wrapFamInstBody :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 wrapFamInstBody tycon args body
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkSymCoercion (mkTyConApp co_con args)) body
+  = mkCoerce (mkSymCo (mkAxInstCo co_con args)) body
   | otherwise
   = body
 
 unwrapFamInstScrut :: TyCon -> [Type] -> CoreExpr -> CoreExpr
 unwrapFamInstScrut tycon args scrut
   | Just co_con <- tyConFamilyCoercion_maybe tycon
-  = mkCoerce (mkTyConApp co_con args) scrut
+  = mkCoerce (mkAxInstCo co_con args) scrut
   | otherwise
   = scrut
 \end{code}
@@ -853,7 +843,7 @@ mkDictFunTy tvs theta clas tys
                               (classSCTheta clas)
                    -- See Note [Silent Superclass Arguments]
     discard pred = isEmptyVarSet (tyVarsOfPred pred)
-                 || any (`tcEqPred` pred) theta
+                 || any (`eqPred` pred) theta
                  -- See the DFun Superclass Invariant in TcInstDcls
 \end{code}
 
@@ -880,12 +870,13 @@ they can unify with both unlifted and lifted types.  Hence we provide
 another gun with which to shoot yourself in the foot.
 
 \begin{code}
-lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName :: Name
-unsafeCoerceName = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
-nullAddrName     = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
-seqName          = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
-realWorldName    = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
-lazyIdName       = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
+lazyIdName, unsafeCoerceName, nullAddrName, seqName, realWorldName, coercionTokenName :: Name
+unsafeCoerceName  = mkWiredInIdName gHC_PRIM (fsLit "unsafeCoerce#") unsafeCoerceIdKey  unsafeCoerceId
+nullAddrName      = mkWiredInIdName gHC_PRIM (fsLit "nullAddr#")     nullAddrIdKey      nullAddrId
+seqName           = mkWiredInIdName gHC_PRIM (fsLit "seq")           seqIdKey           seqId
+realWorldName     = mkWiredInIdName gHC_PRIM (fsLit "realWorld#")    realWorldPrimIdKey realWorldPrimId
+lazyIdName        = mkWiredInIdName gHC_BASE (fsLit "lazy")         lazyIdKey           lazyId
+coercionTokenName = mkWiredInIdName gHC_PRIM (fsLit "coercionToken#") coercionTokenIdKey coercionTokenId
 \end{code}
 
 \begin{code}
@@ -903,7 +894,7 @@ unsafeCoerceId
                       (mkFunTy argAlphaTy openBetaTy)
     [x] = mkTemplateLocals [argAlphaTy]
     rhs = mkLams [argAlphaTyVar,openBetaTyVar,x] $
-          Cast (Var x) (mkUnsafeCoercion argAlphaTy openBetaTy)
+          Cast (Var x) (mkUnsafeCo argAlphaTy openBetaTy)
 
 ------------------------------------------------
 nullAddrId :: Id
@@ -939,7 +930,7 @@ seqId = pcMiscPrelId seqName ty info
 match_seq_of_cast :: IdUnfoldingFun -> [CoreExpr] -> Maybe CoreExpr
     -- See Note [Built-in RULES for seq]
 match_seq_of_cast _ [Type _, Type res_ty, Cast scrut co, expr]
-  = Just (Var seqId `mkApps` [Type (fst (coercionKind co)), Type res_ty,
+  = Just (Var seqId `mkApps` [Type (pFst (coercionKind co)), Type res_ty,
                               scrut, expr])
 match_seq_of_cast _ _ = Nothing
 
@@ -1049,6 +1040,12 @@ realWorldPrimId -- :: State# RealWorld
 voidArgId :: Id
 voidArgId       -- :: State# RealWorld
   = mkSysLocal (fsLit "void") voidArgIdKey realWorldStatePrimTy
+
+coercionTokenId :: Id        -- :: () ~ ()
+coercionTokenId -- Used to replace Coercion terms when we go to STG
+  = pcMiscPrelId coercionTokenName 
+                 (mkTyConApp eqPredPrimTyCon [unitTy, unitTy])
+                 noCafIdInfo
 \end{code}
 
 
index 13810da..3c3ff7f 100644 (file)
@@ -32,7 +32,7 @@
 
 module Var (
         -- * The main data type and synonyms
-       Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
+        Var, TyVar, CoVar, TyCoVar, Id, DictId, DFunId, EvVar, EvId, IpId,
 
        -- ** Taking 'Var's apart
        varName, varUnique, varType, 
@@ -41,34 +41,25 @@ module Var (
        setVarName, setVarUnique, setVarType,
 
        -- ** Constructing, taking apart, modifying 'Id's
-       mkGlobalVar, mkLocalVar, mkExportedLocalVar, 
+       mkGlobalVar, mkLocalVar, mkExportedLocalVar, mkCoVar,
        idInfo, idDetails,
        lazySetIdInfo, setIdDetails, globaliseId,
        setIdExported, setIdNotExported,
 
         -- ** Predicates
-        isCoVar, isId, isTyCoVar, isTyVar, isTcTyVar,
+        isId, isTyVar, isTcTyVar,
         isLocalVar, isLocalId,
        isGlobalId, isExportedId,
        mustHaveLocalBinding,
 
        -- ** Constructing 'TyVar's
-       mkTyVar, mkTcTyVar, mkWildCoVar,
+       mkTyVar, mkTcTyVar, 
 
        -- ** Taking 'TyVar's apart
         tyVarName, tyVarKind, tcTyVarDetails, setTcTyVarDetails,
 
        -- ** Modifying 'TyVar's
-       setTyVarName, setTyVarUnique, setTyVarKind,
-
-        -- ** Constructing 'CoVar's
-        mkCoVar,
-
-        -- ** Taking 'CoVar's apart
-        coVarName,
-
-        -- ** Modifying 'CoVar's
-        setCoVarUnique, setCoVarName
+       setTyVarName, setTyVarUnique, setTyVarKind
 
     ) where
 
@@ -77,8 +68,7 @@ module Var (
 
 import {-# SOURCE #-}  TypeRep( Type, Kind )
 import {-# SOURCE #-}  TcType( TcTyVarDetails, pprTcTyVarDetails )
-import {-# SOURCE #-}  IdInfo( IdDetails, IdInfo, pprIdDetails )
-import {-# SOURCE #-}  TypeRep( isCoercionKind )
+import {-# SOURCE #-}  IdInfo( IdDetails, IdInfo, coVarDetails, vanillaIdInfo, pprIdDetails )
 
 import Name hiding (varName)
 import Unique
@@ -100,7 +90,7 @@ import Data.Data
 -- large number of SOURCE imports of Id.hs :-(
 
 \begin{code}
-type EvVar = Var       -- An evidence variable: dictionary or equality constraint
+type EvVar = Var        -- An evidence variable: dictionary or equality constraint
                        -- Could be an DictId or a CoVar
 
 type Id     = Var       -- A term-level identifier
@@ -110,9 +100,10 @@ type DictId = EvId -- A dictionary variable
 type IpId   = EvId      -- A term-level implicit parameter
 
 type TyVar = Var
-type CoVar = TyVar     -- A coercion variable is simply a type 
+type CoVar = Id                -- A coercion variable is simply an Id
                        -- variable of kind @ty1 ~ ty2@. Hence its
                        -- 'varType' is always @PredTy (EqPred t1 t2)@
+type TyCoVar = TyVar    -- Something that is a type OR coercion variable.
 \end{code}
 
 %************************************************************************
@@ -136,8 +127,8 @@ data Var
        realUnique :: FastInt,          -- Key for fast comparison
                                        -- Identical to the Unique in the name,
                                        -- cached here for speed
-       varType       :: Kind,          -- ^ The type or kind of the 'Var' in question
       isCoercionVar :: Bool }
+       varType       :: Kind           -- ^ The type or kind of the 'Var' in question
+ }
 
   | TcTyVar {                          -- Used only during type inference
                                        -- Used for kind variables during 
@@ -187,9 +178,8 @@ instance Outputable Var where
   ppr var = ppr (varName var) <+> ifPprDebug (brackets (ppr_debug var))
 
 ppr_debug :: Var -> SDoc
-ppr_debug (TyVar { isCoercionVar = False })   = ptext (sLit "tv")
-ppr_debug (TyVar { isCoercionVar = True })    = ptext (sLit "co")
-ppr_debug (TcTyVar {tc_tv_details = d})       = pprTcTyVarDetails d
+ppr_debug (TyVar {})                           = ptext (sLit "tv")
+ppr_debug (TcTyVar {tc_tv_details = d})        = pprTcTyVarDetails d
 ppr_debug (Id { idScope = s, id_details = d }) = ppr_id_scope s <> pprIdDetails d
 
 ppr_id_scope :: IdScope -> SDoc
@@ -268,11 +258,9 @@ setTyVarKind tv k = tv {varType = k}
 
 \begin{code}
 mkTyVar :: Name -> Kind -> TyVar
-mkTyVar name kind = ASSERT( not (isCoercionKind kind ) )
-                   TyVar { varName    = name
+mkTyVar name kind = TyVar { varName    = name
                          , realUnique = getKeyFastInt (nameUnique name)
                          , varType  = kind
-                          , isCoercionVar    = False
                        }
 
 mkTcTyVar :: Name -> Kind -> TcTyVarDetails -> TyVar
@@ -294,36 +282,6 @@ setTcTyVarDetails tv details = tv { tc_tv_details = details }
 
 %************************************************************************
 %*                                                                     *
-\subsection{Coercion variables}
-%*                                                                     *
-%************************************************************************
-
-\begin{code}
-coVarName :: CoVar -> Name
-coVarName = varName
-
-setCoVarUnique :: CoVar -> Unique -> CoVar
-setCoVarUnique = setVarUnique
-
-setCoVarName :: CoVar -> Name -> CoVar
-setCoVarName   = setVarName
-
-mkCoVar :: Name -> Kind -> CoVar
-mkCoVar name kind = ASSERT( isCoercionKind kind )
-                   TyVar { varName       = name
-                         , realUnique    = getKeyFastInt (nameUnique name)
-                         , varType       = kind
-                          , isCoercionVar = True
-                       }
-
-mkWildCoVar :: Kind -> TyVar
--- ^ Create a type variable that is never referred to, so its unique doesn't 
--- matter
-mkWildCoVar = mkCoVar (mkSysTvName (mkBuiltinUnique 1) (fsLit "co_wild"))
-\end{code}
-
-%************************************************************************
-%*                                                                     *
 \subsection{Ids}
 %*                                                                     *
 %************************************************************************
@@ -347,6 +305,10 @@ mkLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
 mkLocalVar details name ty info
   = mk_id name ty (LocalId NotExported) details  info
 
+mkCoVar :: Name -> Type -> CoVar
+-- Coercion variables have no IdInfo
+mkCoVar name ty = mk_id name ty (LocalId NotExported) coVarDetails vanillaIdInfo
+
 -- | Exported 'Var's will not be removed as dead code
 mkExportedLocalVar :: IdDetails -> Name -> Type -> IdInfo -> Id
 mkExportedLocalVar details name ty info 
@@ -392,20 +354,11 @@ setIdNotExported id = ASSERT( isLocalId id )
 %************************************************************************
 
 \begin{code}
-isTyCoVar :: Var -> Bool       -- True of both type and coercion variables
-isTyCoVar (TyVar {})   = True
-isTyCoVar (TcTyVar {}) = True
-isTyCoVar _            = False
-
-isTyVar :: Var -> Bool         -- True of both type variables only
-isTyVar v@(TyVar {}) = not (isCoercionVar v)
+isTyVar :: Var -> Bool          -- True of both type variables only
+isTyVar (TyVar {})   = True
 isTyVar (TcTyVar {}) = True
 isTyVar _            = False
 
-isCoVar :: Var -> Bool         -- Only works after type checking (sigh)
-isCoVar v@(TyVar {}) = isCoercionVar v
-isCoVar _            = False
-
 isTcTyVar :: Var -> Bool
 isTcTyVar (TcTyVar {}) = True
 isTcTyVar _            = False
index f275714..fca6256 100644 (file)
@@ -6,7 +6,7 @@
 \begin{code}
 module VarEnv (
         -- * Var, Id and TyVar environments (maps)
-       VarEnv, IdEnv, TyVarEnv,
+       VarEnv, IdEnv, TyVarEnv, CoVarEnv,
        
        -- ** Manipulating these environments
        emptyVarEnv, unitVarEnv, mkVarEnv,
@@ -29,7 +29,7 @@ module VarEnv (
        emptyInScopeSet, mkInScopeSet, delInScopeSet,
        extendInScopeSet, extendInScopeSetList, extendInScopeSetSet, 
        getInScopeVars, lookupInScope, lookupInScope_Directly, 
-        unionInScope, elemInScopeSet, uniqAway, 
+        unionInScope, elemInScopeSet, uniqAway,
 
        -- * The RnEnv2 type
        RnEnv2, 
@@ -343,6 +343,7 @@ emptyTidyEnv = (emptyTidyOccEnv, emptyVarEnv)
 type VarEnv elt   = UniqFM elt
 type IdEnv elt    = VarEnv elt
 type TyVarEnv elt = VarEnv elt
+type CoVarEnv elt = VarEnv elt
 
 emptyVarEnv      :: VarEnv a
 mkVarEnv         :: [(Var, a)] -> VarEnv a
index 6f03aad..e0ff52d 100644 (file)
@@ -6,7 +6,7 @@
 \begin{code}
 module VarSet (
         -- * Var, Id and TyVar set types
-       VarSet, IdSet, TyVarSet,
+       VarSet, IdSet, TyVarSet, TyCoVarSet, CoVarSet,
        
        -- ** Manipulating these sets
        emptyVarSet, unitVarSet, mkVarSet,
@@ -22,7 +22,7 @@ module VarSet (
 
 #include "HsVersions.h"
 
-import Var      ( Var, TyVar, Id )
+import Var      ( Var, TyVar, CoVar, TyCoVar, Id )
 import Unique
 import UniqSet
 \end{code}
@@ -37,6 +37,8 @@ import UniqSet
 type VarSet       = UniqSet Var
 type IdSet       = UniqSet Id
 type TyVarSet    = UniqSet TyVar
+type TyCoVarSet   = UniqSet TyCoVar
+type CoVarSet     = UniqSet CoVar
 
 emptyVarSet    :: VarSet
 intersectVarSet        :: VarSet -> VarSet -> VarSet
index aad0037..6e97100 100644 (file)
@@ -1,6 +1,7 @@
 {-# OPTIONS_GHC -XNoMonoLocalBinds #-}
 -- Norman likes local bindings
 -- If this module lives on I'd like to get rid of this flag in due course
+
 module CmmCPS (
   -- | Converts C-- with full proceedures and parameters
   -- to a CPS transformed C-- with the stack made manifest.
index 4dc7e32..0ee429d 100644 (file)
@@ -689,15 +689,7 @@ machOps = listToUFM $
        ( "gtu",        MO_U_Gt ),
        ( "ltu",        MO_U_Lt ),
 
-       ( "flt",        MO_S_Lt ),
-       ( "fle",        MO_S_Le ),
-       ( "feq",        MO_Eq ),
-       ( "fne",        MO_Ne ),
-       ( "fgt",        MO_S_Gt ),
-       ( "fge",        MO_S_Ge ),
-       ( "fneg",       MO_S_Neg ),
-
-       ( "and",        MO_And ),
+        ( "and",        MO_And ),
        ( "or",         MO_Or ),
        ( "xor",        MO_Xor ),
        ( "com",        MO_Not ),
@@ -705,7 +697,20 @@ machOps = listToUFM $
        ( "shrl",       MO_U_Shr ),
        ( "shra",       MO_S_Shr ),
 
-       ( "lobits8",  flip MO_UU_Conv W8  ),
+        ( "fadd",       MO_F_Add ),
+        ( "fsub",       MO_F_Sub ),
+        ( "fneg",       MO_F_Neg ),
+        ( "fmul",       MO_F_Mul ),
+        ( "fquot",      MO_F_Quot ),
+
+        ( "feq",        MO_F_Eq ),
+        ( "fne",        MO_F_Ne ),
+        ( "fge",        MO_F_Ge ),
+        ( "fle",        MO_F_Le ),
+        ( "fgt",        MO_F_Gt ),
+        ( "flt",        MO_F_Lt ),
+
+        ( "lobits8",  flip MO_UU_Conv W8  ),
        ( "lobits16", flip MO_UU_Conv W16 ),
        ( "lobits32", flip MO_UU_Conv W32 ),
        ( "lobits64", flip MO_UU_Conv W64 ),
index 678c961..0fa1c38 100644 (file)
@@ -29,6 +29,7 @@ import BasicTypes
 import Unique
 import Outputable
 import FastString
+import Pair
 \end{code}
 
 %************************************************************************
@@ -79,11 +80,13 @@ exprArity e = go e
     go (Lam x e) | isId x         = go e + 1
                 | otherwise       = go e
     go (Note n e) | notSccNote n   = go e
-    go (Cast e co)                 = go e `min` length (typeArity (snd (coercionKind co)))
-                                               -- Note [exprArity invariant]
+    go (Cast e co)                 = go e `min` length (typeArity (pSnd (coercionKind co)))
+                                        -- Note [exprArity invariant]
     go (App e (Type _))            = go e
     go (App f a) | exprIsTrivial a = (go f - 1) `max` 0
         -- See Note [exprArity for applications]
+       -- NB: coercions count as a value argument
+
     go _                          = 0
 
 
@@ -549,7 +552,7 @@ arityType cheap_fn (Lam x e)
   | isId x    = arityLam x (arityType cheap_fn e)
   | otherwise = arityType cheap_fn e
 
-       -- Applications; decrease arity
+       -- Applications; decrease arity, except for types
 arityType cheap_fn (App fun (Type _))
    = arityType cheap_fn fun
 arityType cheap_fn (App fun arg )
@@ -663,14 +666,14 @@ etaExpand n orig_expr
       -- Strip off existing lambdas and casts
       -- Note [Eta expansion and SCCs]
     go 0 expr = expr
-    go n (Lam v body) | isTyCoVar v = Lam v (go n     body)
-                             | otherwise   = Lam v (go (n-1) body)
+    go n (Lam v body) | isTyVar v = Lam v (go n     body)
+                             | otherwise = Lam v (go (n-1) body)
     go n (Cast expr co) = Cast (go n expr) co
     go n expr           = -- pprTrace "ee" (vcat [ppr orig_expr, ppr expr, ppr etas]) $
                                  etaInfoAbs etas (etaInfoApp subst' expr etas)
                        where
                            in_scope = mkInScopeSet (exprFreeVars expr)
-                           (in_scope', etas) = mkEtaWW n in_scope (exprType expr)
+                           (in_scope', etas) = mkEtaWW n orig_expr in_scope (exprType expr)
                            subst' = mkEmptySubst in_scope'
 
                                -- Wrapper    Unwrapper
@@ -685,10 +688,10 @@ instance Outputable EtaInfo where
 
 pushCoercion :: Coercion -> [EtaInfo] -> [EtaInfo]
 pushCoercion co1 (EtaCo co2 : eis)
-  | isIdentityCoercion co = eis
-  | otherwise            = EtaCo co : eis
+  | isReflCo co = eis
+  | otherwise  = EtaCo co : eis
   where
-    co = co1 `mkTransCoercion` co2
+    co = co1 `mkTransCo` co2
 
 pushCoercion co eis = EtaCo co : eis
 
@@ -696,7 +699,7 @@ pushCoercion co eis = EtaCo co : eis
 etaInfoAbs :: [EtaInfo] -> CoreExpr -> CoreExpr
 etaInfoAbs []               expr = expr
 etaInfoAbs (EtaVar v : eis) expr = Lam v (etaInfoAbs eis expr)
-etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCoercion co)
+etaInfoAbs (EtaCo co : eis) expr = Cast (etaInfoAbs eis expr) (mkSymCo co)
 
 --------------
 etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
@@ -704,15 +707,12 @@ etaInfoApp :: Subst -> CoreExpr -> [EtaInfo] -> CoreExpr
 --            ((substExpr s e) `appliedto` eis)
 
 etaInfoApp subst (Lam v1 e) (EtaVar v2 : eis) 
-  = etaInfoApp subst' e eis
-  where
-    subst' | isTyCoVar v1 = CoreSubst.extendTvSubst subst v1 (mkTyVarTy v2) 
-          | otherwise  = CoreSubst.extendIdSubst subst v1 (Var v2)
+  = etaInfoApp (CoreSubst.extendSubstWithVar subst v1 v2) e eis
 
 etaInfoApp subst (Cast e co1) eis
   = etaInfoApp subst e (pushCoercion co' eis)
   where
-    co' = CoreSubst.substTy subst co1
+    co' = CoreSubst.substCo subst co1
 
 etaInfoApp subst (Case e b _ alts) eis 
   = Case (subst_expr subst e) b1 (coreAltsType alts') alts'
@@ -739,24 +739,24 @@ etaInfoApp subst e eis
     go e (EtaCo co    : eis) = go (Cast e co) eis
 
 --------------
-mkEtaWW :: Arity -> InScopeSet -> Type
+mkEtaWW :: Arity -> CoreExpr -> InScopeSet -> Type
        -> (InScopeSet, [EtaInfo])
        -- EtaInfo contains fresh variables,
        --   not free in the incoming CoreExpr
        -- Outgoing InScopeSet includes the EtaInfo vars
        --   and the original free vars
 
-mkEtaWW orig_n in_scope orig_ty
+mkEtaWW orig_n orig_expr in_scope orig_ty
   = go orig_n empty_subst orig_ty []
   where
-    empty_subst = mkTvSubst in_scope emptyTvSubstEnv
+    empty_subst = TvSubst in_scope emptyTvSubstEnv
 
     go n subst ty eis      -- See Note [exprArity invariant]
        | n == 0
        = (getTvInScope subst, reverse eis)
 
        | Just (tv,ty') <- splitForAllTy_maybe ty
-       , let (subst', tv') = substTyVarBndr subst tv
+       , let (subst', tv') = Type.substTyVarBndr subst tv
            -- Avoid free vars of the original expression
        = go n subst' ty' (EtaVar tv' : eis)
 
@@ -772,11 +772,11 @@ mkEtaWW orig_n in_scope orig_ty
                        --      eta_expand 1 e T
                        -- We want to get
                        --      coerce T (\x::[T] -> (coerce ([T]->Int) e) x)
-         go n subst ty' (EtaCo (Type.substTy subst co) : eis)
+         go n subst ty' (EtaCo co : eis)
 
        | otherwise      -- We have an expression of arity > 0, 
                                 -- but its type isn't a function.                 
-       = WARN( True, ppr orig_n <+> ppr orig_ty )
+       = WARN( True, (ppr orig_n <+> ppr orig_ty) $$ ppr orig_expr )
          (getTvInScope subst, reverse eis)
        -- This *can* legitmately happen:
        -- e.g.  coerce Int (\x. x) Essentially the programmer is
index af414f7..88509f9 100644 (file)
@@ -49,6 +49,7 @@ import Name
 import VarSet
 import Var
 import TcType
+import Coercion
 import Util
 import BasicTypes( Activation )
 import Outputable
@@ -179,12 +180,13 @@ addBndrs bndrs fv = foldr addBndr fv bndrs
 expr_fvs :: CoreExpr -> FV
 
 expr_fvs (Type ty)      = someVars (tyVarsOfType ty)
+expr_fvs (Coercion co)   = someVars (tyCoVarsOfCo co)
 expr_fvs (Var var)      = oneVar var
 expr_fvs (Lit _)         = noVars
 expr_fvs (Note _ expr)   = expr_fvs expr
 expr_fvs (App fun arg)   = expr_fvs fun `union` expr_fvs arg
 expr_fvs (Lam bndr body) = addBndr bndr (expr_fvs body)
-expr_fvs (Cast expr co)  = expr_fvs expr `union` someVars (tyVarsOfType co)
+expr_fvs (Cast expr co)  = expr_fvs expr `union` someVars (tyCoVarsOfCo co)
 
 expr_fvs (Case scrut bndr ty alts)
   = expr_fvs scrut `union` someVars (tyVarsOfType ty) `union` addBndr bndr  
@@ -248,10 +250,11 @@ exprOrphNames e
       where n = idName v
     go (Lit _)                     = emptyNameSet
     go (Type ty)           = orphNamesOfType ty        -- Don't need free tyvars
+    go (Coercion co)        = orphNamesOfCo co
     go (App e1 e2)         = go e1 `unionNameSets` go e2
     go (Lam v e)           = go e `delFromNameSet` idName v
     go (Note _ e)           = go e
-    go (Cast e co)          = go e `unionNameSets` orphNamesOfType co
+    go (Cast e co)          = go e `unionNameSets` orphNamesOfCo co
     go (Let (NonRec _ r) e) = go e `unionNameSets` go r
     go (Let (Rec prs) e)    = exprsOrphNames (map snd prs) `unionNameSets` go e
     go (Case e _ ty as)     = go e `unionNameSets` orphNamesOfType ty
@@ -392,15 +395,15 @@ varTypeTyVars :: Var -> TyVarSet
 -- Find the type variables free in the type of the variable
 -- Remember, coercion variables can mention type variables...
 varTypeTyVars var
-  | isLocalId var || isCoVar var = tyVarsOfType (idType var)
-  | otherwise = emptyVarSet    -- Global Ids and non-coercion TyVars
+  | isLocalId var = tyVarsOfType (idType var)
+  | otherwise     = emptyVarSet        -- Global Ids and non-coercion TyVars
 
 varTypeTcTyVars :: Var -> TyVarSet
 -- Find the type variables free in the type of the variable
 -- Remember, coercion variables can mention type variables...
 varTypeTcTyVars var
-  | isLocalId var || isCoVar var = tcTyVarsOfType (idType var)
-  | otherwise = emptyVarSet    -- Global Ids and non-coercion TyVars
+  | isLocalId var = tcTyVarsOfType (idType var)
+  | otherwise     = emptyVarSet        -- Global Ids and non-coercion TyVars
 
 idFreeVars :: Id -> VarSet
 -- Type variables, rule variables, and inline variables
@@ -411,7 +414,7 @@ idFreeVars id = ASSERT( isId id)
 bndrRuleAndUnfoldingVars ::Var -> VarSet
 -- A 'let' can bind a type variable, and idRuleVars assumes 
 -- it's seeing an Id. This function tests first.
-bndrRuleAndUnfoldingVars v | isTyCoVar v = emptyVarSet
+bndrRuleAndUnfoldingVars v | isTyVar v = emptyVarSet
                           | otherwise = idRuleAndUnfoldingVars v
 
 idRuleAndUnfoldingVars :: Id -> VarSet
@@ -510,12 +513,11 @@ freeVars (Let (Rec binds) body)
     body2     = freeVars body
     body_fvs  = freeVarsOf body2
 
-
 freeVars (Cast expr co)
-  = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 co)
+  = (freeVarsOf expr2 `unionFVs` cfvs, AnnCast expr2 (cfvs, co))
   where
     expr2 = freeVars expr
-    cfvs  = tyVarsOfType co
+    cfvs  = tyCoVarsOfCo co
 
 freeVars (Note other_note expr)
   = (freeVarsOf expr2, AnnNote other_note expr2)
@@ -523,5 +525,7 @@ freeVars (Note other_note expr)
     expr2 = freeVars expr
 
 freeVars (Type ty) = (tyVarsOfType ty, AnnType ty)
+
+freeVars (Coercion co) = (tyCoVarsOfCo co, AnnCoercion co)
 \end{code}
 
index 5cc82a2..031fd61 100644 (file)
@@ -15,6 +15,7 @@ import Demand
 import CoreSyn
 import CoreFVs
 import CoreUtils
+import Pair
 import Bag
 import Literal
 import DataCon
@@ -27,6 +28,7 @@ import Id
 import PprCore
 import ErrUtils
 import SrcLoc
+import Kind
 import Type
 import TypeRep
 import Coercion
@@ -41,6 +43,7 @@ import FastString
 import Util
 import Control.Monad
 import Data.Maybe
+import Data.Traversable (traverse)
 \end{code}
 
 %************************************************************************
@@ -166,7 +169,7 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
          -- Check the rhs 
     do { ty <- lintCoreExpr rhs        
        ; lintBinder binder -- Check match to RHS type
-       ; binder_ty <- applySubst binder_ty
+       ; binder_ty <- applySubstTy binder_ty
        ; checkTys binder_ty ty (mkRhsMsg binder ty)
         -- Check (not isUnLiftedType) (also checks for bogus unboxed tuples)
        ; checkL (not (isUnLiftedType binder_ty)
@@ -207,14 +210,15 @@ lintSingleBinding top_lvl_flag rec_flag (binder,rhs)
 %************************************************************************
 
 \begin{code}
-type InType  = Type    -- Substitution not yet applied
-type InVar   = Var
-type InTyVar = TyVar
+type InType      = Type        -- Substitution not yet applied
+type InCoercion  = Coercion
+type InVar       = Var
+type InTyVar     = TyVar
 
-type OutType  = Type   -- Substitution has been applied to this
-type OutVar   = Var
-type OutTyVar = TyVar
-type OutCoVar = CoVar
+type OutType     = Type        -- Substitution has been applied to this
+type OutCoercion = Coercion
+type OutVar      = Var
+type OutTyVar    = TyVar
 
 lintCoreExpr :: CoreExpr -> LintM OutType
 -- The returned type has the substitution from the monad 
@@ -227,6 +231,9 @@ lintCoreExpr (Var var)
   = do { checkL (not (var == oneTupleDataConId))
                 (ptext (sLit "Illegal one-tuple"))
 
+        ; checkL (isId var && not (isCoVar var))
+                 (ptext (sLit "Non term variable") <+> ppr var)
+
         ; checkDeadIdOcc var
        ; var' <- lookupIdInScope var
         ; return (idType var') }
@@ -236,7 +243,7 @@ lintCoreExpr (Lit lit)
 
 lintCoreExpr (Cast expr co)
   = do { expr_ty <- lintCoreExpr expr
-       ; co' <- applySubst co
+       ; co' <- applySubstCo co
        ; (from_ty, to_ty) <- lintCoercion co'
        ; checkTys from_ty expr_ty (mkCastErr from_ty expr_ty)
        ; return to_ty }
@@ -251,29 +258,20 @@ lintCoreExpr (Let (NonRec tv (Type ty)) body)
         ; lintTyBndr tv              $ \ tv' -> 
           addLoc (BodyOfLetRec [tv]) $ 
           extendSubstL tv' ty'       $ do
-        { checkKinds tv' ty'              
+        { checkTyKind tv' ty'
                -- Now extend the substitution so we 
                -- take advantage of it in the body
         ; lintCoreExpr body } }
 
-  | isCoVar tv
-  = do { co <- applySubst ty
-       ; (s1,s2) <- addLoc (RhsOf tv) $ lintCoercion co
-       ; lintTyBndr tv  $ \ tv' -> 
-         addLoc (BodyOfLetRec [tv]) $ do
-       { let (t1,t2) = coVarKind tv'
-       ; checkTys s1 t1 (mkTyVarLetErr tv ty)
-       ; checkTys s2 t2 (mkTyVarLetErr tv ty)
-       ; lintCoreExpr body } }
-
-  | otherwise
-  = failWithL (mkTyVarLetErr tv ty)    -- Not quite accurate
-
 lintCoreExpr (Let (NonRec bndr rhs) body)
+  | isId bndr
   = do { lintSingleBinding NotTopLevel NonRecursive (bndr,rhs)
-       ; addLoc (BodyOfLetRec [bndr])
+       ; addLoc (BodyOfLetRec [bndr]) 
                 (lintAndScopeId bndr $ \_ -> (lintCoreExpr body)) }
 
+  | otherwise
+  = failWithL (mkLetErr bndr rhs)      -- Not quite accurate
+
 lintCoreExpr (Let (Rec pairs) body) 
   = lintAndScopeIds bndrs      $ \_ ->
     do { checkL (null dups) (dupVars dups)
@@ -298,7 +296,7 @@ lintCoreExpr (Lam var expr)
         else
             return (mkForAllTy var' body_ty)
        }
-       -- The applySubst is needed to apply the subst to var
+       -- The applySubstTy is needed to apply the subst to var
 
 lintCoreExpr e@(Case scrut var alt_ty alts) =
        -- Check the scrutinee
@@ -338,6 +336,11 @@ lintCoreExpr e@(Case scrut var alt_ty alts) =
 lintCoreExpr (Type ty)
   = do { ty' <- lintInTy ty
        ; return (typeKind ty') }
+
+lintCoreExpr (Coercion co)
+  = do { co' <- lintInCo co
+       ; let Pair ty1 ty2 = coercionKind co'
+       ; return (mkPredTy $ EqPred ty1 ty2) }
 \end{code}
 
 %************************************************************************
@@ -352,12 +355,12 @@ subtype of the required type, as one would expect.
 \begin{code}
 lintCoreArg  :: OutType -> CoreArg -> LintM OutType
 lintCoreArg fun_ty (Type arg_ty)
-  = do { arg_ty' <- applySubst arg_ty
-        ; lintTyApp fun_ty arg_ty' }
+  = do { arg_ty' <- applySubstTy arg_ty
+       ; lintTyApp fun_ty arg_ty' }
 
 lintCoreArg fun_ty arg
- = do { arg_ty <- lintCoreExpr arg
-      ; lintValApp arg fun_ty arg_ty }
 = do { arg_ty <- lintCoreExpr arg
+       ; lintValApp arg fun_ty arg_ty }
 
 -----------------
 lintAltBinders :: OutType     -- Scrutinee type
@@ -367,7 +370,7 @@ lintAltBinders :: OutType     -- Scrutinee type
 lintAltBinders scrut_ty con_ty [] 
   = checkTys con_ty scrut_ty (mkBadPatMsg con_ty scrut_ty) 
 lintAltBinders scrut_ty con_ty (bndr:bndrs)
-  | isTyCoVar bndr
+  | isTyVar bndr
   = do { con_ty' <- lintTyApp con_ty (mkTyVarTy bndr)
        ; lintAltBinders scrut_ty con_ty' bndrs }
   | otherwise
@@ -378,11 +381,10 @@ lintAltBinders scrut_ty con_ty (bndr:bndrs)
 lintTyApp :: OutType -> OutType -> LintM OutType
 lintTyApp fun_ty arg_ty
   | Just (tyvar,body_ty) <- splitForAllTy_maybe fun_ty
-  = do { checkKinds tyvar arg_ty
-       ; if isCoVar tyvar then 
-             return body_ty   -- Co-vars don't appear in body_ty!
-          else 
-             return (substTyWith [tyvar] [arg_ty] body_ty) }
+  , isTyVar tyvar
+  = do { checkTyKind tyvar arg_ty
+        ; return (substTyWith [tyvar] [arg_ty] body_ty) }
+
   | otherwise
   = failWithL (mkTyAppMsg fun_ty arg_ty)
    
@@ -400,22 +402,34 @@ lintValApp arg fun_ty arg_ty
 \end{code}
 
 \begin{code}
-checkKinds :: OutVar -> OutType -> LintM ()
+checkTyKind :: OutTyVar -> OutType -> LintM ()
 -- Both args have had substitution applied
-checkKinds tyvar arg_ty
+checkTyKind tyvar arg_ty
        -- Arg type might be boxed for a function with an uncommitted
        -- tyvar; notably this is used so that we can give
        --      error :: forall a:*. String -> a
        -- and then apply it to both boxed and unboxed types.
-  | isCoVar tyvar = do { (s2,t2) <- lintCoercion arg_ty
-                       ; unless (s1 `coreEqType` s2 && t1 `coreEqType` t2)
-                                (addErrL (mkCoAppErrMsg tyvar arg_ty)) }
-  | otherwise     = do { arg_kind <- lintType arg_ty
-                       ; unless (arg_kind `isSubKind` tyvar_kind)
-                                (addErrL (mkKindErrMsg tyvar arg_ty)) }
+  = do { arg_kind <- lintType arg_ty
+       ; unless (arg_kind `isSubKind` tyvar_kind)
+                (addErrL (mkKindErrMsg tyvar arg_ty)) }
   where
     tyvar_kind = tyVarKind tyvar
-    (s1,t1)    = coVarKind tyvar
+
+-- Check that the kinds of a type variable and a coercion match, that
+-- is, if tv :: k  then co :: t1 ~ t2  where t1 :: k and t2 :: k.
+checkTyCoKind :: TyVar -> OutCoercion -> LintM (OutType, OutType)
+checkTyCoKind tv co
+  = do { (t1,t2) <- lintCoercion co
+       ; k1      <- lintType t1
+       ; k2      <- lintType t2
+       ; unless ((k1 `isSubKind` tyvar_kind) && (k2 `isSubKind` tyvar_kind))
+                (addErrL (mkTyCoAppErrMsg tv co))
+       ; return (t1,t2) }
+  where 
+    tyvar_kind = tyVarKind tv
+
+checkTyCoKinds :: [TyVar] -> [OutCoercion] -> LintM [(OutType, OutType)]
+checkTyCoKinds = zipWithM checkTyCoKind
 
 checkDeadIdOcc :: Id -> LintM ()
 -- Occurrences of an Id should never be dead....
@@ -536,7 +550,7 @@ lintBinder var linterF
 lintTyBndr :: InTyVar -> (OutTyVar -> LintM a) -> LintM a
 lintTyBndr tv thing_inside
   = do { subst <- getTvSubst
-       ; let (subst', tv') = substTyVarBndr subst tv
+       ; let (subst', tv') = Type.substTyVarBndr subst tv
        ; lintTyBndrKind tv'
        ; updateTvSubst subst' (thing_inside tv') }
 
@@ -581,10 +595,19 @@ lintInTy :: InType -> LintM OutType
 -- ToDo: check the kind structure of the type
 lintInTy ty 
   = addLoc (InType ty) $
-    do { ty' <- applySubst ty
+    do { ty' <- applySubstTy ty
        ; _ <- lintType ty'
        ; return ty' }
 
+lintInCo :: InCoercion -> LintM OutCoercion
+-- Check the coercion, and apply the substitution to it
+-- See Note [Linting type lets]
+lintInCo co
+  = addLoc (InCo co) $
+    do  { co' <- applySubstCo co
+        ; _   <- lintCoercion co'
+        ; return co' }
+
 -------------------
 lintKind :: Kind -> LintM ()
 -- Check well-formedness of kinds: *, *->*, etc
@@ -598,124 +621,71 @@ lintKind kind
 
 -------------------
 lintTyBndrKind :: OutTyVar -> LintM ()
-lintTyBndrKind tv 
-  | isCoVar tv = lintCoVarKind tv
-  | otherwise  = lintKind (tyVarKind tv)
-
--------------------
-lintCoVarKind :: OutCoVar -> LintM ()
--- Check the kind of a coercion binder
-lintCoVarKind tv
-  = do { (ty1,ty2) <- lintSplitCoVar tv
-       ; k1 <- lintType ty1
-       ; k2 <- lintType ty2
-       ; unless (k1 `eqKind` k2) 
-                (addErrL (sep [ ptext (sLit "Kind mis-match in coercion kind of:")
-                              , nest 2 (quotes (ppr tv))
-                              , ppr [k1,k2] ])) }
-
--------------------
-lintSplitCoVar :: CoVar -> LintM (Type,Type)
-lintSplitCoVar cv
-  = case coVarKind_maybe cv of
-      Just ts -> return ts
-      Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
-                                , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
+lintTyBndrKind tv = lintKind (tyVarKind tv)
 
 -------------------
-lintCoercion, lintCoercion' :: OutType -> LintM (OutType, OutType)
+lintCoercion :: OutCoercion -> LintM (OutType, OutType)
 -- Check the kind of a coercion term, returning the kind
-lintCoercion co 
-  = addLoc (InCoercion co) $ lintCoercion' co
-
-lintCoercion' ty@(TyVarTy tv)
-  = do { checkTyVarInScope tv
-       ; if isCoVar tv then return (coVarKind tv) 
-                       else return (ty, ty) }
-
-lintCoercion' ty@(AppTy ty1 ty2) 
-  = do { (s1,t1) <- lintCoercion ty1
-       ; (s2,t2) <- lintCoercion ty2
-       ; check_co_app ty (typeKind s1) [s2]
-       ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
-
-lintCoercion' ty@(FunTy ty1 ty2)
-  = do { (s1,t1) <- lintCoercion ty1
-       ; (s2,t2) <- lintCoercion ty2
-       ; check_co_app ty (tyConKind funTyCon) [s1, s2]
-       ; return (FunTy s1 s2, FunTy t1 t2) }
-
-lintCoercion' ty@(TyConApp tc tys) 
-  | Just (ar, desc) <- isCoercionTyCon_maybe tc
-  = do { unless (tys `lengthAtLeast` ar) (badCo ty)
-       ; (s,t) <- lintCoTyConApp ty desc (take ar tys)
-       ; (ss,ts) <- mapAndUnzipM lintCoercion (drop ar tys)
-       ; check_co_app ty (typeKind s) ss
-       ; return (mkAppTys s ss, mkAppTys t ts) }
+lintCoercion (Refl ty)
+  = do { ty' <- lintInTy ty
+       ; return (ty', ty') }
 
-  | not (tyConHasKind tc)      -- Just something bizarre like SuperKindTyCon
-  = badCo ty
+lintCoercion co@(TyConAppCo tc cos)
+  = do { (ss,ts) <- mapAndUnzipM lintCoercion cos
+       ; check_co_app co (tyConKind tc) ss
+       ; return (mkTyConApp tc ss, mkTyConApp tc ts) }
 
-  | otherwise
-  = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
-       ; check_co_app ty (tyConKind tc) ss
-       ; return (TyConApp tc ss, TyConApp tc ts) }
-
-lintCoercion' ty@(PredTy (ClassP cls tys))
-  = do { (ss,ts) <- mapAndUnzipM lintCoercion tys
-       ; check_co_app ty (tyConKind (classTyCon cls)) ss
-       ; return (PredTy (ClassP cls ss), PredTy (ClassP cls ts)) }
-
-lintCoercion' (PredTy (IParam n p_ty))
-  = do { (s,t) <- lintCoercion p_ty
-       ; return (PredTy (IParam n s), PredTy (IParam n t)) }
-
-lintCoercion' ty@(PredTy (EqPred {}))
-  = failWithL (badEq ty)
-
-lintCoercion' (ForAllTy tv ty)
-  | isCoVar tv
-  = do { (co1, co2) <- lintSplitCoVar tv
-       ; (s1,t1)    <- lintCoercion co1
-       ; (s2,t2)    <- lintCoercion co2
-       ; (sr,tr)    <- lintCoercion ty
-       ; return (mkCoPredTy s1 s2 sr, mkCoPredTy t1 t2 tr) }
+lintCoercion co@(AppCo co1 co2)
+  = do { (s1,t1) <- lintCoercion co1
+       ; (s2,t2) <- lintCoercion co2
+       ; check_co_app co (typeKind s1) [s2]
+       ; return (mkAppTy s1 s2, mkAppTy t1 t2) }
 
-  | otherwise
-  = do { lintKind (tyVarKind tv)
-       ; (s,t) <- addInScopeVar tv (lintCoercion ty)
-       ; return (ForAllTy tv s, ForAllTy tv t) }
-
-badCo :: Coercion -> LintM a
-badCo co = failWithL (hang (ptext (sLit "Ill-kinded coercion term:")) 2 (ppr co))
-
----------------
-lintCoTyConApp :: Coercion -> CoTyConDesc -> [Coercion] -> LintM (Type,Type)
--- Always called with correct number of coercion arguments
--- First arg is just for error message
-lintCoTyConApp _ CoLeft  (co:_) = lintLR   fst             co 
-lintCoTyConApp _ CoRight (co:_) = lintLR   snd             co   
-lintCoTyConApp _ CoCsel1 (co:_) = lintCsel fstOf3   co 
-lintCoTyConApp _ CoCsel2 (co:_) = lintCsel sndOf3   co 
-lintCoTyConApp _ CoCselR (co:_) = lintCsel thirdOf3 co 
-
-lintCoTyConApp _ CoSym (co:_) 
-  = do { (ty1,ty2) <- lintCoercion co
-       ; return (ty2,ty1) }
-
-lintCoTyConApp co CoTrans (co1:co2:_) 
+lintCoercion (ForAllCo v co)
+  = do { lintKind (tyVarKind v)
+       ; (s,t) <- addInScopeVar v (lintCoercion co)
+       ; return (ForAllTy v s, ForAllTy v t) }
+
+lintCoercion (CoVarCo cv)
+  = do { checkTyCoVarInScope cv
+       ; return (coVarKind cv) }
+
+lintCoercion (AxiomInstCo (CoAxiom { co_ax_tvs = tvs
+                                   , co_ax_lhs = lhs
+                                   , co_ax_rhs = rhs }) 
+                           cos)
+  = do { (tys1, tys2) <- liftM unzip (checkTyCoKinds tvs cos)
+       ; return (substTyWith tvs tys1 lhs,
+                 substTyWith tvs tys2 rhs) }
+
+lintCoercion (UnsafeCo ty1 ty2)
+  = do { ty1' <- lintInTy ty1
+       ; ty2' <- lintInTy ty2
+       ; return (ty1', ty2') }
+
+lintCoercion (SymCo co) 
+  = do { (ty1, ty2) <- lintCoercion co
+       ; return (ty2, ty1) }
+
+lintCoercion co@(TransCo co1 co2)
   = do { (ty1a, ty1b) <- lintCoercion co1
        ; (ty2a, ty2b) <- lintCoercion co2
-       ; checkL (ty1b `coreEqType` ty2a)
+       ; checkL (ty1b `eqType` ty2a)
                 (hang (ptext (sLit "Trans coercion mis-match:") <+> ppr co)
                     2 (vcat [ppr ty1a, ppr ty1b, ppr ty2a, ppr ty2b]))
        ; return (ty1a, ty2b) }
 
-lintCoTyConApp _ CoInst (co:arg_ty:_) 
-  = do { co_tys <- lintCoercion co
+lintCoercion the_co@(NthCo d co)
+  = do { (s,t) <- lintCoercion co
+       ; sn <- checkTcApp the_co d s
+       ; tn <- checkTcApp the_co d t
+       ; return (sn, tn) }
+
+lintCoercion (InstCo co arg_ty)
+  = do { co_tys    <- lintCoercion co
        ; arg_kind  <- lintType arg_ty
-       ; case decompInst_maybe co_tys of
-          Just ((tv1,tv2), (ty1,ty2)) 
+       ; case splitForAllTy_maybe `traverse` toPair co_tys of
+          Just (Pair (tv1,ty1) (tv2,ty2))
             | arg_kind `isSubKind` tyVarKind tv1
             -> return (substTyWith [tv1] [arg_ty] ty1, 
                        substTyWith [tv2] [arg_ty] ty2) 
@@ -723,40 +693,20 @@ lintCoTyConApp _ CoInst (co:arg_ty:_)
             -> failWithL (ptext (sLit "Kind mis-match in inst coercion"))
          Nothing -> failWithL (ptext (sLit "Bad argument of inst")) }
 
-lintCoTyConApp _ (CoAxiom { co_ax_tvs = tvs 
-                          , co_ax_lhs = lhs_ty, co_ax_rhs = rhs_ty }) cos
-  = do { (tys1, tys2) <- mapAndUnzipM lintCoercion cos
-       ; sequence_ (zipWith checkKinds tvs tys1)
-       ; return (substTyWith tvs tys1 lhs_ty,
-                 substTyWith tvs tys2 rhs_ty) }
-
-lintCoTyConApp _ CoUnsafe (ty1:ty2:_) 
-  = do { _ <- lintType ty1
-       ; _ <- lintType ty2     -- Ignore kinds; it's unsafe!
-       ; return (ty1,ty2) } 
-
-lintCoTyConApp _ _ _ = panic "lintCoTyConApp"  -- Called with wrong number of coercion args
-
-----------
-lintLR :: (forall a. (a,a)->a) -> Coercion -> LintM (Type,Type)
-lintLR sel co
-  = do { (ty1,ty2) <- lintCoercion co
-       ; case decompLR_maybe (ty1,ty2) of
-           Just res -> return (sel res)
-           Nothing  -> failWithL (ptext (sLit "Bad argument of left/right")) }
-
 ----------
-lintCsel :: (forall a. (a,a,a)->a) -> Coercion -> LintM (Type,Type)
-lintCsel sel co
-  = do { (ty1,ty2) <- lintCoercion co
-       ; case decompCsel_maybe (ty1,ty2) of
-           Just res -> return (sel res)
-           Nothing  -> failWithL (ptext (sLit "Bad argument of csel")) }
+checkTcApp :: Coercion -> Int -> Type -> LintM Type
+checkTcApp co n ty
+  | Just (_, tys) <- splitTyConApp_maybe ty
+  , n < length tys
+  = return (tys !! n)
+  | otherwise
+  = failWithL (hang (ptext (sLit "Bad getNth:") <+> ppr co)
+                  2 (ptext (sLit "Offending type:") <+> ppr ty))
 
 -------------------
 lintType :: OutType -> LintM Kind
 lintType (TyVarTy tv)
-  = do { checkTyVarInScope tv
+  = do { checkTyCoVarInScope tv
        ; return (tyVarKind tv) }
 
 lintType ty@(AppTy t1 t2) 
@@ -782,8 +732,13 @@ lintType ty@(PredTy (ClassP cls tys))
 lintType (PredTy (IParam _ p_ty))
   = lintType p_ty
 
-lintType ty@(PredTy (EqPred {}))
-  = failWithL (badEq ty)
+lintType ty@(PredTy (EqPred t1 t2))
+  = do { k1 <- lintType t1
+       ; k2 <- lintType t2
+       ; unless (k1 `eqKind` k2) 
+                (addErrL (sep [ ptext (sLit "Kind mis-match in equality predicate:")
+                              , nest 2 (ppr ty) ]))
+       ; return unliftedTypeKind }
 
 ----------------
 lint_ty_app :: Type -> Kind -> [OutType] -> LintM Kind
@@ -812,10 +767,6 @@ lint_kind_app doc kfn ks = go kfn ks
                      Just (kfa, kfb) -> do { unless (k `isSubKind` kfa)
                                                      (addErrL fail_msg)
                                             ; go kfb ks } 
---------------
-badEq :: Type -> SDoc
-badEq ty = hang (ptext (sLit "Unexpected equality predicate:"))
-              1 (quotes (ppr ty))
 \end{code}
     
 %************************************************************************
@@ -870,7 +821,7 @@ data LintLocInfo
   | ImportedUnfolding SrcLoc -- Some imported unfolding (ToDo: say which)
   | TopLevelBindings
   | InType Type                -- Inside a type
-  | InCoercion Coercion        -- Inside a type
+  | InCo   Coercion     -- Inside a coercion
 \end{code}
 
                  
@@ -936,12 +887,15 @@ updateTvSubst subst' m =
 getTvSubst :: LintM TvSubst
 getTvSubst = LintM (\ _ subst errs -> (Just subst, errs))
 
-applySubst :: Type -> LintM Type
-applySubst ty = do { subst <- getTvSubst; return (substTy subst ty) }
+applySubstTy :: Type -> LintM Type
+applySubstTy ty = do { subst <- getTvSubst; return (Type.substTy subst ty) }
+
+applySubstCo :: Coercion -> LintM Coercion
+applySubstCo co = do { subst <- getTvSubst; return (substCo (tvCvSubst subst) co) }
 
 extendSubstL :: TyVar -> Type -> LintM a -> LintM a
 extendSubstL tv ty m
-  = LintM (\ loc subst errs -> unLintM m loc (extendTvSubst subst tv ty) errs)
+  = LintM (\ loc subst errs -> unLintM m loc (Type.extendTvSubst subst tv ty) errs)
 \end{code}
 
 \begin{code}
@@ -969,8 +923,8 @@ checkBndrIdInScope binder id
      msg = ptext (sLit "is out of scope inside info for") <+> 
           ppr binder
 
-checkTyVarInScope :: TyVar -> LintM ()
-checkTyVarInScope tv = checkInScope (ptext (sLit "is out of scope")) tv
+checkTyCoVarInScope :: TyCoVar -> LintM ()
+checkTyCoVarInScope v = checkInScope (ptext (sLit "is out of scope")) v
 
 checkInScope :: SDoc -> Var -> LintM ()
 checkInScope loc_msg var =
@@ -982,7 +936,7 @@ checkTys :: OutType -> OutType -> Message -> LintM ()
 -- check ty2 is subtype of ty1 (ie, has same structure but usage
 -- annotations need only be consistent, not equal)
 -- Assumes ty1,ty2 are have alrady had the substitution applied
-checkTys ty1 ty2 msg = checkL (ty1 `coreEqType` ty2) msg
+checkTys ty1 ty2 msg = checkL (ty1 `eqType` ty2) msg
 \end{code}
 
 %************************************************************************
@@ -1021,8 +975,8 @@ dumpLoc TopLevelBindings
   = (noSrcLoc, empty)
 dumpLoc (InType ty)
   = (noSrcLoc, text "In the type" <+> quotes (ppr ty))
-dumpLoc (InCoercion ty)
-  = (noSrcLoc, text "In the coercion" <+> quotes (ppr ty))
+dumpLoc (InCo co)
+  = (noSrcLoc, text "In the coercion" <+> quotes (ppr co))
 
 pp_binders :: [Var] -> SDoc
 pp_binders bs = sep (punctuate comma (map pp_binder bs))
@@ -1114,29 +1068,21 @@ mkNonFunAppMsg fun_ty arg_ty arg
              hang (ptext (sLit "Arg type:")) 4 (ppr arg_ty),
              hang (ptext (sLit "Arg:")) 4 (ppr arg)]
 
-mkTyVarLetErr :: TyVar -> Type -> Message
-mkTyVarLetErr tyvar ty
-  = vcat [ptext (sLit "Bad `let' binding for type or coercion variable:"),
-         hang (ptext (sLit "Type/coercion variable:"))
-                4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
-         hang (ptext (sLit "Arg type/coercion:"))   
-                4 (ppr ty)]
-
-mkKindErrMsg :: TyVar -> Type -> Message
-mkKindErrMsg tyvar arg_ty
-  = vcat [ptext (sLit "Kinds don't match in type application:"),
-         hang (ptext (sLit "Type variable:"))
-                4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
-         hang (ptext (sLit "Arg type:"))   
-                4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
-
-mkCoAppErrMsg :: TyVar -> Type -> Message
-mkCoAppErrMsg tyvar arg_ty
-  = vcat [ptext (sLit "Kinds don't match in coercion application:"),
-         hang (ptext (sLit "Coercion variable:"))
+mkLetErr :: TyVar -> CoreExpr -> Message
+mkLetErr bndr rhs
+  = vcat [ptext (sLit "Bad `let' binding:"),
+         hang (ptext (sLit "Variable:"))
+                4 (ppr bndr <+> dcolon <+> ppr (varType bndr)),
+         hang (ptext (sLit "Rhs:"))   
+                4 (ppr rhs)]
+
+mkTyCoAppErrMsg :: TyVar -> Coercion -> Message
+mkTyCoAppErrMsg tyvar arg_co
+  = vcat [ptext (sLit "Kinds don't match in lifted coercion application:"),
+          hang (ptext (sLit "Type variable:"))
                 4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
          hang (ptext (sLit "Arg coercion:"))   
-                4 (ppr arg_ty <+> dcolon <+> pprEqPred (coercionKind arg_ty))]
+                4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
 
 mkTyAppMsg :: Type -> Type -> Message
 mkTyAppMsg ty arg_ty
@@ -1168,6 +1114,15 @@ mkStrictMsg binder
              hsep [ptext (sLit "Binder's demand info:"), ppr (idDemandInfo binder)]
             ]
 
+
+mkKindErrMsg :: TyVar -> Type -> Message
+mkKindErrMsg tyvar arg_ty
+  = vcat [ptext (sLit "Kinds don't match in type application:"),
+         hang (ptext (sLit "Type variable:"))
+                4 (ppr tyvar <+> dcolon <+> ppr (tyVarKind tyvar)),
+         hang (ptext (sLit "Arg type:"))   
+                4 (ppr arg_ty <+> dcolon <+> ppr (typeKind arg_ty))]
+
 mkArityMsg :: Id -> Message
 mkArityMsg binder
   = vcat [hsep [ptext (sLit "Demand type has "),
@@ -1203,3 +1158,56 @@ dupExtVars vars
   = hang (ptext (sLit "Duplicate top-level variables with the same qualified name"))
        2 (ppr vars)
 \end{code}
+
+-------------- DEAD CODE  -------------------
+
+-------------------
+checkCoKind :: CoVar -> OutCoercion -> LintM ()
+-- Both args have had substitution applied
+checkCoKind covar arg_co
+  = do { (s2,t2) <- lintCoercion arg_co
+       ; unless (s1 `eqType` s2 && t1 `coreEqType` t2)
+                (addErrL (mkCoAppErrMsg covar arg_co)) }
+  where
+    (s1,t1) = coVarKind covar
+
+lintCoVarKind :: OutCoVar -> LintM ()
+-- Check the kind of a coercion binder
+lintCoVarKind tv
+  = do { (ty1,ty2) <- lintSplitCoVar tv
+       ; lintEqType ty1 ty2
+
+
+-------------------
+lintSplitCoVar :: CoVar -> LintM (Type,Type)
+lintSplitCoVar cv
+  = case coVarKind_maybe cv of
+      Just ts -> return ts
+      Nothing -> failWithL (sep [ ptext (sLit "Coercion variable with non-equality kind:")
+                                , nest 2 (ppr cv <+> dcolon <+> ppr (tyVarKind cv))])
+
+mkCoVarLetErr :: CoVar -> Coercion -> Message
+mkCoVarLetErr covar co
+  = vcat [ptext (sLit "Bad `let' binding for coercion variable:"),
+         hang (ptext (sLit "Coercion variable:"))
+                4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)),
+         hang (ptext (sLit "Arg coercion:"))   
+                4 (ppr co)]
+
+mkCoAppErrMsg :: CoVar -> Coercion -> Message
+mkCoAppErrMsg covar arg_co
+  = vcat [ptext (sLit "Kinds don't match in coercion application:"),
+         hang (ptext (sLit "Coercion variable:"))
+                4 (ppr covar <+> dcolon <+> ppr (coVarKind covar)),
+         hang (ptext (sLit "Arg coercion:"))   
+                4 (ppr arg_co <+> dcolon <+> pprEqPred (coercionKind arg_co))]
+
+
+mkCoAppMsg :: Type -> Coercion -> Message
+mkCoAppMsg ty arg_co
+  = vcat [text "Illegal type application:",
+             hang (ptext (sLit "exp type:"))
+                4 (ppr ty <+> dcolon <+> ppr (typeKind ty)),
+             hang (ptext (sLit "arg type:"))   
+                4 (ppr arg_co <+> dcolon <+> ppr (coercionKind arg_co))]
+
index 42379b4..0405716 100644 (file)
@@ -37,6 +37,7 @@ import OrdList
 import ErrUtils
 import DynFlags
 import Util
+import Pair
 import Outputable
 import MonadUtils
 import FastString
@@ -78,9 +79,9 @@ The goal of this pass is to prepare for code generation.
     weaker guarantee of no clashes which the simplifier provides.
     And that is what the code generator needs.
 
-    We don't clone TyVars. The code gen doesn't need that, 
+    We don't clone TyVars or CoVars. The code gen doesn't need that, 
     and doing so would be tiresome because then we'd need
-    to substitute in types.
+    to substitute in types and coercions.
 
 
 7.  Give each dynamic CCall occurrence a fresh unique; this is
@@ -104,19 +105,21 @@ Invariants
 Here is the syntax of the Core produced by CorePrep:
 
     Trivial expressions 
-       triv ::= lit |  var  | triv ty  |  /\a. triv  |  triv |> co
+       triv ::= lit |  var  
+              | triv ty  |  /\a. triv 
+              | truv co  |  /\c. triv  |  triv |> co
 
     Applications
-       app ::= lit  |  var  |  app triv  |  app ty  |  app |> co
+       app ::= lit  |  var  |  app triv  |  app ty  | app co | app |> co
 
     Expressions
        body ::= app  
               | let(rec) x = rhs in body     -- Boxed only
               | case body of pat -> body
-             | /\a. body
+             | /\a. body | /\c. body 
               | body |> co
 
-    Right hand sides (only place where lambdas can occur)
+    Right hand sides (only place where value lambdas can occur)
        rhs ::= /\a.rhs  |  \x.rhs  |  body
 
 We define a synonym for each of these non-terminals.  Functions
@@ -440,9 +443,10 @@ cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
 -- For example
 --     f (g x)   ===>   ([v = g x], f v)
 
-cpeRhsE _env expr@(Type _) = return (emptyFloats, expr)
-cpeRhsE _env expr@(Lit _)  = return (emptyFloats, expr)
-cpeRhsE env expr@(Var {})  = cpeApp env expr
+cpeRhsE _env expr@(Type {})     = return (emptyFloats, expr)
+cpeRhsE _env expr@(Coercion {}) = return (emptyFloats, expr)
+cpeRhsE _env expr@(Lit {})      = return (emptyFloats, expr)
+cpeRhsE env expr@(Var {})       = cpeApp env expr
 
 cpeRhsE env (Var f `App` _ `App` arg)
   | f `hasKey` lazyIdKey         -- Replace (lazy a) by a
@@ -528,7 +532,7 @@ rhsToBody (Cast e co)
 rhsToBody expr@(Lam {})
   | Just no_lam_result <- tryEtaReducePrep bndrs body
   = return (emptyFloats, no_lam_result)
-  | all isTyCoVar bndrs                -- Type lambdas are ok
+  | all isTyVar bndrs          -- Type lambdas are ok
   = return (emptyFloats, expr)
   | otherwise                  -- Some value lambdas
   = do { fn <- newVar (exprType expr)
@@ -579,6 +583,10 @@ cpeApp env expr
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
            ; return (App fun' arg, hd, applyTy fun_ty arg_ty, floats, ss) }
 
+    collect_args (App fun arg@(Coercion arg_co)) depth
+      = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun depth
+           ; return (App fun' arg, hd, applyCo fun_ty arg_co, floats, ss) }
+
     collect_args (App fun arg) depth
       = do { (fun',hd,fun_ty,floats,ss) <- collect_args fun (depth+1)
           ; let
@@ -608,7 +616,7 @@ cpeApp env expr
                -- partial application might be seq'd
 
     collect_args (Cast fun co) depth
-      = do { let (_ty1,ty2) = coercionKind co
+      = do { let Pair _ty1 ty2 = coercionKind co
            ; (fun', hd, _, floats, ss) <- collect_args fun depth
            ; return (Cast fun' co, hd, ty2, floats, ss) }
           
@@ -751,11 +759,12 @@ cpe_ExprIsTrivial :: CoreExpr -> Bool
 -- Version that doesn't consider an scc annotation to be trivial.
 cpe_ExprIsTrivial (Var _)                  = True
 cpe_ExprIsTrivial (Type _)                 = True
+cpe_ExprIsTrivial (Coercion _)             = True
 cpe_ExprIsTrivial (Lit _)                  = True
 cpe_ExprIsTrivial (App e arg)              = isTypeArg arg && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Note n e)               = notSccNote n  && cpe_ExprIsTrivial e
 cpe_ExprIsTrivial (Cast e _)               = cpe_ExprIsTrivial e
-cpe_ExprIsTrivial (Lam b body) | isTyCoVar b = cpe_ExprIsTrivial body
+cpe_ExprIsTrivial (Lam b body) | isTyVar b = cpe_ExprIsTrivial body
 cpe_ExprIsTrivial _                        = False
 \end{code}
 
@@ -1070,7 +1079,7 @@ cloneBndrs env bs = mapAccumLM cloneBndr env bs
 
 cloneBndr  :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var)
 cloneBndr env bndr
-  | isLocalId bndr
+  | isLocalId bndr, not (isCoVar bndr)
   = do bndr' <- setVarUnique bndr <$> getUniqueM
        
        -- We are going to OccAnal soon, so drop (now-useless) rules/unfoldings
@@ -1082,7 +1091,7 @@ cloneBndr env bndr
 
   | otherwise  -- Top level things, which we don't want
                -- to clone, have become GlobalIds by now
-               -- And we don't clone tyvars
+               -- And we don't clone tyvars, or coercion variables
   = return (env, bndr)
   
 
index a229b8c..047e6c3 100644 (file)
@@ -12,14 +12,15 @@ module CoreSubst (
 
         -- ** Substituting into expressions and related types
        deShadowBinds, substSpec, substRulesForImportedIds,
-       substTy, substExpr, substExprSC, substBind, substBindSC,
+       substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
         substUnfolding, substUnfoldingSC,
-       substUnfoldingSource, lookupIdSubst, lookupTvSubst, substIdOcc,
+       substUnfoldingSource, lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
 
         -- ** Operations on substitutions
        emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst, 
        extendIdSubst, extendIdSubstList, extendTvSubst, extendTvSubstList,
-       extendSubst, extendSubstList, zapSubstEnv,
+        extendCvSubst, extendCvSubstList,
+       extendSubst, extendSubstList, extendSubstWithVar, zapSubstEnv,
         addInScopeSet, extendInScope, extendInScopeList, extendInScopeIds,
         isInScope, setInScope,
         delBndr, delBndrs,
@@ -37,18 +38,23 @@ module CoreSubst (
 import CoreSyn
 import CoreFVs
 import CoreUtils
-import PprCore
 import OccurAnal( occurAnalyseExpr, occurAnalysePgm )
 
 import qualified Type
-import Type     ( Type, TvSubst(..), TvSubstEnv )
-import Coercion           ( isIdentityCoercion )
+import qualified Coercion
+
+       -- We are defining local versions
+import Type     hiding ( substTy, extendTvSubst, extendTvSubstList
+                       , isInScope, substTyVarBndr )
+import Coercion hiding ( substTy, substCo, extendTvSubst, substTyVarBndr, substCoVarBndr )
+
 import OptCoercion ( optCoercion )
+import PprCore     ( pprCoreBindings )
 import VarSet
 import VarEnv
 import Id
 import Name    ( Name )
-import Var      ( Var, TyVar, setVarUnique )
+import Var
 import IdInfo
 import Unique
 import UniqSupply
@@ -92,7 +98,8 @@ data Subst
   = Subst InScopeSet  -- Variables in in scope (both Ids and TyVars) /after/
                       -- applying the substitution
           IdSubstEnv  -- Substitution for Ids
-          TvSubstEnv  -- Substitution for TyVars
+          TvSubstEnv  -- Substitution from TyVars to Types
+          CvSubstEnv  -- Substitution from TyCoVars to Coercions
 
        -- INVARIANT 1: See #in_scope_invariant#
        -- This is what lets us deal with name capture properly
@@ -126,6 +133,11 @@ In consequence:
 
 * In substIdBndr, we extend the IdSubstEnv only when the unique changes
 
+* If the CvSubstEnv, TvSubstEnv and IdSubstEnv are all empty,
+  substExpr does nothing (Note that the above rule for substIdBndr
+  maintains this property.  If the incoming envts are both empty, then
+  substituting the type and IdInfo can't change anything.)
+
 * In lookupIdSubst, we *must* look up the Id in the in-scope set, because
   it may contain non-trivial changes.  Example:
        (/\a. \x:a. ...x...) Int
@@ -140,7 +152,8 @@ In consequence:
 * (However, we don't need to do so for expressions found in the IdSubst
   itself, whose range is assumed to be correct wrt the in-scope set.)
 
-Why do we make a different choice for the IdSubstEnv than the TvSubstEnv?
+Why do we make a different choice for the IdSubstEnv than the
+TvSubstEnv and CvSubstEnv?
 
 * For Ids, we change the IdInfo all the time (e.g. deleting the
   unfolding), and adding it back later, so using the TyVar convention
@@ -158,70 +171,82 @@ type IdSubstEnv = IdEnv CoreExpr
 
 ----------------------------
 isEmptySubst :: Subst -> Bool
-isEmptySubst (Subst _ id_env tv_env) = isEmptyVarEnv id_env && isEmptyVarEnv tv_env
+isEmptySubst (Subst _ id_env tv_env cv_env) 
+  = isEmptyVarEnv id_env && isEmptyVarEnv tv_env && isEmptyVarEnv cv_env
 
 emptySubst :: Subst
-emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv
+emptySubst = Subst emptyInScopeSet emptyVarEnv emptyVarEnv emptyVarEnv
 
 mkEmptySubst :: InScopeSet -> Subst
-mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv
-
-mkSubst :: InScopeSet -> TvSubstEnv -> IdSubstEnv -> Subst
-mkSubst in_scope tvs ids = Subst in_scope ids tvs
-
--- getTvSubst :: Subst -> TvSubst
--- getTvSubst (Subst in_scope _ tv_env) = TvSubst in_scope tv_env
+mkEmptySubst in_scope = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
 
--- getTvSubstEnv :: Subst -> TvSubstEnv
--- getTvSubstEnv (Subst _ _ tv_env) = tv_env
--- 
--- setTvSubstEnv :: Subst -> TvSubstEnv -> Subst
--- setTvSubstEnv (Subst in_scope ids _) tvs = Subst in_scope ids tvs
+mkSubst :: InScopeSet -> TvSubstEnv -> CvSubstEnv -> IdSubstEnv -> Subst
+mkSubst in_scope tvs cvs ids = Subst in_scope ids tvs cvs
 
 -- | Find the in-scope set: see "CoreSubst#in_scope_invariant"
 substInScope :: Subst -> InScopeSet
-substInScope (Subst in_scope _ _) = in_scope
+substInScope (Subst in_scope _ _ _) = in_scope
 
 -- | Remove all substitutions for 'Id's and 'Var's that might have been built up
 -- while preserving the in-scope set
 zapSubstEnv :: Subst -> Subst
-zapSubstEnv (Subst in_scope _ _) = Subst in_scope emptyVarEnv emptyVarEnv
+zapSubstEnv (Subst in_scope _ _ _) = Subst in_scope emptyVarEnv emptyVarEnv emptyVarEnv
 
 -- | Add a substitution for an 'Id' to the 'Subst': you must ensure that the in-scope set is
 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
 extendIdSubst :: Subst -> Id -> CoreExpr -> Subst
 -- ToDo: add an ASSERT that fvs(subst-result) is already in the in-scope set
-extendIdSubst (Subst in_scope ids tvs) v r = Subst in_scope (extendVarEnv ids v r) tvs
+extendIdSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope (extendVarEnv ids v r) tvs cvs
 
 -- | Adds multiple 'Id' substitutions to the 'Subst': see also 'extendIdSubst'
 extendIdSubstList :: Subst -> [(Id, CoreExpr)] -> Subst
-extendIdSubstList (Subst in_scope ids tvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs
+extendIdSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope (extendVarEnvList ids prs) tvs cvs
 
 -- | Add a substitution for a 'TyVar' to the 'Subst': you must ensure that the in-scope set is
 -- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
 extendTvSubst :: Subst -> TyVar -> Type -> Subst
-extendTvSubst (Subst in_scope ids tvs) v r = Subst in_scope ids (extendVarEnv tvs v r) 
+extendTvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids (extendVarEnv tvs v r) cvs
 
 -- | Adds multiple 'TyVar' substitutions to the 'Subst': see also 'extendTvSubst'
 extendTvSubstList :: Subst -> [(TyVar,Type)] -> Subst
-extendTvSubstList (Subst in_scope ids tvs) prs = Subst in_scope ids (extendVarEnvList tvs prs)
+extendTvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids (extendVarEnvList tvs prs) cvs
 
--- | Add a substitution for a 'TyVar' or 'Id' as appropriate to the 'Var' being added. See also
--- 'extendIdSubst' and 'extendTvSubst'
-extendSubst :: Subst -> Var -> CoreArg -> Subst
-extendSubst (Subst in_scope ids tvs) tv (Type ty)
-  = ASSERT( isTyCoVar tv ) Subst in_scope ids (extendVarEnv tvs tv ty)
-extendSubst (Subst in_scope ids tvs) id expr
-  = ASSERT( isId id ) Subst in_scope (extendVarEnv ids id expr) tvs
+-- | Add a substitution from a 'TyCoVar' to a 'Coercion' to the 'Subst': you must ensure that the in-scope set is
+-- such that the "CoreSubst#in_scope_invariant" is true after extending the substitution like this
+extendCvSubst :: Subst -> TyCoVar -> Coercion -> Subst
+extendCvSubst (Subst in_scope ids tvs cvs) v r = Subst in_scope ids tvs (extendVarEnv cvs v r)
+
+-- | Adds multiple 'TyCoVar' -> 'Coercion' substitutions to the
+-- 'Subst': see also 'extendCvSubst'
+extendCvSubstList :: Subst -> [(TyCoVar,Coercion)] -> Subst
+extendCvSubstList (Subst in_scope ids tvs cvs) prs = Subst in_scope ids tvs (extendVarEnvList cvs prs)
 
--- | Add a substitution for a 'TyVar' or 'Id' as appropriate to all the 'Var's being added. See also 'extendSubst'
+-- | Add a substitution appropriate to the thing being substituted
+--   (whether an expression, type, or coercion). See also
+--   'extendIdSubst', 'extendTvSubst', and 'extendCvSubst'.
+extendSubst :: Subst -> Var -> CoreArg -> Subst
+extendSubst subst var arg
+  = case arg of
+      Type ty     -> ASSERT( isTyVar var ) extendTvSubst subst var ty
+      Coercion co -> ASSERT( isCoVar var ) extendCvSubst subst var co
+      _           -> ASSERT( isId    var ) extendIdSubst subst var arg
+
+extendSubstWithVar :: Subst -> Var -> Var -> Subst
+extendSubstWithVar subst v1 v2
+  | isTyVar v1 = ASSERT( isTyVar v2 ) extendTvSubst subst v1 (mkTyVarTy v2)
+  | isCoVar v1 = ASSERT( isCoVar v2 ) extendCvSubst subst v1 (mkCoVarCo v2)
+  | otherwise  = ASSERT( isId    v2 ) extendIdSubst subst v1 (Var v2)
+
+-- | Add a substitution as appropriate to each of the terms being
+--   substituted (whether expressions, types, or coercions). See also
+--   'extendSubst'.
 extendSubstList :: Subst -> [(Var,CoreArg)] -> Subst
 extendSubstList subst []             = subst
 extendSubstList subst ((var,rhs):prs) = extendSubstList (extendSubst subst var rhs) prs
 
 -- | Find the substitution for an 'Id' in the 'Subst'
 lookupIdSubst :: SDoc -> Subst -> Id -> CoreExpr
-lookupIdSubst doc (Subst in_scope ids _) v
+lookupIdSubst doc (Subst in_scope ids _ _) v
   | not (isLocalId v) = Var v
   | Just e  <- lookupVarEnv ids       v = e
   | Just v' <- lookupInScope in_scope v = Var v'
@@ -231,18 +256,22 @@ lookupIdSubst doc (Subst in_scope ids _) v
 
 -- | Find the substitution for a 'TyVar' in the 'Subst'
 lookupTvSubst :: Subst -> TyVar -> Type
-lookupTvSubst (Subst _ _ tvs) v = lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+lookupTvSubst (Subst _ _ tvs _) v = ASSERT( isTyVar v) lookupVarEnv tvs v `orElse` Type.mkTyVarTy v
+
+-- | Find the coercion substitution for a 'TyCoVar' in the 'Subst'
+lookupCvSubst :: Subst -> CoVar -> Coercion
+lookupCvSubst (Subst _ _ _ cvs) v = ASSERT( isCoVar v ) lookupVarEnv cvs v `orElse` mkCoVarCo v
 
 delBndr :: Subst -> Var -> Subst
-delBndr (Subst in_scope tvs ids) v
-  | isId v    = Subst in_scope tvs (delVarEnv ids v)
-  | otherwise = Subst in_scope (delVarEnv tvs v) ids
+delBndr (Subst in_scope ids tvs cvs) v
+  | isCoVar v = Subst in_scope ids tvs (delVarEnv cvs v)
+  | isTyVar v = Subst in_scope ids (delVarEnv tvs v) cvs
+  | otherwise = Subst in_scope (delVarEnv ids v) tvs cvs
 
 delBndrs :: Subst -> [Var] -> Subst
-delBndrs (Subst in_scope tvs ids) vs
-  = Subst in_scope (delVarEnvList tvs vs_tv) (delVarEnvList ids vs_id)
-  where
-    (vs_id, vs_tv) = partition isId vs
+delBndrs (Subst in_scope ids tvs cvs) vs
+  = Subst in_scope (delVarEnvList ids vs) (delVarEnvList tvs vs) (delVarEnvList cvs vs)
+      -- Easist thing is just delete all from all!
 
 -- | Simultaneously substitute for a bunch of variables
 --   No left-right shadowing
@@ -252,49 +281,51 @@ mkOpenSubst :: InScopeSet -> [(Var,CoreArg)] -> Subst
 mkOpenSubst in_scope pairs = Subst in_scope
                                   (mkVarEnv [(id,e)  | (id, e) <- pairs, isId id])
                                   (mkVarEnv [(tv,ty) | (tv, Type ty) <- pairs])
+                                   (mkVarEnv [(v,co)  | (v, Coercion co) <- pairs])
 
 ------------------------------
 isInScope :: Var -> Subst -> Bool
-isInScope v (Subst in_scope _ _) = v `elemInScopeSet` in_scope
+isInScope v (Subst in_scope _ _ _) = v `elemInScopeSet` in_scope
 
 -- | Add the 'Var' to the in-scope set, but do not remove
 -- any existing substitutions for it
 addInScopeSet :: Subst -> VarSet -> Subst
-addInScopeSet (Subst in_scope ids tvs) vs
-  = Subst (in_scope `extendInScopeSetSet` vs) ids tvs
+addInScopeSet (Subst in_scope ids tvs cvs) vs
+  = Subst (in_scope `extendInScopeSetSet` vs) ids tvs cvs
 
 -- | Add the 'Var' to the in-scope set: as a side effect,
 -- and remove any existing substitutions for it
 extendInScope :: Subst -> Var -> Subst
-extendInScope (Subst in_scope ids tvs) v
+extendInScope (Subst in_scope ids tvs cvs) v
   = Subst (in_scope `extendInScopeSet` v) 
-         (ids `delVarEnv` v) (tvs `delVarEnv` v)
+         (ids `delVarEnv` v) (tvs `delVarEnv` v) (cvs `delVarEnv` v)
 
 -- | Add the 'Var's to the in-scope set: see also 'extendInScope'
 extendInScopeList :: Subst -> [Var] -> Subst
-extendInScopeList (Subst in_scope ids tvs) vs
+extendInScopeList (Subst in_scope ids tvs cvs) vs
   = Subst (in_scope `extendInScopeSetList` vs) 
-         (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs)
+         (ids `delVarEnvList` vs) (tvs `delVarEnvList` vs) (cvs `delVarEnvList` vs)
 
 -- | Optimized version of 'extendInScopeList' that can be used if you are certain 
--- all the things being added are 'Id's and hence none are 'TyVar's
+-- all the things being added are 'Id's and hence none are 'TyVar's or 'CoVar's
 extendInScopeIds :: Subst -> [Id] -> Subst
-extendInScopeIds (Subst in_scope ids tvs) vs 
+extendInScopeIds (Subst in_scope ids tvs cvs) vs 
   = Subst (in_scope `extendInScopeSetList` vs) 
-         (ids `delVarEnvList` vs) tvs
+         (ids `delVarEnvList` vs) tvs cvs
 
 setInScope :: Subst -> InScopeSet -> Subst
-setInScope (Subst _ ids tvs) in_scope = Subst in_scope ids tvs
+setInScope (Subst _ ids tvs cvs) in_scope = Subst in_scope ids tvs cvs
 \end{code}
 
 Pretty printing, for debugging only
 
 \begin{code}
 instance Outputable Subst where
-  ppr (Subst in_scope ids tvs) 
+  ppr (Subst in_scope ids tvs cvs
        =  ptext (sLit "<InScope =") <+> braces (fsep (map ppr (varEnvElts (getInScopeVars in_scope))))
        $$ ptext (sLit " IdSubst   =") <+> ppr ids
        $$ ptext (sLit " TvSubst   =") <+> ppr tvs
+        $$ ptext (sLit " CvSubst   =") <+> ppr cvs   
         <> char '>'
 \end{code}
 
@@ -326,10 +357,11 @@ subst_expr subst expr
   where
     go (Var v)        = lookupIdSubst (text "subst_expr") subst v 
     go (Type ty)       = Type (substTy subst ty)
+    go (Coercion co)   = Coercion (substCo subst co)
     go (Lit lit)       = Lit lit
     go (App fun arg)   = App (go fun) (go arg)
     go (Note note e)   = Note (go_note note) (go e)
-    go (Cast e co)     = Cast (go e) (optCoercion (getTvSubst subst) co)
+    go (Cast e co)     = Cast (go e) (substCo subst co)
        -- Do not optimise even identity coercions
        -- Reason: substitution applies to the LHS of RULES, and
        --         if you "optimise" an identity coercion, you may
@@ -416,8 +448,9 @@ preserve occ info in rules.
 -- 'IdInfo' is preserved by this process, although it is substituted into appropriately.
 substBndr :: Subst -> Var -> (Subst, Var)
 substBndr subst bndr
-  | isTyCoVar bndr  = substTyVarBndr subst bndr
-  | otherwise       = substIdBndr (text "var-bndr") subst subst bndr
+  | isTyVar bndr  = substTyVarBndr subst bndr
+  | isCoVar bndr  = substCoVarBndr subst bndr
+  | otherwise     = substIdBndr (text "var-bndr") subst subst bndr
 
 -- | Applies 'substBndr' to a number of 'Var's, accumulating a new 'Subst' left-to-right
 substBndrs :: Subst -> [Var] -> (Subst, [Var])
@@ -439,9 +472,9 @@ substIdBndr :: SDoc
            -> (Subst, Id)      -- ^ Transformed pair
                                -- NB: unfolding may be zapped
 
-substIdBndr _doc rec_subst subst@(Subst in_scope env tvs) old_id
+substIdBndr _doc rec_subst subst@(Subst in_scope env tvs cvs) old_id
   = -- pprTrace "substIdBndr" (doc $$ ppr old_id $$ ppr in_scope) $
-    (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+    (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
   where
     id1 = uniqAway in_scope old_id     -- id1 is cloned if necessary
     id2 | no_type_change = id1
@@ -498,8 +531,8 @@ clone_id    :: Subst                        -- Substitution for the IdInfo
            -> Subst -> (Id, Unique)    -- Substitition and Id to transform
            -> (Subst, Id)              -- Transformed pair
 
-clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
-  = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs, new_id)
+clone_id rec_subst subst@(Subst in_scope env tvs cvs) (old_id, uniq)
+  = (Subst (in_scope `extendInScopeSet` new_id) new_env tvs cvs, new_id)
   where
     id1            = setVarUnique old_id uniq
     id2     = substIdType subst id1
@@ -510,26 +543,40 @@ clone_id rec_subst subst@(Subst in_scope env tvs) (old_id, uniq)
 
 %************************************************************************
 %*                                                                     *
-               Types
+               Types and Coercions
 %*                                                                     *
 %************************************************************************
 
-For types we just call the corresponding function in Type, but we have
-to repackage the substitution, from a Subst to a TvSubst
+For types and coercions we just call the corresponding functions in
+Type and Coercion, but we have to repackage the substitution, from a
+Subst to a TvSubst.
 
 \begin{code}
 substTyVarBndr :: Subst -> TyVar -> (Subst, TyVar)
-substTyVarBndr (Subst in_scope id_env tv_env) tv
+substTyVarBndr (Subst in_scope id_env tv_env cv_env) tv
   = case Type.substTyVarBndr (TvSubst in_scope tv_env) tv of
        (TvSubst in_scope' tv_env', tv') 
-          -> (Subst in_scope' id_env tv_env', tv')
+          -> (Subst in_scope' id_env tv_env' cv_env, tv')
+
+substCoVarBndr :: Subst -> TyVar -> (Subst, TyVar)
+substCoVarBndr (Subst in_scope id_env tv_env cv_env) cv
+  = case Coercion.substCoVarBndr (CvSubst in_scope tv_env cv_env) cv of
+       (CvSubst in_scope' tv_env' cv_env', cv') 
+          -> (Subst in_scope' id_env tv_env' cv_env', cv')
 
 -- | See 'Type.substTy'
 substTy :: Subst -> Type -> Type 
 substTy subst ty = Type.substTy (getTvSubst subst) ty
 
 getTvSubst :: Subst -> TvSubst
-getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
+getTvSubst (Subst in_scope _ tenv _) = TvSubst in_scope tenv
+
+getCvSubst :: Subst -> CvSubst
+getCvSubst (Subst in_scope _ tenv cenv) = CvSubst in_scope tenv cenv
+
+-- | See 'Coercion.substCo'
+substCo :: Subst -> Coercion -> Coercion
+substCo subst co = Coercion.substCo (getCvSubst subst) co
 \end{code}
 
 
@@ -541,8 +588,8 @@ getTvSubst (Subst in_scope _id_env tv_env) = TvSubst in_scope tv_env
 
 \begin{code}
 substIdType :: Subst -> Id -> Id
-substIdType subst@(Subst _ _ tv_env) id
-  | isEmptyVarEnv tv_env || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
+substIdType subst@(Subst _ _ tv_env cv_env) id
+  | (isEmptyVarEnv tv_env && isEmptyVarEnv cv_env) || isEmptyVarSet (Type.tyVarsOfType old_ty) = id
   | otherwise  = setIdType id (substTy subst old_ty)
                -- The tyVarsOfType is cheaper than it looks
                -- because we cache the free tyvars of the type
@@ -555,7 +602,7 @@ substIdType subst@(Subst _ _ tv_env) id
 substIdInfo :: Subst -> Id -> IdInfo -> Maybe IdInfo
 substIdInfo subst new_id info
   | nothing_to_do = Nothing
-  | otherwise     = Just (info `setSpecInfo`             substSpec subst new_id old_rules
+  | otherwise     = Just (info `setSpecInfo`      substSpec subst new_id old_rules
                               `setUnfoldingInfo` substUnfolding subst old_unf)
   where
     old_rules    = specInfo info
@@ -594,7 +641,7 @@ substUnfolding _ unf = unf  -- NoUnfolding, OtherCon
 
 -------------------
 substUnfoldingSource :: Subst -> UnfoldingSource -> UnfoldingSource
-substUnfoldingSource (Subst in_scope ids _) (InlineWrapper wkr)
+substUnfoldingSource (Subst in_scope ids _ _) (InlineWrapper wkr)
   | Just wkr_expr <- lookupVarEnv ids wkr 
   = case wkr_expr of
       Var w1 -> InlineWrapper w1
@@ -628,7 +675,7 @@ substSpec subst new_id (SpecInfo rules rhs_fvs)
   where
     subst_ru_fn = const (idName new_id)
     new_spec = SpecInfo (map (substRule subst subst_ru_fn) rules)
-                         (substVarSet subst rhs_fvs)
+                        (substVarSet subst rhs_fvs)
 
 ------------------
 substRulesForImportedIds :: Subst -> [CoreRule] -> [CoreRule]
@@ -646,7 +693,6 @@ substRule :: Subst -> (Name -> Name) -> CoreRule -> CoreRule
 --    - Rules for *local* Ids are in the IdInfo for that Id,
 --      and the ru_fn field is simply replaced by the new name 
 --     of the Id
-
 substRule _ _ rule@(BuiltinRule {}) = rule
 substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
                                        , ru_fn = fn_name, ru_rhs = rhs
@@ -664,7 +710,7 @@ substRule subst subst_ru_fn rule@(Rule { ru_bndrs = bndrs, ru_args = args
 
 ------------------
 substVarSet :: Subst -> VarSet -> VarSet
-substVarSet subst fvs 
+substVarSet subst fvs
   = foldVarSet (unionVarSet . subst_fv subst) emptyVarSet fvs
   where
     subst_fv subst fv 
@@ -713,7 +759,7 @@ simpleOptExpr expr
        -- won't *be* substituting for x if it occurs inside a
        -- lambda.  
        --
-       -- It's a bit painful to call exprFreeVars, because it makes
+        -- It's a bit painful to call exprFreeVars, because it makes
        -- three passes instead of two (occ-anal, and go)
 
 simpleOptExprWith :: Subst -> InExpr -> OutExpr
@@ -747,19 +793,22 @@ type OutExpr = CoreExpr
 -- In these functions the substitution maps InVar -> OutExpr
 
 ----------------------
-simple_opt_expr :: Subst -> InExpr -> OutExpr
-simple_opt_expr subst expr
+simple_opt_expr, simple_opt_expr' :: Subst -> InExpr -> OutExpr
+simple_opt_expr s e = simple_opt_expr' s e
+
+simple_opt_expr' subst expr
   = go expr
   where
     go (Var v)          = lookupIdSubst (text "simpleOptExpr") subst v
     go (App e1 e2)      = simple_app subst e1 [go e2]
-    go (Type ty)        = Type (substTy subst ty)
+    go (Type ty)        = Type     (substTy subst ty)
+    go (Coercion co)    = Coercion (optCoercion (getCvSubst subst) co)
     go (Lit lit)        = Lit lit
     go (Note note e)    = Note note (go e)
-    go (Cast e co)      | isIdentityCoercion co' = go e
-                               | otherwise              = Cast (go e) co' 
+    go (Cast e co)      | isReflCo co' = go e
+                               | otherwise    = Cast (go e) co' 
                         where
-                          co' = substTy subst co
+                          co' = optCoercion (getCvSubst subst) co
 
     go (Let bind body) = case simple_opt_bind subst bind of
                            (subst', Nothing)   -> simple_opt_expr subst' body
@@ -806,21 +855,25 @@ simple_app subst e as
   = foldl App (simple_opt_expr subst e) as
 
 ----------------------
-simple_opt_bind :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
-simple_opt_bind subst (Rec prs)
-  = (subst'', Just (Rec (reverse rev_prs')))
+simple_opt_bind,simple_opt_bind' :: Subst -> CoreBind -> (Subst, Maybe CoreBind)
+simple_opt_bind s b              -- Can add trace stuff here
+  = simple_opt_bind' s b
+
+simple_opt_bind' subst (Rec prs)
+  = (subst'', res_bind)
   where
+    res_bind            = Just (Rec (reverse rev_prs'))
     (subst', bndrs')    = subst_opt_bndrs subst (map fst prs)
     (subst'', rev_prs') = foldl do_pr (subst', []) (prs `zip` bndrs')
     do_pr (subst, prs) ((b,r), b') 
        = case maybe_substitute subst b r2 of
            Just subst' -> (subst', prs)
-          Nothing     -> (subst,  (b2,r2):prs)
+           Nothing     -> (subst,  (b2,r2):prs)
        where
          b2 = add_info subst b b'
          r2 = simple_opt_expr subst r
 
-simple_opt_bind subst (NonRec b r)
+simple_opt_bind' subst (NonRec b r)
   = case maybe_substitute subst b r' of
       Just ext_subst -> (ext_subst, Nothing)
       Nothing        -> (subst', Just (NonRec b2 r'))
@@ -836,10 +889,14 @@ maybe_substitute :: Subst -> InVar -> OutExpr -> Maybe Subst
     --   or     returns Nothing
 maybe_substitute subst b r
   | Type ty <- r       -- let a::* = TYPE ty in <body>
-  = ASSERT( isTyCoVar b )
+  = ASSERT( isTyVar b )
     Just (extendTvSubst subst b ty)
 
-  | isId b             -- let x = e in <body>
+  | Coercion co <- r
+  = ASSERT( isCoVar b )
+    Just (extendCvSubst subst b co)
+
+  | isId b              -- let x = e in <body>
   , safe_to_inline (idOccInfo b) 
   , isAlwaysActive (idInlineActivation b)      -- Note [Inline prag in simplOpt]
   , not (isStableUnfolding (idUnfolding b))
@@ -859,19 +916,20 @@ maybe_substitute subst b r
 ----------------------
 subst_opt_bndr :: Subst -> InVar -> (Subst, OutVar)
 subst_opt_bndr subst bndr
-  | isTyCoVar bndr  = substTyVarBndr subst bndr
-  | otherwise       = subst_opt_id_bndr subst bndr
+  | isTyVar bndr  = substTyVarBndr subst bndr
+  | isCoVar bndr  = substCoVarBndr subst bndr
+  | otherwise     = subst_opt_id_bndr subst bndr
 
 subst_opt_id_bndr :: Subst -> InId -> (Subst, OutId)
 -- Nuke all fragile IdInfo, unfolding, and RULES; 
 --    it gets added back later by add_info
 -- Rather like SimplEnv.substIdBndr
 --
--- It's important to zap fragile OccInfo (which CoreSubst.SubstIdBndr 
+-- It's important to zap fragile OccInfo (which CoreSubst.substIdBndr 
 -- carefully does not do) because simplOptExpr invalidates it
 
-subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst) old_id
-  = (Subst new_in_scope new_id_subst tv_subst, new_id)
+subst_opt_id_bndr subst@(Subst in_scope id_subst tv_subst cv_subst) old_id
+  = (Subst new_in_scope new_id_subst tv_subst cv_subst, new_id)
   where
     id1           = uniqAway in_scope old_id
     id2    = setIdType id1 (substTy subst (idType old_id))
@@ -894,9 +952,9 @@ subst_opt_bndrs subst bndrs
 
 ----------------------
 add_info :: Subst -> InVar -> OutVar -> OutVar
-add_info subst old_bndr new_bndr 
- | isTyCoVar old_bndr = new_bndr
- | otherwise          = maybeModifyIdInfo mb_new_info new_bndr
+add_info subst old_bndr new_bndr
+ | isTyVar old_bndr = new_bndr
+ | otherwise        = maybeModifyIdInfo mb_new_info new_bndr
  where
    mb_new_info = substIdInfo subst new_bndr (idInfo old_bndr)
 \end{code}
@@ -920,3 +978,4 @@ we don't know what phase we're in.  Here's an example
 When inlining 'foo' in 'bar' we want the let-binding for 'inner' 
 to remain visible until Phase 1
 
+
index 603b745..e754c6d 100644 (file)
@@ -15,7 +15,7 @@ module CoreSyn (
 
         -- ** 'Expr' construction
        mkLets, mkLams,
-       mkApps, mkTyApps, mkVarApps,
+       mkApps, mkTyApps, mkCoApps, mkVarApps,
        
        mkIntLit, mkIntLitInt,
        mkWordLit, mkWordLitWord,
@@ -23,18 +23,19 @@ module CoreSyn (
        mkFloatLit, mkFloatLitFloat,
        mkDoubleLit, mkDoubleLitDouble,
        
-       mkConApp, mkTyBind,
+       mkConApp, mkTyBind, mkCoBind,
        varToCoreExpr, varsToCoreExprs,
 
-        isTyCoVar, isId, cmpAltCon, cmpAlt, ltAlt,
+        isId, cmpAltCon, cmpAlt, ltAlt,
        
        -- ** Simple 'Expr' access functions and predicates
        bindersOf, bindersOfBinds, rhssOfBind, rhssOfAlts, 
        collectBinders, collectTyBinders, collectValBinders, collectTyAndValBinders,
        collectArgs, coreExprCc, flattenBinds, 
 
-       isValArg, isTypeArg, valArgCount, valBndrCount, isRuntimeArg, isRuntimeVar,
-       notSccNote,
+        isValArg, isTypeArg, isTyCoArg, valArgCount, valBndrCount,
+        isRuntimeArg, isRuntimeVar,
+        notSccNote,
 
        -- * Unfolding data types
         Unfolding(..),  UnfoldingGuidance(..), UnfoldingSource(..),
@@ -95,7 +96,7 @@ import Util
 import Data.Data
 import Data.Word
 
-infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`
+infixl 4 `mkApps`, `mkTyApps`, `mkVarApps`, `App`, `mkCoApps`
 -- Left associative, so that we can say (f `mkTyApps` xs `mkVarApps` ys)
 \end{code}
 
@@ -239,6 +240,8 @@ data Expr b
 
   | Type  Type                         -- ^ A type: this should only show up at the top
                                         -- level of an Arg
+    
+  | Coercion Coercion                   -- ^ A coercion
   deriving (Data, Typeable)
 
 -- | Type synonym for expressions that occur in function argument positions.
@@ -878,6 +881,8 @@ instance Outputable b => OutputableBndr (TaggedBndr b) where
 mkApps    :: Expr b -> [Arg b]  -> Expr b
 -- | Apply a list of type argument expressions to a function expression in a nested fashion
 mkTyApps  :: Expr b -> [Type]   -> Expr b
+-- | Apply a list of coercion argument expressions to a function expression in a nested fashion
+mkCoApps  :: Expr b -> [Coercion] -> Expr b
 -- | Apply a list of type or value variables to a function expression in a nested fashion
 mkVarApps :: Expr b -> [Var] -> Expr b
 -- | Apply a list of argument expressions to a data constructor in a nested fashion. Prefer to
@@ -886,6 +891,7 @@ mkConApp      :: DataCon -> [Arg b] -> Expr b
 
 mkApps    f args = foldl App                      f args
 mkTyApps  f args = foldl (\ e a -> App e (Type a)) f args
+mkCoApps  f args = foldl (\ e a -> App e (Coercion a)) f args
 mkVarApps f vars = foldl (\ e a -> App e (varToCoreExpr a)) f vars
 mkConApp con args = mkApps (Var (dataConWorkId con)) args
 
@@ -956,10 +962,16 @@ mkLets binds body   = foldr Let body binds
 mkTyBind :: TyVar -> Type -> CoreBind
 mkTyBind tv ty      = NonRec tv (Type ty)
 
+-- | Create a binding group where a type variable is bound to a type. Per "CoreSyn#type_let",
+-- this can only be used to bind something in a non-recursive @let@ expression
+mkCoBind :: CoVar -> Coercion -> CoreBind
+mkCoBind cv co      = NonRec cv (Coercion co)
+
 -- | Convert a binder into either a 'Var' or 'Type' 'Expr' appropriately
 varToCoreExpr :: CoreBndr -> Expr b
-varToCoreExpr v | isId v = Var v
-                | otherwise = Type (mkTyVarTy v)
+varToCoreExpr v | isTyVar v = Type (mkTyVarTy v)
+                | isCoVar v = Coercion (mkCoVarCo v)
+                | otherwise = ASSERT( isId v ) Var v
 
 varsToCoreExprs :: [CoreBndr] -> [Expr b]
 varsToCoreExprs vs = map varToCoreExpr vs
@@ -1025,7 +1037,7 @@ collectTyAndValBinders expr
 collectTyBinders expr
   = go [] expr
   where
-    go tvs (Lam b e) | isTyCoVar b = go (b:tvs) e
+    go tvs (Lam b e) | isTyVar b = go (b:tvs) e
     go tvs e                    = (reverse tvs, e)
 
 collectValBinders expr
@@ -1076,15 +1088,23 @@ isRuntimeVar = isId
 isRuntimeArg :: CoreExpr -> Bool
 isRuntimeArg = isValArg
 
--- | Returns @False@ iff the expression is a 'Type' expression at its top level
+-- | Returns @False@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
 isValArg :: Expr b -> Bool
-isValArg (Type _) = False
-isValArg _        = True
+isValArg e = not (isTypeArg e)
+
+-- | Returns @True@ iff the expression is a 'Type' or 'Coercion'
+-- expression at its top level
+isTyCoArg :: Expr b -> Bool
+isTyCoArg (Type {})     = True
+isTyCoArg (Coercion {}) = True
+isTyCoArg _             = False
 
--- | Returns @True@ iff the expression is a 'Type' expression at its top level
+-- | Returns @True@ iff the expression is a 'Type' expression at its
+-- top level.  Note this does NOT include 'Coercion's.
 isTypeArg :: Expr b -> Bool
-isTypeArg (Type _) = True
-isTypeArg _        = False
+isTypeArg (Type {}) = True
+isTypeArg _         = False
 
 -- | The number of binders that bind values rather than types
 valBndrCount :: [CoreBndr] -> Int
@@ -1114,9 +1134,10 @@ seqExpr (App f a)       = seqExpr f `seq` seqExpr a
 seqExpr (Lam b e)       = seqBndr b `seq` seqExpr e
 seqExpr (Let b e)       = seqBind b `seq` seqExpr e
 seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
-seqExpr (Cast e co)     = seqExpr e `seq` seqType co
+seqExpr (Cast e co)     = seqExpr e `seq` seqCo co
 seqExpr (Note n e)      = seqNote n `seq` seqExpr e
-seqExpr (Type t)        = seqType t
+seqExpr (Type t)       = seqType t
+seqExpr (Coercion co)   = seqCo co
 
 seqExprs :: [CoreExpr] -> ()
 seqExprs [] = ()
@@ -1170,9 +1191,11 @@ data AnnExpr' bndr annot
   | AnnApp     (AnnExpr bndr annot) (AnnExpr bndr annot)
   | AnnCase    (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
   | AnnLet     (AnnBind bndr annot) (AnnExpr bndr annot)
-  | AnnCast     (AnnExpr bndr annot) Coercion
+  | AnnCast     (AnnExpr bndr annot) (annot, Coercion)
+                  -- Put an annotation on the (root of) the coercion
   | AnnNote    Note (AnnExpr bndr annot)
   | AnnType    Type
+  | AnnCoercion Coercion
 
 -- | A clone of the 'Alt' type but allowing annotation at every tree node
 type AnnAlt bndr annot = (AltCon, [bndr], AnnExpr bndr annot)
@@ -1199,12 +1222,13 @@ deAnnotate :: AnnExpr bndr annot -> Expr bndr
 deAnnotate (_, e) = deAnnotate' e
 
 deAnnotate' :: AnnExpr' bndr annot -> Expr bndr
-deAnnotate' (AnnType t)           = Type t
+deAnnotate' (AnnType t)          = Type t
+deAnnotate' (AnnCoercion co)      = Coercion co
 deAnnotate' (AnnVar  v)           = Var v
 deAnnotate' (AnnLit  lit)         = Lit lit
 deAnnotate' (AnnLam  binder body) = Lam binder (deAnnotate body)
 deAnnotate' (AnnApp  fun arg)     = App (deAnnotate fun) (deAnnotate arg)
-deAnnotate' (AnnCast e co)        = Cast (deAnnotate e) co
+deAnnotate' (AnnCast e (_,co))    = Cast (deAnnotate e) co
 deAnnotate' (AnnNote note body)   = Note note (deAnnotate body)
 
 deAnnotate' (AnnLet bind body)
index 582f873..377bfd8 100644 (file)
@@ -17,7 +17,7 @@ import CoreSyn
 import CoreArity
 import Id
 import IdInfo
-import TcType( tidyType, tidyTyVarBndr )
+import TcType( tidyType, tidyCo, tidyTyVarBndr )
 import Var
 import VarEnv
 import UniqFM
@@ -55,11 +55,12 @@ tidyBind env (Rec prs)
 ------------  Expressions  --------------
 tidyExpr :: TidyEnv -> CoreExpr -> CoreExpr
 tidyExpr env (Var v)            =  Var (tidyVarOcc env v)
-tidyExpr env (Type ty)          =  Type (tidyType env ty)
+tidyExpr env (Type ty)  =  Type (tidyType env ty)
+tidyExpr env (Coercion co) = Coercion (tidyCo env co)
 tidyExpr _   (Lit lit)   =  Lit lit
 tidyExpr env (App f a)          =  App (tidyExpr env f) (tidyExpr env a)
 tidyExpr env (Note n e)  =  Note (tidyNote env n) (tidyExpr env e)
-tidyExpr env (Cast e co) =  Cast (tidyExpr env e) (tidyType env co)
+tidyExpr env (Cast e co) =  Cast (tidyExpr env e) (tidyCo env co)
 
 tidyExpr env (Let b e) 
   = tidyBind env b     =: \ (env', b') ->
@@ -125,7 +126,7 @@ tidyVarOcc (_, var_env) v = lookupVarEnv var_env v `orElse` v
 -- tidyBndr is used for lambda and case binders
 tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
 tidyBndr env var
-  | isTyCoVar var = tidyTyVarBndr env var
+  | isTyVar var = tidyTyVarBndr env var
   | otherwise   = tidyIdBndr env var
 
 tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
index d1b9fa0..5883013 100644 (file)
@@ -60,6 +60,7 @@ import PrelNames
 import VarEnv           ( mkInScopeSet )
 import Bag
 import Util
+import Pair
 import FastTypes
 import FastString
 import Outputable
@@ -107,7 +108,7 @@ mkWwInlineRule id expr arity
 mkCompulsoryUnfolding :: CoreExpr -> Unfolding
 mkCompulsoryUnfolding expr        -- Used for things that absolutely must be unfolded
   = mkCoreUnfolding InlineCompulsory True
-                    expr 0    -- Arity of unfolding doesn't matter
+                    (simpleOptExpr expr) 0    -- Arity of unfolding doesn't matter
                     (UnfWhen unSaturatedOk boringCxtOk)
 
 mkInlineUnfolding :: Maybe Arity -> CoreExpr -> Unfolding
@@ -348,11 +349,13 @@ sizeExpr bOMB_OUT_SIZE top_args expr
     size_up (Cast e _) = size_up e
     size_up (Note _ e) = size_up e
     size_up (Type _)   = sizeZero           -- Types cost nothing
+    size_up (Coercion _) = sizeZero
     size_up (Lit lit)  = sizeN (litSize lit)
     size_up (Var f)    = size_up_call f []  -- Make sure we get constructor
                                            -- discounts even on nullary constructors
 
     size_up (App fun (Type _)) = size_up fun
+    size_up (App fun (Coercion _)) = size_up fun
     size_up (App fun arg)      = size_up arg  `addSizeNSD`
                                  size_up_app fun [arg]
 
@@ -408,7 +411,7 @@ sizeExpr bOMB_OUT_SIZE top_args expr
     ------------ 
     -- size_up_app is used when there's ONE OR MORE value args
     size_up_app (App fun arg) args 
-       | isTypeArg arg            = size_up_app fun args
+       | isTyCoArg arg            = size_up_app fun args
        | otherwise                = size_up arg  `addSizeNSD`
                                      size_up_app fun (arg:args)
     size_up_app (Var fun)     args = size_up_call fun args
@@ -1147,12 +1150,14 @@ interestingArg e = go e 0
          conlike_unfolding = isConLikeUnfolding (idUnfolding v)
 
     go (Type _)          _ = TrivArg
-    go (App fn (Type _)) n = go fn n    
+    go (Coercion _)      _ = TrivArg
+    go (App fn (Type _)) n = go fn n
+    go (App fn (Coercion _)) n = go fn n
     go (App fn _)        n = go fn (n+1)
     go (Note _ a)       n = go a n
     go (Cast e _)       n = go e n
     go (Lam v e)        n 
-       | isTyCoVar v      = go e n
+       | isTyVar v        = go e n
        | n>0              = go e (n-1)
        | otherwise        = ValueArg
     go (Let _ e)        n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
@@ -1208,7 +1213,7 @@ exprIsConApp_maybe id_unf (Cast expr co)
        Nothing                          -> Nothing ;
        Just (dc, _dc_univ_args, dc_args) -> 
 
-    let (_from_ty, to_ty) = coercionKind co
+    let Pair _from_ty to_ty = coercionKind co
        dc_tc = dataConTyCon dc
     in
     case splitTyConApp_maybe to_ty of {
@@ -1228,41 +1233,28 @@ exprIsConApp_maybe id_unf (Cast expr co)
         dc_ex_tyvars   = dataConExTyVars dc
         arg_tys        = dataConRepArgTys dc
 
-        dc_eqs :: [(Type,Type)]          -- All equalities from the DataCon
-        dc_eqs = [(mkTyVarTy tv, ty)   | (tv,ty) <- dataConEqSpec dc] ++
-                 [getEqPredTys eq_pred | eq_pred <- dataConEqTheta dc]
-
-        (ex_args, rest1)    = splitAtList dc_ex_tyvars dc_args
-       (co_args, val_args) = splitAtList dc_eqs rest1
+        (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
 
        -- Make the "theta" from Fig 3 of the paper
         gammas = decomposeCo tc_arity co
-        theta  = zipOpenTvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
-                                (gammas         ++ stripTypeArgs ex_args)
-
-          -- Cast the existential coercion arguments
-        cast_co (ty1, ty2) (Type co) 
-          = Type $ mkSymCoercion (substTy theta ty1)
-                  `mkTransCoercion` co
-                  `mkTransCoercion` (substTy theta ty2)
-        cast_co _ other_arg = pprPanic "cast_co" (ppr other_arg)
-        new_co_args = zipWith cast_co dc_eqs co_args
-  
+        theta  = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
+                                (gammas         ++ map mkReflCo (stripTypeArgs ex_args))
+
           -- Cast the value arguments (which include dictionaries)
        new_val_args = zipWith cast_arg arg_tys val_args
-       cast_arg arg_ty arg = mkCoerce (substTy theta arg_ty) arg
+       cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg
     in
 #ifdef DEBUG
     let dump_doc = vcat [ppr dc,      ppr dc_univ_tyvars, ppr dc_ex_tyvars,
                          ppr arg_tys, ppr dc_args,        ppr _dc_univ_args,
                          ppr ex_args, ppr val_args]
     in
-    ASSERT2( coreEqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
-    ASSERT2( all isTypeArg (ex_args ++ co_args), dump_doc )
+    ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
+    ASSERT2( all isTypeArg ex_args, dump_doc )
     ASSERT2( equalLength val_args arg_tys, dump_doc )
 #endif
 
-    Just (dc, to_tc_arg_tys, ex_args ++ new_co_args ++ new_val_args)
+    Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
     }}
 
 exprIsConApp_maybe id_unf expr 
@@ -1301,7 +1293,7 @@ exprIsConApp_maybe id_unf expr
 
     -----------
     beta (Lam v body) pairs (arg : args) 
-        | isTypeArg arg
+        | isTyCoArg arg
         = beta body ((v,arg):pairs) args 
 
     beta (Lam {}) _ _    -- Un-saturated, or not a type lambda
@@ -1313,10 +1305,10 @@ exprIsConApp_maybe id_unf expr
           subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs
          -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
 
-
 stripTypeArgs :: [CoreExpr] -> [Type]
 stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
                      [ty | Type ty <- args]
+  -- We really do want isTypeArg here, not isTyCoArg!
 \end{code}
 
 Note [Unfolding DFuns]
index 70e1db7..a0a229f 100644 (file)
@@ -16,7 +16,7 @@ Utility functions on @Core@ syntax
 -- | Commonly useful utilites for manipulating the Core language
 module CoreUtils (
        -- * Constructing expressions
-       mkSCC, mkCoerce, mkCoerceI,
+       mkSCC, mkCoerce,
        bindNonRec, needsCaseBinding,
        mkAltExpr, mkPiType, mkPiTypes,
 
@@ -45,7 +45,7 @@ module CoreUtils (
 
        -- * Manipulating data constructors and types
        applyTypeToArgs, applyTypeToArg,
-        dataConOrigInstPat, dataConRepInstPat, dataConRepFSInstPat
+        dataConRepInstPat, dataConRepFSInstPat
     ) where
 
 #include "HsVersions.h"
@@ -62,7 +62,6 @@ import DataCon
 import PrimOp
 import Id
 import IdInfo
-import TcType  ( isPredTy )
 import Type
 import Coercion
 import TyCon
@@ -73,6 +72,7 @@ import TysPrim
 import FastString
 import Maybes
 import Util
+import Pair
 import Data.Word
 import Data.Bits
 \end{code}
@@ -91,9 +91,10 @@ exprType :: CoreExpr -> Type
 -- really be said to have a type
 exprType (Var var)          = idType var
 exprType (Lit lit)          = literalType lit
+exprType (Coercion co)      = coercionType co
 exprType (Let _ body)       = exprType body
 exprType (Case _ _ ty _)     = ty
-exprType (Cast _ co)         = snd (coercionKind co)
+exprType (Cast _ co)         = pSnd (coercionKind co)
 exprType (Note _ e)          = exprType e
 exprType (Lam binder expr)   = mkPiType binder (exprType expr)
 exprType e@(App _ _)
@@ -110,7 +111,7 @@ coreAltType (_,bs,rhs)
   where
     ty           = exprType rhs
     free_tvs     = tyVarsOfType ty
-    bad_binder b = isTyCoVar b && b `elemVarSet` free_tvs
+    bad_binder b = isTyVar b && b `elemVarSet` free_tvs
 
 coreAltsType :: [CoreAlt] -> Type
 -- ^ Returns the type of the first alternative, which should be the same as for all alternatives
@@ -143,10 +144,10 @@ Various possibilities suggest themselves:
    we are doing here.  It's not too expensive, I think.
 
 \begin{code}
-mkPiType  :: EvVar -> Type -> Type
+mkPiType  :: Var -> Type -> Type
 -- ^ Makes a @(->)@ type or a forall type, depending
 -- on whether it is given a type variable or a term variable.
-mkPiTypes :: [EvVar] -> Type -> Type
+mkPiTypes :: [Var] -> Type -> Type
 -- ^ 'mkPiType' for multiple type or value arguments
 
 mkPiType v ty
@@ -172,11 +173,11 @@ applyTypeToArgs e op_ty (Type ty : args)
     go [ty] args
   where
     go rev_tys (Type ty : args) = go (ty:rev_tys) args
-    go rev_tys rest_args        = applyTypeToArgs e op_ty' rest_args
-                               where
-                                 op_ty' = applyTysD msg op_ty (reverse rev_tys)
-                                 msg = ptext (sLit "applyTypeToArgs") <+> 
-                                       panic_msg e op_ty
+    go rev_tys rest_args         = applyTypeToArgs e op_ty' rest_args
+                                where
+                                  op_ty' = applyTysD msg op_ty (reverse rev_tys)
+                                  msg = ptext (sLit "applyTypeToArgs") <+> 
+                                        panic_msg e op_ty
 
 applyTypeToArgs e op_ty (_ : args)
   = case (splitFunTy_maybe op_ty) of
@@ -194,25 +195,22 @@ panic_msg e op_ty = pprCoreExpr e $$ ppr op_ty
 %************************************************************************
 
 \begin{code}
--- | Wrap the given expression in the coercion, dropping identity coercions and coalescing nested coercions
-mkCoerceI :: CoercionI -> CoreExpr -> CoreExpr
-mkCoerceI (IdCo _) e = e
-mkCoerceI (ACo co) e = mkCoerce co e
-
--- | Wrap the given expression in the coercion safely, coalescing nested coercions
+-- | Wrap the given expression in the coercion safely, dropping
+-- identity coercions and coalescing nested coercions
 mkCoerce :: Coercion -> CoreExpr -> CoreExpr
+mkCoerce co e | isReflCo co = e
 mkCoerce co (Cast expr co2)
-  = ASSERT(let { (from_ty, _to_ty) = coercionKind co; 
-                 (_from_ty2, to_ty2) = coercionKind co2} in
-           from_ty `coreEqType` to_ty2 )
-    mkCoerce (mkTransCoercion co2 co) expr
+  = ASSERT(let { Pair  from_ty  _to_ty  = coercionKind co; 
+                 Pair _from_ty2  to_ty2 = coercionKind co2} in
+           from_ty `eqType` to_ty2 )
+    mkCoerce (mkTransCo co2 co) expr
 
 mkCoerce co expr 
-  = let (from_ty, _to_ty) = coercionKind co in
---    if to_ty `coreEqType` from_ty
+  = let Pair from_ty _to_ty = coercionKind co in
+--    if to_ty `eqType` from_ty
 --    then expr
 --    else 
-        WARN(not (from_ty `coreEqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
+        WARN(not (from_ty `eqType` exprType expr), text "Trying to coerce" <+> text "(" <> ppr expr $$ text "::" <+> ppr (exprType expr) <> text ")" $$ ppr co $$ pprEqPred (coercionKind co))
          (Cast expr co)
 \end{code}
 
@@ -415,7 +413,8 @@ discount.
 \begin{code}
 exprIsTrivial :: CoreExpr -> Bool
 exprIsTrivial (Var _)          = True        -- See Note [Variables are trivial]
-exprIsTrivial (Type _)         = True
+exprIsTrivial (Type _)        = True
+exprIsTrivial (Coercion _)     = True
 exprIsTrivial (Lit lit)        = litIsTrivial lit
 exprIsTrivial (App e arg)      = not (isRuntimeArg arg) && exprIsTrivial e
 exprIsTrivial (Note _       e) = exprIsTrivial e  -- See Note [SCCs are trivial]
@@ -469,10 +468,11 @@ exprIsDupable e
   = isJust (go dupAppSize e)
   where
     go :: Int -> CoreExpr -> Maybe Int
-    go n (Type {}) = Just n
-    go n (Var {})  = decrement n
-    go n (Note _ e) = go n e
-    go n (Cast e _) = go n e
+    go n (Type {})     = Just n
+    go n (Coercion {}) = Just n
+    go n (Var {})      = decrement n
+    go n (Note _ e)    = go n e
+    go n (Cast e _)    = go n e
     go n (App f a) | Just n' <- go n a = go n' f
     go n (Lit lit) | litIsDupable lit = decrement n
     go _ _ = Nothing
@@ -540,13 +540,14 @@ exprIsExpandable = exprIsCheap' isExpandableApp   -- See Note [CONLIKE pragma] in
 
 type CheapAppFun = Id -> Int -> Bool
 exprIsCheap' :: CheapAppFun -> CoreExpr -> Bool
-exprIsCheap' _          (Lit _)   = True
-exprIsCheap' _          (Type _)  = True
-exprIsCheap' _          (Var _)   = True
-exprIsCheap' good_app (Note _ e)  = exprIsCheap' good_app e
-exprIsCheap' good_app (Cast e _)  = exprIsCheap' good_app e
-exprIsCheap' good_app (Lam x e)   = isRuntimeVar x
-                                 || exprIsCheap' good_app e
+exprIsCheap' _        (Lit _)      = True
+exprIsCheap' _        (Type _)    = True
+exprIsCheap' _        (Coercion _) = True
+exprIsCheap' _        (Var _)      = True
+exprIsCheap' good_app (Note _ e)   = exprIsCheap' good_app e
+exprIsCheap' good_app (Cast e _)   = exprIsCheap' good_app e
+exprIsCheap' good_app (Lam x e)    = isRuntimeVar x
+                                  || exprIsCheap' good_app e
 
 exprIsCheap' good_app (Case e _ _ alts) = exprIsCheap' good_app e && 
                                          and [exprIsCheap' good_app rhs | (_,_,rhs) <- alts]
@@ -684,8 +685,9 @@ it's applied only to dictionaries.
 -- We can only do this if the @y + 1@ is ok for speculation: it has no
 -- side effects, and can't diverge or raise an exception.
 exprOkForSpeculation :: CoreExpr -> Bool
-exprOkForSpeculation (Lit _)     = True
-exprOkForSpeculation (Type _)    = True
+exprOkForSpeculation (Lit _)      = True
+exprOkForSpeculation (Type _)     = True
+exprOkForSpeculation (Coercion _) = True
 
 exprOkForSpeculation (Var v)     
   | isTickBoxOp v = False     -- Tick boxes are *not* suitable for speculation
@@ -865,12 +867,14 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
        -- we could get an infinite loop
 
     is_hnf_like (Lit _)          = True
-    is_hnf_like (Type _)         = True       -- Types are honorary Values;
+    is_hnf_like (Type _)        = True       -- Types are honorary Values;
                                               -- we don't mind copying them
+    is_hnf_like (Coercion _)     = True       -- Same for coercions
     is_hnf_like (Lam b e)        = isRuntimeVar b || is_hnf_like e
     is_hnf_like (Note _ e)       = is_hnf_like e
     is_hnf_like (Cast e _)       = is_hnf_like e
-    is_hnf_like (App e (Type _)) = is_hnf_like e
+    is_hnf_like (App e (Type _))    = is_hnf_like e
+    is_hnf_like (App e (Coercion _)) = is_hnf_like e
     is_hnf_like (App e a)        = app_is_value e [a]
     is_hnf_like (Let _ e)        = is_hnf_like e  -- Lazy let(rec)s don't affect us
     is_hnf_like _                = False
@@ -896,36 +900,26 @@ exprIsHNFlike is_con is_con_unf = is_hnf_like
 These InstPat functions go here to avoid circularity between DataCon and Id
 
 \begin{code}
-dataConRepInstPat, dataConOrigInstPat :: [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
-dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [CoVar], [Id])
+dataConRepInstPat   ::                 [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
+dataConRepFSInstPat :: [FastString] -> [Unique] -> DataCon -> [Type] -> ([TyVar], [Id])
 
-dataConRepInstPat   = dataConInstPat dataConRepArgTys (repeat ((fsLit "ipv")))
-dataConRepFSInstPat = dataConInstPat dataConRepArgTys
-dataConOrigInstPat  = dataConInstPat dc_arg_tys       (repeat ((fsLit "ipv")))
-  where 
-    dc_arg_tys dc = map mkPredTy (dataConEqTheta dc) ++ map mkPredTy (dataConDictTheta dc) ++ dataConOrigArgTys dc
-       -- Remember to include the existential dictionaries
-
-dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
-                  -> [FastString]          -- A long enough list of FSs to use for names
-                  -> [Unique]              -- An equally long list of uniques, at least one for each binder
-                  -> DataCon
-                 -> [Type]                -- Types to instantiate the universally quantified tyvars
-              -> ([TyVar], [CoVar], [Id]) -- Return instantiated variables
+dataConRepInstPat   = dataConInstPat (repeat ((fsLit "ipv")))
+dataConRepFSInstPat = dataConInstPat 
+
+dataConInstPat :: [FastString]          -- A long enough list of FSs to use for names
+               -> [Unique]              -- An equally long list of uniques, at least one for each binder
+               -> DataCon
+              -> [Type]                -- Types to instantiate the universally quantified tyvars
+              -> ([TyVar], [Id])          -- Return instantiated variables
 -- dataConInstPat arg_fun fss us con inst_tys returns a triple 
--- (ex_tvs, co_tvs, arg_ids),
+-- (ex_tvs, arg_ids),
 --
 --   ex_tvs are intended to be used as binders for existential type args
 --
---   co_tvs are intended to be used as binders for coercion args and the kinds
---     of these vars have been instantiated by the inst_tys and the ex_tys
---     The co_tvs include both GADT equalities (dcEqSpec) and 
---     programmer-specified equalities (dcEqTheta)
---
 --   arg_ids are indended to be used as binders for value arguments, 
 --     and their types have been instantiated with inst_tys and ex_tys
---     The arg_ids include both dicts (dcDictTheta) and
---     programmer-specified arguments (after rep-ing) (deRepArgTys)
+--     The arg_ids include both evidence and
+--     programmer-specified arguments (both after rep-ing)
 --
 -- Example.
 --  The following constructor T1
@@ -940,29 +934,22 @@ dataConInstPat :: (DataCon -> [Type])      -- function used to find arg tys
 --
 --  dataConInstPat fss us T1 (a1',b') will return
 --
---  ([a1'', b''], [c :: (a1', b')~(a1'', b'')], [x :: Int, y :: b''])
+--  ([a1'', b''], [c :: (a1', b')~(a1'', b'')x :: Int, y :: b''])
 --
 --  where the double-primed variables are created with the FastStrings and
 --  Uniques given as fss and us
-dataConInstPat arg_fun fss uniqs con inst_tys 
-  = (ex_bndrs, co_bndrs, arg_ids)
+dataConInstPat fss uniqs con inst_tys 
+  = (ex_bndrs, arg_ids)
   where 
     univ_tvs = dataConUnivTyVars con
     ex_tvs   = dataConExTyVars con
-    arg_tys  = arg_fun con
-    eq_spec  = dataConEqSpec con
-    eq_theta = dataConEqTheta con
-    eq_preds = eqSpecPreds eq_spec ++ eq_theta
+    arg_tys  = dataConRepArgTys con
 
     n_ex = length ex_tvs
-    n_co = length eq_preds
 
       -- split the Uniques and FastStrings
-    (ex_uniqs, uniqs')   = splitAt n_ex uniqs
-    (co_uniqs, id_uniqs) = splitAt n_co uniqs'
-
-    (ex_fss, fss')     = splitAt n_ex fss
-    (co_fss, id_fss)   = splitAt n_co fss'
+    (ex_uniqs, id_uniqs) = splitAt n_ex uniqs
+    (ex_fss,   id_fss)   = splitAt n_ex fss
 
       -- Make existential type variables
     ex_bndrs = zipWith3 mk_ex_var ex_uniqs ex_fss ex_tvs
@@ -974,17 +961,9 @@ dataConInstPat arg_fun fss uniqs con inst_tys
       -- Make the instantiating substitution
     subst = zipOpenTvSubst (univ_tvs ++ ex_tvs) (inst_tys ++ map mkTyVarTy ex_bndrs)
 
-      -- Make new coercion vars, instantiating kind
-    co_bndrs = zipWith3 mk_co_var co_uniqs co_fss eq_preds
-    mk_co_var uniq fs eq_pred = mkCoVar new_name co_kind
-       where
-         new_name = mkSysTvName uniq fs
-         co_kind  = substTy subst (mkPredTy eq_pred)
-
-      -- make value vars, instantiating types
-    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (substTy subst ty) noSrcSpan
+      -- Make value vars, instantiating types
+    mk_id_var uniq fs ty = mkUserLocal (mkVarOccFS fs) uniq (Type.substTy subst ty) noSrcSpan
     arg_ids = zipWith3 mk_id_var id_uniqs id_fss arg_tys
-
 \end{code}
 
 %************************************************************************
@@ -1003,7 +982,8 @@ cheapEqExpr :: Expr b -> Expr b -> Bool
 
 cheapEqExpr (Var v1)   (Var v2)   = v1==v2
 cheapEqExpr (Lit lit1) (Lit lit2) = lit1 == lit2
-cheapEqExpr (Type t1)  (Type t2)  = t1 `coreEqType` t2
+cheapEqExpr (Type t1) (Type t2) = t1 `eqType` t2
+cheapEqExpr (Coercion c1) (Coercion c2) = c1 `coreEqCoercion` c2
 
 cheapEqExpr (App f1 a1) (App f2 a2)
   = f1 `cheapEqExpr` f2 && a1 `cheapEqExpr` a2
@@ -1019,7 +999,8 @@ exprIsBig :: Expr b -> Bool
 -- ^ Returns @True@ of expressions that are too big to be compared by 'cheapEqExpr'
 exprIsBig (Lit _)      = False
 exprIsBig (Var _)      = False
-exprIsBig (Type _)     = False
+exprIsBig (Type _)    = False
+exprIsBig (Coercion _) = False
 exprIsBig (Lam _ e)    = exprIsBig e
 exprIsBig (App f a)    = exprIsBig f || exprIsBig a
 exprIsBig (Cast e _)   = exprIsBig e   -- Hopefully coercions are not too big!
@@ -1061,14 +1042,15 @@ eqExprX id_unfolding_fun env e1 e2
       , Just e2' <- expandUnfolding_maybe (id_unfolding_fun (lookupRnInScope env v2))
       = go (nukeRnEnvR env) e1 e2'
 
-    go _   (Lit lit1)    (Lit lit2)    = lit1 == lit2
-    go env (Type t1)     (Type t2)     = tcEqTypeX env t1 t2
-    go env (Cast e1 co1) (Cast e2 co2) = tcEqTypeX env co1 co2 && go env e1 e2
+    go _   (Lit lit1)    (Lit lit2)      = lit1 == lit2
+    go env (Type t1)    (Type t2)        = eqTypeX env t1 t2
+    go env (Coercion co1) (Coercion co2) = coreEqCoercion2 env co1 co2
+    go env (Cast e1 co1) (Cast e2 co2) = coreEqCoercion2 env co1 co2 && go env e1 e2
     go env (App f1 a1)   (App f2 a2)   = go env f1 f2 && go env a1 a2
     go env (Note n1 e1)  (Note n2 e2)  = go_note n1 n2 && go env e1 e2
 
     go env (Lam b1 e1)  (Lam b2 e2)  
-      =  tcEqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination
+      =  eqTypeX env (varType b1) (varType b2)   -- False for Id/TyVar combination
       && go (rnBndr2 env b1 b2) e1 e2
 
     go env (Let (NonRec v1 r1) e1) (Let (NonRec v2 r2) e2) 
@@ -1084,7 +1066,7 @@ eqExprX id_unfolding_fun env e1 e2
 
     go env (Case e1 b1 _ a1) (Case e2 b2 _ a2)
       =  go env e1 e2
-      && tcEqTypeX env (idType b1) (idType b2)
+      && eqTypeX env (idType b1) (idType b2)
       && all2 (go_alt (rnBndr2 env b1 b2)) a1 a2
 
     go _ _ _ = False
@@ -1128,16 +1110,17 @@ exprSize (App f a)       = exprSize f + exprSize a
 exprSize (Lam b e)       = varSize b + exprSize e
 exprSize (Let b e)       = bindSize b + exprSize e
 exprSize (Case e b t as) = seqType t `seq` exprSize e + varSize b + 1 + foldr ((+) . altSize) 0 as
-exprSize (Cast e co)     = (seqType co `seq` 1) + exprSize e
+exprSize (Cast e co)     = (seqCo co `seq` 1) + exprSize e
 exprSize (Note n e)      = noteSize n + exprSize e
-exprSize (Type t)        = seqType t `seq` 1
+exprSize (Type t)       = seqType t `seq` 1
+exprSize (Coercion co)   = seqCo co `seq` 1
 
 noteSize :: Note -> Int
 noteSize (SCC cc)       = cc `seq` 1
 noteSize (CoreNote s)   = s `seq` 1  -- hdaume: core annotations
  
 varSize :: Var -> Int
-varSize b  | isTyCoVar b = 1
+varSize b  | isTyVar b = 1
           | otherwise = seqType (idType b)             `seq`
                         megaSeqIdInfo (idInfo b)       `seq`
                         1
@@ -1187,30 +1170,23 @@ bndrStats v = oneTM `plusCS` tyStats (varType v)
 exprStats :: CoreExpr -> CoreStats
 exprStats (Var {})        = oneTM
 exprStats (Lit {})        = oneTM
-exprStats (App f (Type t))= tyCoStats (exprType f) t
+exprStats (Type t)        = tyStats t
+exprStats (Coercion c)    = coStats c
 exprStats (App f a)       = exprStats f `plusCS` exprStats a 
 exprStats (Lam b e)       = bndrStats b `plusCS` exprStats e 
 exprStats (Let b e)       = bindStats b `plusCS` exprStats e 
 exprStats (Case e b _ as) = exprStats e `plusCS` bndrStats b `plusCS` sumCS altStats as
 exprStats (Cast e co)     = coStats co `plusCS` exprStats e
 exprStats (Note _ e)      = exprStats e
-exprStats (Type ty)       = zeroCS { cs_ty = typeSize ty }
-         -- Ugh (might be a co)
 
 altStats :: CoreAlt -> CoreStats
 altStats (_, bs, r) = sumCS bndrStats bs `plusCS` exprStats r
 
-tyCoStats :: Type -> Type -> CoreStats
-tyCoStats fun_ty arg
-  = case splitForAllTy_maybe fun_ty of
-      Just (tv,_) | isCoVar tv -> coStats arg
-      _                        -> tyStats arg
-
 tyStats :: Type -> CoreStats
 tyStats ty = zeroCS { cs_ty = typeSize ty }
 
 coStats :: Coercion -> CoreStats
-coStats co = zeroCS { cs_co = typeSize co }
+coStats co = zeroCS { cs_co = coercionSize co }
 \end{code}
 
 %************************************************************************
@@ -1252,15 +1228,17 @@ hash_expr env (Lam b e)               = hash_expr (extend_env env b) e
 hash_expr _   (Type _)                = WARN(True, text "hash_expr: type") 1
 -- Shouldn't happen.  Better to use WARN than trace, because trace
 -- prevents the CPR optimisation kicking in for hash_expr.
+hash_expr _   (Coercion _)            = WARN(True, text "hash_expr: coercion") 1
 
 fast_hash_expr :: HashEnv -> CoreExpr -> Word32
-fast_hash_expr env (Var v)             = hashVar env v
-fast_hash_expr env (Type t)    = fast_hash_type env t
-fast_hash_expr _   (Lit lit)    = fromIntegral (hashLiteral lit)
-fast_hash_expr env (Cast e _)   = fast_hash_expr env e
-fast_hash_expr env (Note _ e)   = fast_hash_expr env e
-fast_hash_expr env (App _ a)    = fast_hash_expr env a -- A bit idiosyncratic ('a' not 'f')!
-fast_hash_expr _   _            = 1
+fast_hash_expr env (Var v)              = hashVar env v
+fast_hash_expr env (Type t)     = fast_hash_type env t
+fast_hash_expr env (Coercion co) = fast_hash_co env co
+fast_hash_expr _   (Lit lit)     = fromIntegral (hashLiteral lit)
+fast_hash_expr env (Cast e _)    = fast_hash_expr env e
+fast_hash_expr env (Note _ e)    = fast_hash_expr env e
+fast_hash_expr env (App _ a)     = fast_hash_expr env a        -- A bit idiosyncratic ('a' not 'f')!
+fast_hash_expr _   _             = 1
 
 fast_hash_type :: HashEnv -> Type -> Word32
 fast_hash_type env ty 
@@ -1269,6 +1247,13 @@ fast_hash_type env ty
                                              in foldr (\t n -> fast_hash_type env t + n) hash_tc tys
   | otherwise                              = 1
 
+fast_hash_co :: HashEnv -> Coercion -> Word32
+fast_hash_co env co
+  | Just cv <- getCoVar_maybe co              = hashVar env cv
+  | Just (tc,cos) <- splitTyConAppCo_maybe co = let hash_tc = fromIntegral (hashName (tyConName tc))
+                                                in foldr (\c n -> fast_hash_co env c + n) hash_tc cos
+  | otherwise                                 = 1
+
 extend_env :: HashEnv -> Var -> (Int, VarEnv Int)
 extend_env (n,env) b = (n+1, extendVarEnv env b n)
 
@@ -1368,18 +1353,18 @@ need to address that here.
 \begin{code}
 tryEtaReduce :: [Var] -> CoreExpr -> Maybe CoreExpr
 tryEtaReduce bndrs body 
-  = go (reverse bndrs) body (IdCo (exprType body))
+  = go (reverse bndrs) body (mkReflCo (exprType body))
   where
     incoming_arity = count isId bndrs
 
     go :: [Var]                   -- Binders, innermost first, types [a3,a2,a1]
        -> CoreExpr         -- Of type tr
-       -> CoercionI        -- Of type tr ~ ts
+       -> Coercion         -- Of type tr ~ ts
        -> Maybe CoreExpr   -- Of type a1 -> a2 -> a3 -> ts
     -- See Note [Eta reduction with casted arguments]
     -- for why we have an accumulating coercion
     go [] fun co
-      | ok_fun fun = Just (mkCoerceI co fun)
+      | ok_fun fun = Just (mkCoerce co fun)
 
     go (b : bs) (App fun arg) co
       | Just co' <- ok_arg b arg co
@@ -1390,7 +1375,7 @@ tryEtaReduce bndrs body
     ---------------
     -- Note [Eta reduction conditions]
     ok_fun (App fun (Type ty)) 
-       | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
+        | not (any (`elemVarSet` tyVarsOfType ty) bndrs)
        =  ok_fun fun
     ok_fun (Var fun_id)
        =  not (fun_id `elem` bndrs)
@@ -1406,22 +1391,22 @@ tryEtaReduce bndrs body
        | otherwise = idArity fun             
 
     ---------------
-    ok_lam v = isTyCoVar v || isDictId v
+    ok_lam v = isTyVar v || isEvVar v
 
     ---------------
-    ok_arg :: Var              -- Of type bndr_t
-           -> CoreExpr          -- Of type arg_t
-           -> CoercionI         -- Of kind (t1~t2)
-           -> Maybe CoercionI   -- Of type (arg_t -> t1 ~  bndr_t -> t2)
-                               --   (and similarly for tyvars, coercion args)
+    ok_arg :: Var              -- Of type bndr_t
+           -> CoreExpr         -- Of type arg_t
+           -> Coercion         -- Of kind (t1~t2)
+           -> Maybe Coercion   -- Of type (arg_t -> t1 ~  bndr_t -> t2)
+                               --   (and similarly for tyvars, coercion args)
     -- See Note [Eta reduction with casted arguments]
     ok_arg bndr (Type ty) co
        | Just tv <- getTyVar_maybe ty
-       , bndr == tv  = Just (mkForAllTyCoI tv co)
+       , bndr == tv  = Just (mkForAllCo tv co)
     ok_arg bndr (Var v) co
-       | bndr == v   = Just (mkFunTyCoI (IdCo (idType bndr)) co)
+       | bndr == v   = Just (mkFunCo (mkReflCo (idType bndr)) co)
     ok_arg bndr (Cast (Var v) co_arg) co
-       | bndr == v  = Just (mkFunTyCoI (ACo (mkSymCoercion co_arg)) co)
+       | bndr == v  = Just (mkFunCo (mkSymCo co_arg) co)
        -- The simplifier combines multiple casts into one, 
        -- so we can have a simple-minded pattern match here
     ok_arg _ _ _ = Nothing
index 07a1dfb..359419c 100644 (file)
@@ -4,7 +4,6 @@
 \begin{code}
 module ExternalCore where
 
-
 data Module 
  = Module Mname [Tdef] [Vdefg]
 
@@ -51,21 +50,21 @@ data Alt
 type Vbind = (Var,Ty)
 type Tbind = (Tvar,Kind)
 
+-- Internally, we represent types and coercions separately; but for
+-- the purposes of external core (at least for now) it's still
+-- convenient to collapse them into a single type.
 data Ty 
   = Tvar Tvar
   | Tcon (Qual Tcon)
   | Tapp Ty Ty
   | Tforall Tbind Ty 
--- We distinguish primitive coercions
--- (represented in GHC by wired-in names), because
--- External Core treats them specially, so we have
--- to print them out with special syntax.
+-- We distinguish primitive coercions because External Core treats
+-- them specially, so we have to print them out with special syntax.
   | TransCoercion Ty Ty
   | SymCoercion Ty
   | UnsafeCoercion Ty Ty
   | InstCoercion Ty Ty
-  | LeftCoercion Ty
-  | RightCoercion Ty
+  | NthCoercion Int Ty
 
 data Kind 
   = Klifted
index f1d4273..b6bc7d4 100644 (file)
@@ -45,8 +45,7 @@ module MkCore (
 #include "HsVersions.h"
 
 import Id
-import IdInfo
-import Var      ( EvVar, mkWildCoVar, setTyVarUnique )
+import Var      ( EvVar, setTyVarUnique )
 
 import CoreSyn
 import CoreUtils        ( exprType, needsCaseBinding, bindNonRec )
@@ -58,8 +57,10 @@ import PrelNames
 
 import TcType          ( mkSigmaTy )
 import Type
+import Coercion
 import TysPrim
 import DataCon          ( DataCon, dataConWorkId )
+import IdInfo          ( vanillaIdInfo, setStrictnessInfo, setArityInfo )
 import Demand
 import Name
 import Outputable
@@ -102,6 +103,7 @@ mkCoreApp :: CoreExpr -> CoreExpr -> CoreExpr
 -- Check the invariant that the arg of an App is ok-for-speculation if unlifted
 -- See CoreSyn Note [CoreSyn let/app invariant]
 mkCoreApp fun (Type ty) = App fun (Type ty)
+mkCoreApp fun (Coercion co) = App fun (Coercion co)
 mkCoreApp fun arg       = ASSERT2( isFunTy fun_ty, ppr fun $$ ppr arg )
                           mk_val_app fun arg arg_ty res_ty
                       where
@@ -117,6 +119,7 @@ mkCoreApps orig_fun orig_args
   where
     go fun _      []               = fun
     go fun fun_ty (Type ty : args) = go (App fun (Type ty)) (applyTy fun_ty ty) args
+    go fun fun_ty (Coercion co : args) = go (App fun (Coercion co)) (applyCo fun_ty co) args
     go fun fun_ty (arg     : args) = ASSERT2( isFunTy fun_ty, ppr fun_ty $$ ppr orig_fun $$ ppr orig_args )
                                      go (mk_val_app fun arg arg_ty res_ty) res_ty args
                                    where
@@ -148,8 +151,7 @@ mk_val_app fun arg arg_ty res_ty
        -- fragmet of it as the fun part of a 'mk_val_app'.
 
 mkWildEvBinder :: PredType -> EvVar
-mkWildEvBinder pred@(EqPred {}) = mkWildCoVar     (mkPredTy pred)
-mkWildEvBinder pred             = mkWildValBinder (mkPredTy pred)
+mkWildEvBinder pred = mkWildValBinder (mkPredTy pred)
 
 -- | Make a /wildcard binder/. This is typically used when you need a binder 
 -- that you expect to use only at a *binding* site.  Do not use it at
index cb784e8..78df509 100644 (file)
@@ -13,6 +13,8 @@ import Module
 import CoreSyn
 import HscTypes        
 import TyCon
+-- import Class
+-- import TysPrim( eqPredPrimTyCon )
 import TypeRep
 import Type
 import PprExternalCore () -- Instances
@@ -78,10 +80,7 @@ collect_tdefs tcon tdefs
   where
     tdef | isNewTyCon tcon = 
                 C.Newtype (qtc tcon) 
-                  (case newTyConCo_maybe tcon of
-                     Just co -> qtc co
-                     Nothing       -> pprPanic ("MkExternalCore: newtype tcon\
-                                       should have a coercion: ") (ppr tcon))
+                  (qcc (newTyConCo tcon))
                   (map make_tbind tyvars) 
                   (make_ty (snd (newTyConRhs tcon)))
          | otherwise = 
@@ -94,6 +93,8 @@ collect_tdefs _ tdefs = tdefs
 qtc :: TyCon -> C.Qual C.Tcon
 qtc = make_con_qid . tyConName
 
+qcc :: CoAxiom -> C.Qual C.Tcon
+qcc = make_con_qid . co_ax_name
 
 make_cdef :: DataCon -> C.Cdef
 make_cdef dcon =  C.Constr dcon_name existentials tys
@@ -142,15 +143,16 @@ make_exp (Var v) = do
 make_exp (Lit (MachLabel s _ _)) = return $ C.Label (unpackFS s)
 make_exp (Lit l) = return $ C.Lit (make_lit l)
 make_exp (App e (Type t)) = make_exp e >>= (\ b -> return $ C.Appt b (make_ty t))
+make_exp (App _e (Coercion _co)) = error "make_exp (App _ (Coercion _))"    -- TODO
 make_exp (App e1 e2) = do
    rator <- make_exp e1
    rand <- make_exp e2
    return $ C.App rator rand
-make_exp (Lam v e) | isTyCoVar v = make_exp e >>= (\ b -> 
+make_exp (Lam v e) | isTyVar v = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Tb (make_tbind v)) b)
 make_exp (Lam v e) | otherwise = make_exp e >>= (\ b -> 
                                     return $ C.Lam (C.Vb (make_vbind v)) b)
-make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_ty co))
+make_exp (Cast e co) = make_exp e >>= (\ b -> return $ C.Cast b (make_co co))
 make_exp (Let b e) = do
   vd   <- make_vdef False b
   body <- make_exp e
@@ -170,7 +172,7 @@ make_alt (DataAlt dcon, vs, e) = do
            (map make_tbind tbs)
            (map make_vbind vbs)
           newE
-       where (tbs,vbs) = span isTyCoVar vs
+       where (tbs,vbs) = span isTyVar vs
 make_alt (LitAlt l,_,e)   = make_exp e >>= (return . (C.Alit (make_lit l)))
 make_alt (DEFAULT,[],e)   = make_exp e >>= (return . C.Adefault)
 -- This should never happen, as the DEFAULT alternative binds no variables,
@@ -229,29 +231,12 @@ make_ty' (TyConApp tc ts)          = make_tyConApp tc ts
 make_ty' (PredTy p)    = make_ty (predTypeRep p)
 
 make_tyConApp :: TyCon -> [Type] -> C.Ty
-make_tyConApp tc [t1, t2] | tc == transCoercionTyCon =
-  C.TransCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t]      | tc == symCoercionTyCon =
-  C.SymCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == unsafeCoercionTyCon =
-  C.UnsafeCoercion (make_ty t1) (make_ty t2)
-make_tyConApp tc [t]      | tc == leftCoercionTyCon =
-  C.LeftCoercion (make_ty t)
-make_tyConApp tc [t]      | tc == rightCoercionTyCon =
-  C.RightCoercion (make_ty t)
-make_tyConApp tc [t1, t2] | tc == instCoercionTyCon =
-  C.InstCoercion (make_ty t1) (make_ty t2)
--- this fails silently if we have an application
--- of a wired-in coercion tycon to the wrong number of args.
--- Not great...
 make_tyConApp tc ts =
   foldl C.Tapp (C.Tcon (qtc tc)) 
            (map make_ty ts)
 
-
 make_kind :: Kind -> C.Kind
-make_kind (PredTy p) | isEqPred p = C.Keq (make_ty t1) (make_ty t2)
-    where (t1, t2) = getEqPredTys p
+make_kind (PredTy (EqPred t1 t2)) = C.Keq (make_ty t1) (make_ty t2)
 make_kind (FunTy k1 k2)  = C.Karrow (make_kind k1) (make_kind k2)
 make_kind k
   | isLiftedTypeKind k   = C.Klifted
@@ -299,6 +284,25 @@ make_var_qid force_unqual = make_qid force_unqual True
 make_con_qid :: Name -> C.Qual C.Id
 make_con_qid = make_qid False False
 
+make_co :: Coercion -> C.Ty
+make_co (Refl ty)             = make_ty ty
+make_co (TyConAppCo tc cos)   = make_conAppCo (qtc tc) cos
+make_co (AppCo c1 c2)         = C.Tapp (make_co c1) (make_co c2)
+make_co (ForAllCo tv co)      = C.Tforall (make_tbind tv) (make_co co)
+make_co (CoVarCo cv)          = C.Tvar (make_var_id (coVarName cv))
+make_co (AxiomInstCo cc cos)  = make_conAppCo (qcc cc) cos
+make_co (UnsafeCo t1 t2)      = C.UnsafeCoercion (make_ty t1) (make_ty t2)
+make_co (SymCo co)            = C.SymCoercion (make_co co)
+make_co (TransCo c1 c2)       = C.TransCoercion (make_co c1) (make_co c2)
+make_co (NthCo d co)          = C.NthCoercion d (make_co co)
+make_co (InstCo co ty)        = C.InstCoercion (make_co co) (make_ty ty)
+
+-- Used for both tycon app coercions and axiom instantiations.
+make_conAppCo :: C.Qual C.Tcon -> [Coercion] -> C.Ty
+make_conAppCo con cos =
+  foldl C.Tapp (C.Tcon con) 
+           (map make_co cos)
+
 -------
 isALocal :: Name -> CoreM Bool
 isALocal vName = do
index 041b842..e9452dc 100644 (file)
@@ -106,7 +106,9 @@ ppr_expr :: OutputableBndr b => (SDoc -> SDoc) -> Expr b -> SDoc
        -- The function adds parens in context that need
        -- an atomic value (e.g. function args)
 
-ppr_expr add_par (Type ty)  = add_par (ptext (sLit "TYPE") <+> ppr ty) -- Wierd
+ppr_expr add_par (Type ty) = add_par (ptext (sLit "TYPE") <+> ppr ty)  -- Wierd
+
+ppr_expr add_par (Coercion co) = add_par (ptext (sLit "CO") <+> ppr co)
                   
 ppr_expr _       (Var name) = ppr name
 ppr_expr _       (Lit lit)  = ppr lit
@@ -255,8 +257,8 @@ pprArg :: OutputableBndr a => Expr a -> SDoc
 pprArg (Type ty) 
  | opt_SuppressTypeApplications        = empty
  | otherwise                   = ptext (sLit "@") <+> pprParendType ty
-
-pprArg expr      = pprParendExpr expr
+pprArg (Coercion co) = ptext (sLit "@~") <+> pprParendCo co
+pprArg expr          = pprParendExpr expr
 \end{code}
 
 Other printing bits-and-bobs used with the general @pprCoreBinding@
@@ -268,7 +270,7 @@ instance OutputableBndr Var where
 
 pprCoreBinder :: BindingSite -> Var -> SDoc
 pprCoreBinder LetBind binder
-  | isTyCoVar binder = pprKindedTyVarBndr binder
+  | isTyVar binder = pprKindedTyVarBndr binder
   | otherwise      = pprTypedBinder binder $$ 
                     ppIdInfo binder (idInfo binder)
 
@@ -279,7 +281,7 @@ pprCoreBinder bind_site bndr
 
 pprUntypedBinder :: Var -> SDoc
 pprUntypedBinder binder
-  | isTyCoVar binder = ptext (sLit "@") <+> ppr binder -- NB: don't print kind
+  | isTyVar binder = ptext (sLit "@") <+> ppr binder   -- NB: don't print kind
   | otherwise      = pprIdBndr binder
 
 pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
@@ -287,7 +289,7 @@ pprTypedLCBinder :: BindingSite -> Bool -> Var -> SDoc
 pprTypedLCBinder bind_site debug_on var
   | not debug_on && isDeadBinder var    = char '_'
   | not debug_on, CaseBind <- bind_site = pprUntypedBinder var  -- No parens, no kind info
-  | isTyCoVar var                         = parens (pprKindedTyVarBndr var)
+  | isTyVar var                         = parens (pprKindedTyVarBndr var)
   | otherwise = parens (hang (pprIdBndr var) 
                            2 (vcat [ dcolon <+> pprType (idType var), pp_unf]))
               where
@@ -298,7 +300,7 @@ pprTypedLCBinder bind_site debug_on var
 pprTypedBinder :: Var -> SDoc
 -- Print binder with a type or kind signature (not paren'd)
 pprTypedBinder binder
-  | isTyCoVar binder           = pprKindedTyVarBndr binder
+  | isTyVar binder             = pprKindedTyVarBndr binder
   | opt_SuppressTypeSignatures = empty
   | otherwise                  = hang (pprIdBndr binder) 2 (dcolon <+> pprType (idType binder))
 
index 3c4b25e..5303b0d 100644 (file)
@@ -106,10 +106,8 @@ pty (SymCoercion t) =
   sep [text "%sym", paty t]
 pty (UnsafeCoercion t1 t2) =
   sep [text "%unsafe", paty t1, paty t2]
-pty (LeftCoercion t) =
-  sep [text "%left", paty t]
-pty (RightCoercion t) =
-  sep [text "%right", paty t]
+pty (NthCoercion n t) =
+  sep [text "%nth", int n, paty t]
 pty (InstCoercion t1 t2) =
   sep [text "%inst", paty t1, paty t2]
 pty t = pbty t
index c5e0118..47fbf2e 100644 (file)
@@ -27,7 +27,6 @@ import TysWiredIn
 import PrelNames
 import TyCon
 import Type
-import Unify( dataConCannotMatch )
 import SrcLoc
 import UniqSet
 import Util
index 37a3cf9..7b008e9 100644 (file)
@@ -378,6 +378,8 @@ switching off EnableRewriteRules.  See DsExpr.dsExplicitList.
 
 That keeps the desugaring of list comprehensions simple too.
 
+
+
 Nor do we want to warn of conversion identities on the LHS;
 the rule is precisly to optimise them:
   {-# RULES "fromRational/id" fromRational = id :: Rational -> Rational #-}
index 815c0d1..65cb815 100644 (file)
@@ -11,7 +11,7 @@ lower levels it is preserved with @let@/@letrec@s).
 
 \begin{code}
 module DsBinds ( dsTopLHsBinds, dsLHsBinds, decomposeRuleLhs, dsSpec,
-                 dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds,
+                dsHsWrapper, dsTcEvBinds, dsEvBinds, wrapDsEvBinds, 
                 DsEvBind(..), AutoScc(..)
   ) where
 
@@ -36,6 +36,7 @@ import Digraph
 
 import TcType
 import Type
+import Coercion
 import TysPrim  ( anyTypeOfKind )
 import CostCentre
 import Module
@@ -230,8 +231,8 @@ dsEvBinds bs = return (map dsEvGroup sccs)
 
     free_vars_of :: EvTerm -> [EvVar]
     free_vars_of (EvId v)           = [v]
-    free_vars_of (EvCast v co)      = v : varSetElems (tyVarsOfType co)
-    free_vars_of (EvCoercion co)    = varSetElems (tyVarsOfType co)
+    free_vars_of (EvCast v co)      = v : varSetElems (tyCoVarsOfCo co)
+    free_vars_of (EvCoercion co)    = varSetElems (tyCoVarsOfCo co)
     free_vars_of (EvDFunApp _ _ vs) = vs
     free_vars_of (EvSuperClass d _) = [d]
 
@@ -247,7 +248,7 @@ dsEvGroup (AcyclicSCC (EvBind co_var (EvSuperClass dict n)))
     (arg_tys, _) = splitFunTys rho
     bndrs = ex_tvs ++ map mk_wild_pred (theta `zip` [0..])
                    ++ map mkWildValBinder arg_tys
-    mk_wild_pred (p, i) | i==n      = ASSERT( p `tcEqPred` (coVarPred co_var)) 
+    mk_wild_pred (p, i) | i==n      = ASSERT( p `eqPred` (coVarPred co_var)) 
                                       co_var
                         | otherwise = mkWildEvBinder p
     
@@ -263,7 +264,7 @@ dsEvTerm :: EvTerm -> CoreExpr
 dsEvTerm (EvId v)                = Var v
 dsEvTerm (EvCast v co)           = Cast (Var v) co
 dsEvTerm (EvDFunApp df tys vars) = Var df `mkTyApps` tys `mkVarApps` vars
-dsEvTerm (EvCoercion co)         = Type co
+dsEvTerm (EvCoercion co)         = Coercion co
 dsEvTerm (EvSuperClass d n)
   = ASSERT( isClassPred (classSCTheta cls !! n) )
            -- We can only select *dictionary* superclasses
@@ -597,17 +598,13 @@ decomposeRuleLhs bndrs lhs
 
    bad_shape_msg = hang (ptext (sLit "RULE left-hand side too complicated to desugar"))
                       2 (ppr opt_lhs)
-   dead_msg bndr = hang (ptext (sLit "Forall'd") <+> pp_bndr bndr
-                                <+> ptext (sLit "is not bound in RULE lhs"))
+   dead_msg bndr = hang (sep [ ptext (sLit "Forall'd") <+> pp_bndr bndr
+                            , ptext (sLit "is not bound in RULE lhs")])
                       2 (ppr opt_lhs)
    pp_bndr bndr
-    | isTyVar bndr = ptext (sLit "type variable") <+> ppr bndr
-    | isCoVar bndr = ptext (sLit "coercion variable") <+> ppr bndr
-    | isDictId bndr = ptext (sLit "constraint") <+> ppr (get_pred bndr)
-    | otherwise     = ptext (sLit "variable") <+> ppr bndr
-
-   get_pred b = ASSERT( isId b ) expectJust "decomposeRuleLhs" 
-                                 (tcSplitPredTy_maybe (idType b))
+    | isTyVar bndr  = ptext (sLit "type variable") <+> quotes (ppr bndr)
+    | isEvVar bndr  = ptext (sLit "constraint") <+> quotes (ppr (evVarPred bndr))
+    | otherwise     = ptext (sLit "variable") <+> quotes (ppr bndr)
 \end{code}
 
 Note [Simplifying the left-hand side of a RULE]
@@ -634,7 +631,6 @@ otherwise we don't match when given an argument like
 NB: tcSimplifyRuleLhs is very careful not to generate complicated
     dictionary expressions that we might have to match
 
-
 Note [Matching seqId]
 ~~~~~~~~~~~~~~~~~~~
 The desugarer turns (seq e r) into (case e of _ -> r), via a special-case hack
index f46d99e..58ebc26 100644 (file)
@@ -273,7 +273,7 @@ boxResult result_ty
        ; let io_data_con = head (tyConDataCons io_tycon)
              toIOCon     = dataConWrapId io_data_con
 
-             wrap the_call = mkCoerceI (mkSymCoI co) $
+             wrap the_call = mkCoerce (mkSymCo co) $
                              mkApps (Var toIOCon)
                                     [ Type io_res_ty, 
                                       Lam state_id $
@@ -372,7 +372,7 @@ resultWrapper result_ty
   -- Recursive newtypes
   | Just (rep_ty, co) <- splitNewTypeRepCo_maybe result_ty
   = do (maybe_ty, wrapper) <- resultWrapper rep_ty
-       return (maybe_ty, \e -> mkCoerce (mkSymCoercion co) (wrapper e))
+       return (maybe_ty, \e -> mkCoerce (mkSymCo co) (wrapper e))
 
   -- The type might contain foralls (eg. for dummy type arguments,
   -- referring to 'Ptr a' is legal).
index 4088e44..e33b113 100644 (file)
@@ -49,8 +49,8 @@ import DynFlags
 import StaticFlags
 import CostCentre
 import Id
-import Var
 import VarSet
+import VarEnv
 import DataCon
 import TysWiredIn
 import BasicTypes
@@ -513,12 +513,12 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
 
     mk_alt upd_fld_env con
       = do { let (univ_tvs, ex_tvs, eq_spec, 
-                 eq_theta, dict_theta, arg_tys, _) = dataConFullSig con
+                 theta, arg_tys, _) = dataConFullSig con
                 subst = mkTopTvSubst (univ_tvs `zip` in_inst_tys)
 
                -- I'm not bothering to clone the ex_tvs
           ; eqs_vars   <- mapM newPredVarDs (substTheta subst (eqSpecPreds eq_spec))
-          ; theta_vars <- mapM newPredVarDs (substTheta subst (eq_theta ++ dict_theta))
+          ; theta_vars <- mapM newPredVarDs (substTheta subst theta)
           ; arg_ids    <- newSysLocalsDs (substTys subst arg_tys)
           ; let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg
                                         (dataConFieldLabels con) arg_ids
@@ -529,21 +529,21 @@ dsExpr expr@(RecordUpd record_expr (HsRecFields { rec_flds = fields })
                 wrap = mkWpEvVarApps theta_vars          `WpCompose` 
                        mkWpTyApps    (mkTyVarTys ex_tvs) `WpCompose`
                        mkWpTyApps [ty | (tv, ty) <- univ_tvs `zip` out_inst_tys
-                                      , isNothing (lookupTyVar wrap_subst tv) ]
+                                      , not (tv `elemVarEnv` wrap_subst) ]
                 rhs = foldl (\a b -> nlHsApp a b) inst_con val_args
 
                        -- Tediously wrap the application in a cast
                        -- Note [Update for GADTs]
                 wrapped_rhs | null eq_spec = rhs
                             | otherwise    = mkLHsWrap (WpCast wrap_co) rhs
-                wrap_co = mkTyConApp tycon [ lookup tv ty 
-                                           | (tv,ty) <- univ_tvs `zip` out_inst_tys]
-                lookup univ_tv ty = case lookupTyVar wrap_subst univ_tv of
-                                       Just ty' -> ty'
-                                       Nothing  -> ty
-                wrap_subst = mkTopTvSubst [ (tv,mkSymCoercion (mkTyVarTy co_var))
-                                          | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
-                
+                wrap_co = mkTyConAppCo tycon [ lookup tv ty
+                                             | (tv,ty) <- univ_tvs `zip` out_inst_tys]
+                lookup univ_tv ty = case lookupVarEnv wrap_subst univ_tv of
+                                       Just co' -> co'
+                                       Nothing  -> mkReflCo ty
+                wrap_subst = mkVarEnv [ (tv, mkSymCo (mkCoVarCo co_var))
+                                      | ((tv,_),co_var) <- eq_spec `zip` eqs_vars ]
+
                 pat = noLoc $ ConPatOut { pat_con = noLoc con, pat_tvs = ex_tvs
                                         , pat_dicts = eqs_vars ++ theta_vars
                                         , pat_binds = emptyTcEvBinds
@@ -583,7 +583,7 @@ dsExpr (HsTick ix vars e) = do
 
 dsExpr (HsBinTick ixT ixF e) = do
   e2 <- dsLExpr e
-  do { ASSERT(exprType e2 `coreEqType` boolTy)
+  do { ASSERT(exprType e2 `eqType` boolTy)
        mkBinaryTickBox ixT ixF e2
      }
 \end{code}
@@ -787,7 +787,7 @@ warnAboutIdentities (Var v) co_fn
   | idName v `elem` conversionNames
   , let fun_ty = exprType (co_fn (Var v))
   , Just (arg_ty, res_ty) <- splitFunTy_maybe fun_ty
-  , arg_ty `tcEqType` res_ty  -- So we are converting  ty -> ty
+  , arg_ty `eqType` res_ty  -- So we are converting  ty -> ty
   = warnDs (vcat [ ptext (sLit "Call of") <+> ppr v <+> dcolon <+> ppr fun_ty
                  , nest 2 $ ptext (sLit "can probably be omitted")
                  , parens (ptext (sLit "Use -fno-warn-identities to suppress this messsage)"))
@@ -822,7 +822,7 @@ warnDiscardedDoBindings rhs rhs_ty
          -- but only if we didn't already warn due to Opt_WarnUnusedDoBind
     do { warn_wrong <- doptDs Opt_WarnWrongDoBind
        ; case tcSplitAppTy_maybe elt_ty of
-           Just (elt_m_ty, _) | warn_wrong, m_ty `tcEqType` elt_m_ty
+           Just (elt_m_ty, _) | warn_wrong, m_ty `eqType` elt_m_ty
                               -> warnDs (wrongMonadBind rhs elt_ty)
            _ -> return () } }
 
index 4d0a148..b391b8f 100644 (file)
@@ -28,7 +28,6 @@ import Type
 import TyCon
 import Coercion
 import TcType
-import Var
 
 import CmmExpr
 import CmmUtils
@@ -140,7 +139,7 @@ dsCImport id (CLabel cid) cconv _ = do
                  IsFunction
              _ -> IsData
    (resTy, foRhs) <- resultWrapper ty
-   ASSERT(fromJust resTy `coreEqType` addrPrimTy)    -- typechecker ensures this
+   ASSERT(fromJust resTy `eqType` addrPrimTy)    -- typechecker ensures this
     let
         rhs = foRhs (Lit (MachLabel cid stdcall_info fod))
         stdcall_info = fun_type_arg_stdcall_info cconv ty
@@ -382,9 +381,9 @@ dsFExportDynamic id cconv = do
     ccall_adj <- dsCCall adjustor adj_args PlayRisky (mkTyConApp io_tc [res_ty])
         -- PlayRisky: the adjustor doesn't allocate in the Haskell heap or do a callback
 
-    let io_app = mkLams tvs                $
-                 Lam cback                 $
-                 mkCoerceI (mkSymCoI co)   $
+    let io_app = mkLams tvs                  $
+                 Lam cback                   $
+                 mkCoerce (mkSymCo co) $
                  mkApps (Var bindIOId)
                         [ Type stable_ptr_ty
                         , Type res_ty       
@@ -483,7 +482,7 @@ mkFExportCBits c_nm maybe_target arg_htys res_hty is_IO_res_ty cc
         typeCmmType (mkStablePtrPrimTy alphaTy))
 
   -- stuff to do with the return type of the C function
-  res_hty_is_unit = res_hty `coreEqType` unitTy        -- Look through any newtypes
+  res_hty_is_unit = res_hty `eqType` unitTy    -- Look through any newtypes
 
   cResType | res_hty_is_unit = text "void"
           | otherwise       = showStgType res_hty
@@ -675,7 +674,7 @@ getPrimTyOf ty
 -- e.g. 'W' is a signed 32-bit integer.
 primTyDescChar :: Type -> Char
 primTyDescChar ty
- | ty `coreEqType` unitTy = 'v'
+ | ty `eqType` unitTy = 'v'
  | otherwise
  = case typePrimRep (getPrimTyOf ty) of
      IntRep     -> signed_word
index 3a97687..8b5c0a9 100644 (file)
@@ -53,7 +53,6 @@ import CoreUtils
 import MkCore
 import MkId
 import Id
-import Var
 import Name
 import Literal
 import TyCon
@@ -75,7 +74,6 @@ import StaticFlags
 \end{code}
 
 
-
 %************************************************************************
 %*                                                                     *
                Rebindable syntax
@@ -256,10 +254,9 @@ wrapBinds [] e = e
 wrapBinds ((new,old):prs) e = wrapBind new old (wrapBinds prs e)
 
 wrapBind :: Var -> Var -> CoreExpr -> CoreExpr
-wrapBind new old body  -- Can deal with term variables *or* type variables
-  | new==old    = body
-  | isTyCoVar new = Let (mkTyBind new (mkTyVarTy old)) body
-  | otherwise   = Let (NonRec new (Var old))         body
+wrapBind new old body  -- NB: this function must deal with term
+  | new==old    = body -- variables, type variables or coercion variables
+  | otherwise   = Let (NonRec new (varToCoreExpr old)) body
 
 seqVar :: Var -> CoreExpr -> CoreExpr
 seqVar var body = Case (Var var) var (exprType body)
@@ -299,10 +296,11 @@ mkCoPrimCaseMatchResult var ty match_alts
                                                   return (LitAlt lit, [], body)
 
 
-mkCoAlgCaseMatchResult :: Id                                   -- Scrutinee
-                    -> Type                                     -- Type of exp
-                   -> [(DataCon, [CoreBndr], MatchResult)]     -- Alternatives
-                   -> MatchResult
+mkCoAlgCaseMatchResult 
+  :: Id                                           -- Scrutinee
+  -> Type                                  -- Type of exp
+  -> [(DataCon, [CoreBndr], MatchResult)]  -- Alternatives (bndrs *include* tyvars, dicts)
+  -> MatchResult
 mkCoAlgCaseMatchResult var ty match_alts 
   | isNewTyCon tycon           -- Newtype case; use a let
   = ASSERT( null (tail match_alts) && null (tail arg_ids1) )
@@ -605,7 +603,7 @@ mkSelectorBinds pat val_expr
         return (bndr_var, rhs_expr)
       where
         error_expr = mkCoerce co (Var err_var)
-        co         = mkUnsafeCoercion (exprType (Var err_var)) (idType bndr_var)
+        co         = mkUnsafeCo (exprType (Var err_var)) (idType bndr_var)
 
     is_simple_lpat p = is_simple_pat (unLoc p)
 
index 15c5a55..1a044d3 100644 (file)
@@ -29,6 +29,7 @@ import DataCon
 import MatchCon
 import MatchLit
 import Type
+import Coercion
 import TysWiredIn
 import ListSetOps
 import SrcLoc
@@ -825,7 +826,7 @@ sameGroup (PgCon _)  (PgCon _)  = True              -- One case expression
 sameGroup (PgLit _)  (PgLit _)  = True         -- One case expression
 sameGroup (PgN l1)   (PgN l2)   = l1==l2       -- Order is significant
 sameGroup (PgNpK l1) (PgNpK l2) = l1==l2       -- See Note [Grouping overloaded literal patterns]
-sameGroup (PgCo        t1)  (PgCo t2)  = t1 `coreEqType` t2
+sameGroup (PgCo        t1)  (PgCo t2)  = t1 `eqType` t2
        -- CoPats are in the same goup only if the type of the
        -- enclosed pattern is the same. The patterns outside the CoPat
        -- always have the same type, so this boils down to saying that
@@ -873,7 +874,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
         -- which resolve the overloading (e.g., fromInteger 1),
         -- because these expressions get written as a bunch of different variables
         -- (presumably to improve sharing)
-        tcEqType (overLitType l) (overLitType l') && l == l'
+        eqType (overLitType l) (overLitType l') && l == l'
     exp (HsApp e1 e2) (HsApp e1' e2') = lexp e1 e1' && lexp e2 e2'
     -- the fixities have been straightened out by now, so it's safe
     -- to ignore them?
@@ -897,7 +898,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
 
     ---------
     tup_arg (Present e1) (Present e2) = lexp e1 e2
-    tup_arg (Missing t1) (Missing t2) = tcEqType t1 t2
+    tup_arg (Missing t1) (Missing t2) = eqType t1 t2
     tup_arg _ _ = False
 
     ---------
@@ -910,9 +911,9 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     --        equating different ways of writing a coercion)
     wrap WpHole WpHole = True
     wrap (WpCompose w1 w2) (WpCompose w1' w2') = wrap w1 w1' && wrap w2 w2'
-    wrap (WpCast c)  (WpCast c')     = tcEqType c c'
+    wrap (WpCast c)  (WpCast c')     = coreEqCoercion c c'
     wrap (WpEvApp et1) (WpEvApp et2) = ev_term et1 et2
-    wrap (WpTyApp t) (WpTyApp t')    = tcEqType t t'
+    wrap (WpTyApp t) (WpTyApp t')    = eqType t t'
     -- Enhancement: could implement equality for more wrappers
     --   if it seems useful (lams and lets)
     wrap _ _ = False
@@ -920,7 +921,7 @@ viewLExprEq (e1,_) (e2,_) = lexp e1 e2
     ---------
     ev_term :: EvTerm -> EvTerm -> Bool
     ev_term (EvId a)       (EvId b)       = a==b
-    ev_term (EvCoercion a) (EvCoercion b) = tcEqType a b
+    ev_term (EvCoercion a) (EvCoercion b) = coreEqCoercion a b
     ev_term _ _ = False        
 
     ---------
@@ -959,3 +960,4 @@ If the first arg matches '1' but the second does not match 'True', we
 cannot jump to the third equation!  Because the same argument might
 match '2'!
 Hence we don't regard 1 and 2, or (n+1) and (n+2), as part of the same group.
+
index 03fa325..d84b901 100644 (file)
@@ -28,7 +28,6 @@ import DsUtils
 import Util    ( all2, takeList, zipEqual )
 import ListSetOps ( runs )
 import Id
-import Var      ( Var )
 import NameEnv
 import SrcLoc
 import Outputable
index 18a06b0..f70a1b3 100644 (file)
@@ -416,6 +416,7 @@ Library
         Generics
         InstEnv
         TyCon
+        Kind
         Type
         TypeRep
         Unify
@@ -442,6 +443,7 @@ Library
         MonadUtils
         OrdList
         Outputable
+        Pair
         Panic
         Pretty
         Serialized
index b888747..426f4f2 100644 (file)
@@ -31,7 +31,6 @@ import Type
 import DataCon
 import TyCon
 import Util
-import Var
 import VarSet
 import TysPrim
 import DynFlags
@@ -249,7 +248,7 @@ schemeR fvs (nm, rhs)
 {-
    | trace (showSDoc (
               (char ' '
-               $$ (ppr.filter (not.isTyCoVar).varSetElems.fst) rhs
+               $$ (ppr.filter (not.isTyVar).varSetElems.fst) rhs
                $$ pprCoreExpr (deAnnotate rhs)
                $$ char ' '
               ))) False
@@ -833,8 +832,8 @@ doCase d s p (_,scrut) bndr alts is_unboxed_tuple
              MASSERT(isAlgCase)
              rhs_code <- schemeE (d_alts+size) s p' rhs
              return (my_discr alt, unitOL (UNPACK size) `appOL` rhs_code)
-           where
-             real_bndrs = filter (not.isTyCoVar) bndrs
+          where
+            real_bndrs = filterOut isTyVar bndrs
 
         my_discr (DEFAULT, _, _) = NoDiscr {-shouldn't really happen-}
         my_discr (DataAlt dc, _, _)
@@ -1197,6 +1196,9 @@ pushAtom d p e
    | Just e' <- bcView e
    = pushAtom d p e'
 
+pushAtom _ _ (AnnCoercion {})  -- Coercions are zero-width things, 
+   = return (nilOL, 0)         -- treated just like a variable VoidArg
+
 pushAtom d p (AnnVar v)
    | idCgRep v == VoidArg
    = return (nilOL, 0)
@@ -1270,9 +1272,6 @@ pushAtom _ _ (AnnLit lit)
                 -- Get the addr on the stack, untaggedly
                 return (unitOL (PUSH_UBX (Right addr) 1), 1)
 
-pushAtom d p (AnnCast e _)
-   = pushAtom d p (snd e)
-
 pushAtom _ _ expr
    = pprPanic "ByteCodeGen.pushAtom"
               (pprCoreExpr (deAnnotate (undefined, expr)))
@@ -1454,21 +1453,23 @@ bcView :: AnnExpr' Var ann -> Maybe (AnnExpr' Var ann)
 --  d) notes
 -- Type lambdas *can* occur in random expressions,
 -- whereas value lambdas cannot; that is why they are nuked here
-bcView (AnnNote _ (_,e))               = Just e
-bcView (AnnCast (_,e) _)               = Just e
-bcView (AnnLam v (_,e)) | isTyCoVar v  = Just e
-bcView (AnnApp (_,e) (_, AnnType _))   = Just e
-bcView _                               = Nothing
+bcView (AnnNote _ (_,e))            = Just e
+bcView (AnnCast (_,e) _)            = Just e
+bcView (AnnLam v (_,e)) | isTyVar v  = Just e
+bcView (AnnApp (_,e) (_, AnnType _)) = Just e
+bcView _                             = Nothing
 
 isVoidArgAtom :: AnnExpr' Var ann -> Bool
 isVoidArgAtom e | Just e' <- bcView e = isVoidArgAtom e'
 isVoidArgAtom (AnnVar v)              = typePrimRep (idType v) == VoidRep
-isVoidArgAtom _                       = False
+isVoidArgAtom (AnnCoercion {})        = True
+isVoidArgAtom _                      = False
 
 atomPrimRep :: AnnExpr' Id ann -> PrimRep
 atomPrimRep e | Just e' <- bcView e = atomPrimRep e'
-atomPrimRep (AnnVar v)              = typePrimRep (idType v)
-atomPrimRep (AnnLit l)              = typePrimRep (literalType l)
+atomPrimRep (AnnVar v)             = typePrimRep (idType v)
+atomPrimRep (AnnLit l)             = typePrimRep (literalType l)
+atomPrimRep (AnnCoercion {})        = VoidRep
 atomPrimRep other = pprPanic "atomPrimRep" (ppr (deAnnotate (undefined,other)))
 
 atomRep :: AnnExpr' Id ann -> CgRep
index b4068a7..b6c97c3 100644 (file)
@@ -45,22 +45,19 @@ import TyCon
 import Name
 import VarEnv
 import Util
-import ListSetOps
 import VarSet
 import TysPrim
 import PrelNames
 import TysWiredIn
 import DynFlags
-import Outputable
+import Outputable as Ppr
 import FastString
--- import Panic
-
 import Constants        ( wORD_SIZE )
-
 import GHC.Arr          ( Array(..) )
 import GHC.Exts
 import GHC.IO ( IO(..) )
 
+import StaticFlags( opt_PprStyle_Debug )
 import Control.Monad
 import Data.Maybe
 import Data.Array.Base
@@ -186,7 +183,7 @@ getClosureData a =
                elems = fromIntegral (BCI.ptrs itbl)
                ptrsList = Array 0 (elems - 1) elems ptrs
                nptrs_data = [W# (indexWordArray# nptrs i)
-                              | I# i <- [0.. fromIntegral (BCI.nptrs itbl)] ]
+                              | I# i <- [0.. fromIntegral (BCI.nptrs itbl)-1] ]
            ASSERT(elems >= 0) return ()
            ptrsList `seq` 
             return (Closure tipe (Ptr iptr) itbl ptrsList nptrs_data)
@@ -346,10 +343,17 @@ ppr_termM y p Term{dc=Right dc, subTerms=tt}
   = parens (ppr_term1 True t1 <+> ppr dc <+> ppr_term1 True ppr t2) 
     <+> hsep (map (ppr_term1 True) tt) 
 -} -- TODO Printing infix constructors properly
-  | null tt   = return$ ppr dc
-  | otherwise = do
-         tt_docs <- mapM (y app_prec) tt
-         return$ cparen (p >= app_prec) (ppr dc <+> pprDeeperList fsep tt_docs)
+  | null sub_terms_to_show
+  = return (ppr dc)
+  | otherwise 
+  = do { tt_docs <- mapM (y app_prec) sub_terms_to_show
+       ; return $ cparen (p >= app_prec) $
+         sep [ppr dc, nest 2 (pprDeeperList fsep tt_docs)] }
+  where
+    sub_terms_to_show  -- Don't show the dictionary arguments to 
+                       -- constructors unless -dppr-debug is on
+      | opt_PprStyle_Debug = tt
+      | otherwise = dropList (dataConTheta dc) tt
 
 ppr_termM y p t@NewtypeWrap{} = pprNewtypeWrap y p t
 ppr_termM y p RefWrap{wrapped_term=t}  = do
@@ -414,55 +418,70 @@ cPprTerm printers_ = go 0 where
   firstJustM [] = return Nothing
 
 -- Default set of custom printers. Note that the recursion knot is explicit
-cPprTermBase :: Monad m => CustomTermPrinter m
+cPprTermBase :: forall m. Monad m => CustomTermPrinter m
 cPprTermBase y =
   [ ifTerm (isTupleTy.ty) (\_p -> liftM (parens . hcat . punctuate comma) 
                                       . mapM (y (-1))
                                       . subTerms)
   , ifTerm (\t -> isTyCon listTyCon (ty t) && subTerms t `lengthIs` 2)
-           (\ p t -> doList p t)
-  , ifTerm (isTyCon intTyCon    . ty) (coerceShow$ \(a::Int)->a)
-  , ifTerm (isTyCon charTyCon   . ty) (coerceShow$ \(a::Char)->a)
-  , ifTerm (isTyCon floatTyCon  . ty) (coerceShow$ \(a::Float)->a)
-  , ifTerm (isTyCon doubleTyCon . ty) (coerceShow$ \(a::Double)->a)
-  , ifTerm (isIntegerTy         . ty) (coerceShow$ \(a::Integer)->a)
+           ppr_list
+  , ifTerm (isTyCon intTyCon    . ty) ppr_int
+  , ifTerm (isTyCon charTyCon   . ty) ppr_char
+  , ifTerm (isTyCon floatTyCon  . ty) ppr_float
+  , ifTerm (isTyCon doubleTyCon . ty) ppr_double
+  , ifTerm (isIntegerTy         . ty) ppr_integer
   ]
-     where ifTerm pred f prec t@Term{}
-               | pred t    = Just `liftM` f prec t
-           ifTerm _ _ _ _  = return Nothing
-
-           isTupleTy ty    = fromMaybe False $ do 
-             (tc,_) <- tcSplitTyConApp_maybe ty 
-             return (isBoxedTupleTyCon tc)
-
-           isTyCon a_tc ty = fromMaybe False $ do 
-             (tc,_) <- tcSplitTyConApp_maybe ty
-             return (a_tc == tc)
-
-           isIntegerTy ty = fromMaybe False $ do
-             (tc,_) <- tcSplitTyConApp_maybe ty
-             return (tyConName tc == integerTyConName)
-
-           coerceShow f _p = return . text . show . f . unsafeCoerce# . val
-
-           --Note pprinting of list terms is not lazy
-           doList p (Term{subTerms=[h,t]}) = do
-               let elems      = h : getListTerms t
-                   isConsLast = not(termType(last elems) `coreEqType` termType h)
-               print_elems <- mapM (y cons_prec) elems
-               return$ if isConsLast
-                     then cparen (p >= cons_prec) 
-                        . pprDeeperList fsep 
-                        . punctuate (space<>colon)
-                        $ print_elems
-                     else brackets (pprDeeperList fcat$
-                                         punctuate comma print_elems)
-
-                where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
-                      getListTerms Term{subTerms=[]}    = []
-                      getListTerms t@Suspension{}       = [t]
-                      getListTerms t = pprPanic "getListTerms" (ppr t)
-           doList _ _ = panic "doList"
+ where 
+   ifTerm :: (Term -> Bool)
+          -> (Precedence -> Term -> m SDoc)
+          -> Precedence -> Term -> m (Maybe SDoc)
+   ifTerm pred f prec t@Term{}
+       | pred t    = Just `liftM` f prec t
+   ifTerm _ _ _ _  = return Nothing
+
+   isTupleTy ty    = fromMaybe False $ do 
+     (tc,_) <- tcSplitTyConApp_maybe ty 
+     return (isBoxedTupleTyCon tc)
+
+   isTyCon a_tc ty = fromMaybe False $ do 
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (a_tc == tc)
+
+   isIntegerTy ty = fromMaybe False $ do
+     (tc,_) <- tcSplitTyConApp_maybe ty
+     return (tyConName tc == integerTyConName)
+
+   ppr_int, ppr_char, ppr_float, ppr_double, ppr_integer 
+      :: Precedence -> Term -> m SDoc
+   ppr_int     _ v = return (Ppr.int     (unsafeCoerce# (val v)))
+   ppr_char    _ v = return (Ppr.char '\'' <> Ppr.char (unsafeCoerce# (val v)) <> Ppr.char '\'')
+   ppr_float   _ v = return (Ppr.float   (unsafeCoerce# (val v)))
+   ppr_double  _ v = return (Ppr.double  (unsafeCoerce# (val v)))
+   ppr_integer _ v = return (Ppr.integer (unsafeCoerce# (val v)))
+
+   --Note pprinting of list terms is not lazy
+   ppr_list :: Precedence -> Term -> m SDoc
+   ppr_list p (Term{subTerms=[h,t]}) = do
+       let elems      = h : getListTerms t
+           isConsLast = not(termType(last elems) `eqType` termType h)
+          is_string  = all (isCharTy . ty) elems
+
+       print_elems <- mapM (y cons_prec) elems
+       if is_string
+        then return (Ppr.doubleQuotes (Ppr.text (unsafeCoerce# (map val elems))))
+        else if isConsLast
+        then return $ cparen (p >= cons_prec) 
+                    $ pprDeeperList fsep 
+                    $ punctuate (space<>colon) print_elems
+        else return $ brackets 
+                    $ pprDeeperList fcat
+                    $ punctuate comma print_elems
+
+        where getListTerms Term{subTerms=[h,t]} = h : getListTerms t
+              getListTerms Term{subTerms=[]}    = []
+              getListTerms t@Suspension{}       = [t]
+              getListTerms t = pprPanic "getListTerms" (ppr t)
+   ppr_list _ _ = panic "doList"
 
 
 repPrim :: TyCon -> [Word] -> String
@@ -566,6 +585,11 @@ liftTcM = id
 newVar :: Kind -> TR TcType
 newVar = liftTcM . newFlexiTyVarTy
 
+instTyVars :: [TyVar] -> TR ([TcTyVar], [TcType], TvSubst)
+-- Instantiate fresh mutable type variables from some TyVars
+-- This function preserves the print-name, which helps error messages
+instTyVars = liftTcM . tcInstTyVars
+
 type RttiInstantiation = [(TcTyVar, TyVar)]
    -- Associates the typechecker-world meta type variables 
    -- (which are mutable and may be refined), to their 
@@ -658,7 +682,10 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
             text "Type obtained: " <> ppr (termType term))
    return term
     where 
+
   go :: Int -> Type -> Type -> HValue -> TcM Term
+   -- [SPJ May 11] I don't understand the difference between my_ty and old_ty
+
   go max_depth _ _ _ | seq max_depth False = undefined
   go 0 my_ty _old_ty a = do
     traceTR (text "Gave up reconstructing a term after" <>
@@ -704,7 +731,7 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
         traceTR (text "entering a constructor " <>
                       if monomorphic
                         then parens (text "already monomorphic: " <> ppr my_ty)
-                        else Outputable.empty)
+                        else Ppr.empty)
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
         case mb_dc of
@@ -713,59 +740,34 @@ cvObtainTerm hsc_env max_depth force old_ty hval = runTR hsc_env $ do
                         -- In such case, we return a best approximation:
                         --  ignore the unpointed args, and recover the pointeds
                         -- This preserves laziness, and should be safe.
+                      traceTR (text "Nothing" <+> ppr dcname)
                        let tag = showSDoc (ppr dcname)
                        vars     <- replicateM (length$ elems$ ptrs clos) 
-                                              (newVar (liftedTypeKind))
+                                              (newVar liftedTypeKind)
                        subTerms <- sequence [appArr (go (pred max_depth) tv tv) (ptrs clos) i 
                                               | (i, tv) <- zip [0..] vars]
                        return (Term my_ty (Left ('<' : tag ++ ">")) a subTerms)
           Just dc -> do
-            let subTtypes  = matchSubTypes dc old_ty
-            subTermTvs    <- mapMif (not . isMonomorphic)
-                                    (\t -> newVar (typeKind t))
-                                    subTtypes
-            let (subTermsP, subTermsNP) = partition (\(ty,_) -> isLifted ty
-                                                             || isRefType ty)
-                                                    (zip subTtypes subTermTvs)
-                (subTtypesP,   subTermTvsP ) = unzip subTermsP
-                (subTtypesNP, _subTermTvsNP) = unzip subTermsNP
-
-            -- When we already have all the information, avoid solving
-            -- unnecessary constraints. Propagation of type information
-            -- to subterms is already being done via matching.
-            when (not monomorphic) $ do
-               let myType = mkFunTys subTermTvs my_ty
-               (signatureType,_) <- instScheme (mydataConType dc)
-            -- It is vital for newtype reconstruction that the unification step
-            -- is done right here, _before_ the subterms are RTTI reconstructed
-               addConstraint myType signatureType
+            traceTR (text "Just" <+> ppr dc)
+            subTtypes <- getDataConArgTys dc my_ty
+            let (subTtypesP, subTtypesNP) = partition isPtrType subTtypes
             subTermsP <- sequence
-                  [ appArr (go (pred max_depth) tv t) (ptrs clos) i
-                   | (i,tv,t) <- zip3 [0..] subTermTvsP subTtypesP]
+                  [ appArr (go (pred max_depth) ty ty) (ptrs clos) i
+                  | (i,ty) <- zip [0..] subTtypesP]
             let unboxeds   = extractUnboxed subTtypesNP clos
-                subTermsNP = map (uncurry Prim) (zip subTtypesNP unboxeds)
+                subTermsNP = zipWith Prim subTtypesNP unboxeds
                 subTerms   = reOrderTerms subTermsP subTermsNP subTtypes
             return (Term my_ty (Right dc) a subTerms)
+
 -- The otherwise case: can be a Thunk,AP,PAP,etc.
       tipe_clos ->
          return (Suspension tipe_clos my_ty a Nothing)
 
-  matchSubTypes dc ty
-    | ty' <- repType ty     -- look through newtypes
-    , Just (tc,ty_args) <- tcSplitTyConApp_maybe ty'
-    , dc `elem` tyConDataCons tc
-      -- It is necessary to check that dc is actually a constructor for tycon tc,
-      -- because it may be the case that tc is a recursive newtype and tcSplitTyConApp
-      -- has not removed it. In that case, we happily give up and don't match
-    = myDataConInstArgTys dc ty_args
-    | otherwise = dataConRepArgTys dc
-
   -- put together pointed and nonpointed subterms in the
   --  correct order.
   reOrderTerms _ _ [] = []
   reOrderTerms pointed unpointed (ty:tys) 
-   | isLifted ty || isRefType ty
-                  = ASSERT2(not(null pointed)
+   | isPtrType ty = ASSERT2(not(null pointed)
                             , ptext (sLit "reOrderTerms") $$ 
                                         (ppr pointed $$ ppr unpointed))
                     let (t:tt) = pointed in t : reOrderTerms tt unpointed tys
@@ -835,6 +837,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
    -- returns unification tasks,since we are going to want a breadth-first search
   go :: Type -> HValue -> TR [(Type, HValue)]
   go my_ty a = do
+    traceTR (text "go" <+> ppr my_ty)
     clos <- trIO $ getClosureData a
     case tipe clos of
       Blackhole -> appArr (go my_ty) (ptrs clos) 0 -- carefully, don't eval the TSO
@@ -847,6 +850,7 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
          return [(tv', contents)]
       Constr -> do
         Right dcname <- dataConInfoPtrToName (infoPtr clos)
+        traceTR (text "Constr1" <+> ppr dcname)
         (_,mb_dc)    <- tryTcErrs (tcLookupDataCon dcname)
         case mb_dc of
           Nothing-> do
@@ -856,17 +860,10 @@ cvReconstructType hsc_env max_depth old_ty hval = runTR_maybe hsc_env $ do
                         return$ appArr (\e->(tv,e)) (ptrs clos) i
 
           Just dc -> do
-            subTtypes <- mapMif (not . isMonomorphic)
-                                (\t -> newVar (typeKind t))
-                                (dataConRepArgTys dc)
-
-            -- It is vital for newtype reconstruction that the unification step
-            -- is done right here, _before_ the subterms are RTTI reconstructed
-            let myType         = mkFunTys subTtypes my_ty
-            (signatureType,_) <- instScheme (mydataConType dc)
-            addConstraint myType signatureType
-            return $ [ appArr (\e->(t,e)) (ptrs clos) i
-                       | (i,t) <- zip [0..] (filter (isLifted |.| isRefType) subTtypes)]
+            arg_tys <- getDataConArgTys dc my_ty
+           traceTR (text "Constr2" <+> ppr dcname <+> ppr arg_tys)
+            return $ [ appArr (\e-> (ty,e)) (ptrs clos) i
+                     | (i,ty) <- zip [0..] (filter isPtrType arg_tys)]
       _ -> return []
 
 -- Compute the difference between a base type and the type found by RTTI
@@ -877,36 +874,36 @@ improveRTTIType :: HscEnv -> RttiType -> RttiType -> Maybe TvSubst
 improveRTTIType _ base_ty new_ty
   = U.tcUnifyTys (const U.BindMe) [base_ty] [new_ty]
 
-myDataConInstArgTys :: DataCon -> [Type] -> [Type]
-myDataConInstArgTys dc args
-    | null (dataConExTyVars dc) && null (dataConEqTheta dc) = dataConInstArgTys dc args
-    | otherwise = dataConRepArgTys dc
-
-mydataConType :: DataCon -> QuantifiedType
--- ^ Custom version of DataCon.dataConUserType where we
---    - remove the equality constraints
---    - use the representation types for arguments, including dictionaries
---    - keep the original result type
-mydataConType  dc
-  = ( (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
-    , mkFunTys arg_tys res_ty )
-  where univ_tvs   = dataConUnivTyVars dc
-        ex_tvs     = dataConExTyVars dc
-        eq_spec    = dataConEqSpec dc
-        arg_tys    = [case a of
-                        PredTy p -> predTypeRep p
-                        _        -> a
-                     | a <- dataConRepArgTys dc]
-        res_ty     = dataConOrigResTy dc
-
-isRefType :: Type -> Bool
-isRefType ty
-   | Just (tc, _) <- tcSplitTyConApp_maybe ty' = isRefTyCon tc
-   | otherwise = False
-  where ty'= repType ty
-
-isRefTyCon :: TyCon -> Bool
-isRefTyCon tc = tc `elem` [mutVarPrimTyCon, mVarPrimTyCon, tVarPrimTyCon]
+getDataConArgTys :: DataCon -> Type -> TR [Type]
+-- Given the result type ty of a constructor application (D a b c :: ty) 
+-- return the types of the arguments.  This is RTTI-land, so 'ty' might
+-- not be fully known.  Moreover, the arg types might involve existentials;
+-- if so, make up fresh RTTI type variables for them
+getDataConArgTys dc con_app_ty
+  = do { (_, ex_tys, _) <- instTyVars ex_tvs
+       ; let rep_con_app_ty = repType con_app_ty
+       ; ty_args <- case tcSplitTyConApp_maybe rep_con_app_ty of
+                       Just (tc, ty_args) | dataConTyCon dc == tc
+                          -> ASSERT( univ_tvs `equalLength` ty_args) 
+                              return ty_args
+                      _   -> do { (_, ty_args, subst) <- instTyVars univ_tvs
+                                ; let res_ty = substTy subst (dataConOrigResTy dc)
+                                 ; addConstraint rep_con_app_ty res_ty
+                                 ; return ty_args }
+               -- It is necessary to check dataConTyCon dc == tc
+               -- because it may be the case that tc is a recursive
+               -- newtype and tcSplitTyConApp has not removed it. In
+               -- that case, we happily give up and don't match
+       ; let subst = zipTopTvSubst (univ_tvs ++ ex_tvs) (ty_args ++ ex_tys)
+       ; return (substTys subst (dataConRepArgTys dc)) }
+  where
+    univ_tvs = dataConUnivTyVars dc
+    ex_tvs   = dataConExTyVars dc
+
+isPtrType :: Type -> Bool
+isPtrType ty = case typePrimRep ty of
+                 PtrRep -> True
+                 _      -> False
 
 -- Soundness checks
 --------------------
@@ -1103,7 +1100,7 @@ congruenceNewtypes lhs rhs = go lhs rhs >>= \rhs' -> return (lhs,rhs')
             | otherwise = do
                traceTR (text "(Upgrade) upgraded " <> ppr ty <>
                         text " in presence of newtype evidence " <> ppr new_tycon)
-               vars <- mapM (newVar . tyVarKind) (tyConTyVars new_tycon)
+               (_, vars, _) <- instTyVars (tyConTyVars new_tycon)
                let ty' = mkTyConApp new_tycon vars
                _ <- liftTcM (unifyType ty (repType ty'))
         -- assumes that reptype doesn't ^^^^ touch tyconApp args 
@@ -1183,12 +1180,6 @@ quantifyType :: Type -> QuantifiedType
 -- Generalize the type: find all free tyvars and wrap in the appropiate ForAll.
 quantifyType ty = (varSetElems (tyVarsOfType ty), ty)
 
-mapMif :: Monad m => (a -> Bool) -> (a -> m a) -> [a] -> m [a]
-mapMif pred f xx = sequence $ mapMif_ pred f xx
-  where
-   mapMif_ _ _ []     = []
-   mapMif_ pred f (x:xx) = (if pred x then f x else return x) : mapMif_ pred f xx
-
 unlessM :: Monad m => m Bool -> m () -> m ()
 unlessM condM acc = condM >>= \c -> unless c acc
 
@@ -1205,24 +1196,10 @@ amap' f (Array i0 i _ arr#) = map g [0 .. i - i0]
     where g (I# i#) = case indexArray# arr# i# of
                           (# e #) -> f e
 
-
-isLifted :: Type -> Bool
-isLifted =  not . isUnLiftedType
-
 extractUnboxed  :: [Type] -> Closure -> [[Word]]
 extractUnboxed tt clos = go tt (nonPtrs clos)
-   where sizeofType t
-           | Just (tycon,_) <- tcSplitTyConApp_maybe t
-           = ASSERT (isPrimTyCon tycon) sizeofTyCon tycon
-           | otherwise = pprPanic "Expected a TcTyCon" (ppr t)
+   where sizeofType t = primRepSizeW (typePrimRep t)
          go [] _ = []
          go (t:tt) xx 
            | (x, rest) <- splitAt (sizeofType t) xx
            = x : go tt rest
-
-sizeofTyCon :: TyCon -> Int -- in *words*
-sizeofTyCon = primRepSizeW . tyConPrimRep
-
-
-(|.|) :: (a -> Bool) -> (a -> Bool) -> a -> Bool
-(f |.| g) x = f x || g x
index dab2860..81b5f18 100644 (file)
@@ -357,7 +357,7 @@ data IPBind id
 
 instance (OutputableBndr id) => Outputable (HsIPBinds id) where
   ppr (IPBinds bs ds) = pprDeeperList vcat (map ppr bs) 
-                       $$ ifPprDebug (ppr ds)
+                        $$ ifPprDebug (ppr ds)
 
 instance (OutputableBndr id) => Outputable (IPBind id) where
   ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs)
@@ -457,7 +457,7 @@ data EvTerm
   deriving( Data, Typeable)
 
 evVarTerm :: EvVar -> EvTerm
-evVarTerm v | isCoVar v = EvCoercion (mkCoVarCoercion v)
+evVarTerm v | isCoVar v = EvCoercion (mkCoVarCo v)
             | otherwise = EvId v
 \end{code}
 
@@ -546,7 +546,7 @@ pprHsWrapper doc wrap
     help it WpHole             = it
     help it (WpCompose f1 f2)  = help (help it f2) f1
     help it (WpCast co)   = add_parens $ sep [it False, nest 2 (ptext (sLit "|>") 
-                                                 <+> pprParendType co)]
+                                              <+> pprParendCo co)]
     help it (WpEvApp id)  = no_parens  $ sep [it True, nest 2 (ppr id)]
     help it (WpTyApp ty)  = no_parens  $ sep [it True, ptext (sLit "@") <+> pprParendType ty]
     help it (WpEvLam id)  = add_parens $ sep [ ptext (sLit "\\") <> pp_bndr id, it False]
@@ -572,8 +572,8 @@ instance Outputable EvBind where
 
 instance Outputable EvTerm where
   ppr (EvId v)          = ppr v
-  ppr (EvCast v co)     = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendType co
-  ppr (EvCoercion co)    = ppr co
+  ppr (EvCast v co)      = ppr v <+> (ptext (sLit "`cast`")) <+> pprParendCo co
+  ppr (EvCoercion co)    = ptext (sLit "CO") <+> ppr co
   ppr (EvSuperClass d n) = ptext (sLit "sc") <> parens (ppr (d,n))
   ppr (EvDFunApp df tys ts) = ppr df <+> sep [ char '@' <> ppr tys, ppr ts ]
 \end{code}
index 13b9d6e..7fb5f72 100644 (file)
@@ -24,7 +24,7 @@ module HsPat (
 
         isBangHsBind, isLiftedPatBind,
         isBangLPat, hsPatNeedsParens,
-       isIrrefutableHsPat,
+        isIrrefutableHsPat,
 
        pprParendLPat
     ) where
@@ -65,7 +65,7 @@ data Pat id
        -- support hsPatType :: Pat Id -> Type
 
   | VarPat     id                      -- Variable
-  | LazyPat    (LPat id)               -- Lazy pattern
+  | LazyPat     (LPat id)               -- Lazy pattern
   | AsPat      (Located id) (LPat id)  -- As pattern
   | ParPat      (LPat id)              -- Parenthesised pattern
   | BangPat    (LPat id)               -- Bang pattern
index 526f7eb..dfb3dd5 100644 (file)
@@ -19,9 +19,9 @@ module HsUtils(
   mkHsPar, mkHsApp, mkHsConApp, mkSimpleHsAlt,
   mkSimpleMatch, unguardedGRHSs, unguardedRHS, 
   mkMatchGroup, mkMatch, mkHsLam, mkHsIf,
-  mkHsWrap, mkLHsWrap, mkHsWrapCoI, mkLHsWrapCoI,
-  coiToHsWrapper, mkHsLams, mkHsDictLet,
-  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCoI, 
+  mkHsWrap, mkLHsWrap, mkHsWrapCo, mkLHsWrapCo,
+  coToHsWrapper, mkHsDictLet, mkHsLams,
+  mkHsOpApp, mkHsDo, mkHsComp, mkHsWrapPat, mkHsWrapPatCo,
 
   nlHsTyApp, nlHsVar, nlHsLit, nlHsApp, nlHsApps, nlHsIntLit, nlHsVarApps, 
   nlHsDo, nlHsOpApp, nlHsLam, nlHsPar, nlHsIf, nlHsCase, nlList,
@@ -77,7 +77,7 @@ import HsLit
 import RdrName
 import Var
 import Coercion
-import Type
+import TypeRep
 import DataCon
 import Name
 import NameSet
@@ -137,25 +137,25 @@ mkHsWrap :: HsWrapper -> HsExpr id -> HsExpr id
 mkHsWrap co_fn e | isIdHsWrapper co_fn = e
                 | otherwise           = HsWrap co_fn e
 
-mkHsWrapCoI :: CoercionI -> HsExpr id -> HsExpr id
-mkHsWrapCoI (IdCo _) e = e
-mkHsWrapCoI (ACo co) e = mkHsWrap (WpCast co) e
+mkHsWrapCo :: Coercion -> HsExpr id -> HsExpr id
+mkHsWrapCo (Refl _) e = e
+mkHsWrapCo co       e = mkHsWrap (WpCast co) e
 
-mkLHsWrapCoI :: CoercionI -> LHsExpr id -> LHsExpr id
-mkLHsWrapCoI (IdCo _) e         = e
-mkLHsWrapCoI (ACo co) (L loc e) = L loc (mkHsWrap (WpCast co) e)
+mkLHsWrapCo :: Coercion -> LHsExpr id -> LHsExpr id
+mkLHsWrapCo (Refl _) e         = e
+mkLHsWrapCo co       (L loc e) = L loc (mkHsWrap (WpCast co) e)
 
-coiToHsWrapper :: CoercionI -> HsWrapper
-coiToHsWrapper (IdCo _) = idHsWrapper
-coiToHsWrapper (ACo co) = WpCast co
+coToHsWrapper :: Coercion -> HsWrapper
+coToHsWrapper (Refl _) = idHsWrapper
+coToHsWrapper co       = WpCast co
 
 mkHsWrapPat :: HsWrapper -> Pat id -> Type -> Pat id
 mkHsWrapPat co_fn p ty | isIdHsWrapper co_fn = p
                       | otherwise           = CoPat co_fn p ty
 
-mkHsWrapPatCoI :: CoercionI -> Pat id -> Type -> Pat id
-mkHsWrapPatCoI (IdCo _) pat _  = pat
-mkHsWrapPatCoI (ACo co) pat ty = CoPat (WpCast co) pat ty
+mkHsWrapPatCo :: Coercion -> Pat id -> Type -> Pat id
+mkHsWrapPatCo (Refl _) pat _  = pat
+mkHsWrapPatCo co       pat ty = CoPat (WpCast co) pat ty
 
 mkHsLam :: [LPat id] -> LHsExpr id -> LHsExpr id
 mkHsLam pats body = mkHsPar (L (getLoc body) (HsLam matches))
index 993159b..c80628b 100644 (file)
@@ -1,4 +1,3 @@
-
 {-# OPTIONS_GHC -O #-}
 -- We always optimise this, otherwise performance of a non-optimised
 -- compiler is severely affected
@@ -903,10 +902,11 @@ instance Binary IfaceType where
     put_ bh (IfaceTyConApp (IfaceAnyTc k) [])         = do { putByte bh 17; put_ bh k }
 
        -- Generic cases
-
     put_ bh (IfaceTyConApp (IfaceTc tc) tys) = do { putByte bh 18; put_ bh tc; put_ bh tys }
     put_ bh (IfaceTyConApp tc tys)          = do { putByte bh 19; put_ bh tc; put_ bh tys }
 
+    put_ bh (IfaceCoConApp cc tys) = do { putByte bh 20; put_ bh cc; put_ bh tys }
+
     get bh = do
            h <- getByte bh
            case h of
@@ -939,11 +939,11 @@ instance Binary IfaceType where
               17 -> do { k <- get bh; return (IfaceTyConApp (IfaceAnyTc k) []) }
 
              18 -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp (IfaceTc tc) tys) }
-             _  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+             19  -> do { tc <- get bh; tys <- get bh; return (IfaceTyConApp tc tys) }
+             _  -> do { cc <- get bh; tys <- get bh; return (IfaceCoConApp cc tys) }
 
 instance Binary IfaceTyCon where
        -- Int,Char,Bool can't show up here because they can't not be saturated
-
    put_ bh IfaceIntTc                = putByte bh 1
    put_ bh IfaceBoolTc               = putByte bh 2
    put_ bh IfaceCharTc               = putByte bh 3
@@ -954,9 +954,9 @@ instance Binary IfaceTyCon where
    put_ bh IfaceUnliftedTypeKindTc = putByte bh 8
    put_ bh IfaceUbxTupleKindTc     = putByte bh 9
    put_ bh IfaceArgTypeKindTc      = putByte bh 10
-   put_ bh (IfaceTupTc bx ar) = do { putByte bh 11; put_ bh bx; put_ bh ar }
-   put_ bh (IfaceTc ext)      = do { putByte bh 12; put_ bh ext }
-   put_ bh (IfaceAnyTc k)     = do { putByte bh 13; put_ bh k }
+   put_ bh (IfaceTupTc bx ar)  = do { putByte bh 11; put_ bh bx; put_ bh ar }
+   put_ bh (IfaceTc ext)       = do { putByte bh 12; put_ bh ext }
+   put_ bh (IfaceAnyTc k)      = do { putByte bh 13; put_ bh k }
 
    get bh = do
        h <- getByte bh
@@ -973,7 +973,27 @@ instance Binary IfaceTyCon where
           10 -> return IfaceArgTypeKindTc
          11 -> do { bx <- get bh; ar <- get bh; return (IfaceTupTc bx ar) }
          12 -> do { ext <- get bh; return (IfaceTc ext) }
-         _  -> do { k <- get bh; return (IfaceAnyTc k) }
+         _ -> do { k <- get bh; return (IfaceAnyTc k) }
+
+instance Binary IfaceCoCon where
+   put_ bh (IfaceCoAx n)       = do { putByte bh 0; put_ bh n }
+   put_ bh IfaceReflCo         = putByte bh 1
+   put_ bh IfaceUnsafeCo       = putByte bh 2
+   put_ bh IfaceSymCo          = putByte bh 3
+   put_ bh IfaceTransCo        = putByte bh 4
+   put_ bh IfaceInstCo         = putByte bh 5
+   put_ bh (IfaceNthCo d)      = do { putByte bh 6; put_ bh d }
+  
+   get bh = do
+       h <- getByte bh
+       case h of
+          0 -> do { n <- get bh; return (IfaceCoAx n) }
+         1 -> return IfaceReflCo 
+         2 -> return IfaceUnsafeCo
+         3 -> return IfaceSymCo
+         4 -> return IfaceTransCo
+         5 -> return IfaceInstCo
+          _ -> do { d <- get bh; return (IfaceNthCo d) }
 
 instance Binary IfacePredType where
     put_ bh (IfaceClassP aa ab) = do
@@ -1013,50 +1033,50 @@ instance Binary IfaceExpr where
     put_ bh (IfaceType ab) = do
            putByte bh 1
            put_ bh ab
-    put_ bh (IfaceTuple ac ad) = do
+    put_ bh (IfaceCo ab) = do
            putByte bh 2
+           put_ bh ab
+    put_ bh (IfaceTuple ac ad) = do
+           putByte bh 3
            put_ bh ac
            put_ bh ad
     put_ bh (IfaceLam ae af) = do
-           putByte bh 3
+           putByte bh 4
            put_ bh ae
            put_ bh af
     put_ bh (IfaceApp ag ah) = do
-           putByte bh 4
+           putByte bh 5
            put_ bh ag
            put_ bh ah
--- gaw 2004
-    put_ bh (IfaceCase ai aj al ak) = do
-           putByte bh 5
+    put_ bh (IfaceCase ai aj ak) = do
+           putByte bh 6
            put_ bh ai
            put_ bh aj
--- gaw 2004
-            put_ bh al
            put_ bh ak
     put_ bh (IfaceLet al am) = do
-           putByte bh 6
+           putByte bh 7
            put_ bh al
            put_ bh am
     put_ bh (IfaceNote an ao) = do
-           putByte bh 7
+           putByte bh 8
            put_ bh an
            put_ bh ao
     put_ bh (IfaceLit ap) = do
-           putByte bh 8
+           putByte bh 9
            put_ bh ap
     put_ bh (IfaceFCall as at) = do
-           putByte bh 9
+           putByte bh 10
            put_ bh as
            put_ bh at
     put_ bh (IfaceExt aa) = do
-           putByte bh 10
+           putByte bh 11
            put_ bh aa
     put_ bh (IfaceCast ie ico) = do
-            putByte bh 11
+            putByte bh 12
             put_ bh ie
             put_ bh ico
     put_ bh (IfaceTick m ix) = do
-            putByte bh 12
+            putByte bh 13
             put_ bh m
             put_ bh ix
     get bh = do
@@ -1066,39 +1086,38 @@ instance Binary IfaceExpr where
                      return (IfaceLcl aa)
              1 -> do ab <- get bh
                      return (IfaceType ab)
-             2 -> do ac <- get bh
+             2 -> do ab <- get bh
+                     return (IfaceCo ab)
+             3 -> do ac <- get bh
                      ad <- get bh
                      return (IfaceTuple ac ad)
-             3 -> do ae <- get bh
+             4 -> do ae <- get bh
                      af <- get bh
                      return (IfaceLam ae af)
-             4 -> do ag <- get bh
+             5 -> do ag <- get bh
                      ah <- get bh
                      return (IfaceApp ag ah)
-             5 -> do ai <- get bh
+             6 -> do ai <- get bh
                      aj <- get bh
--- gaw 2004
-                      al <- get bh                   
                      ak <- get bh
--- gaw 2004
-                     return (IfaceCase ai aj al ak)
-             6 -> do al <- get bh
+                     return (IfaceCase ai aj ak)
+             7 -> do al <- get bh
                      am <- get bh
                      return (IfaceLet al am)
-             7 -> do an <- get bh
+             8 -> do an <- get bh
                      ao <- get bh
                      return (IfaceNote an ao)
-             8 -> do ap <- get bh
+             9 -> do ap <- get bh
                      return (IfaceLit ap)
-             9 -> do as <- get bh
-                     at <- get bh
-                     return (IfaceFCall as at)
-             10 -> do aa <- get bh
+             10 -> do as <- get bh
+                      at <- get bh
+                      return (IfaceFCall as at)
+             11 -> do aa <- get bh
                       return (IfaceExt aa)
-              11 -> do ie <- get bh
+              12 -> do ie <- get bh
                        ico <- get bh
                        return (IfaceCast ie ico)
-              12 -> do m <- get bh
+              13 -> do m <- get bh
                        ix <- get bh
                        return (IfaceTick m ix)
               _ -> panic ("get IfaceExpr " ++ show h)
index 9522024..92d0f42 100644 (file)
@@ -99,8 +99,8 @@ mkFamInstParentInfo :: Name -> [TyVar]
 mkFamInstParentInfo tc_name tvs (family, instTys) rep_tycon
   = do { -- Create the coercion
        ; co_tycon_name <- newImplicitBinder tc_name mkInstTyCoOcc
-       ; let co_tycon = mkFamInstCoercion co_tycon_name tvs
-                                        family instTys rep_tycon
+       ; let co_tycon = mkFamInstCo co_tycon_name tvs
+                                    family instTys rep_tycon
        ; return $ FamInstTyCon family instTys co_tycon }
     
 ------------------------------------------------------
@@ -126,23 +126,15 @@ mkNewTyConRhs :: Name -> TyCon -> DataCon -> TcRnIf m n AlgTyConRhs
 --   because the latter is part of a knot, whereas the former is not.
 mkNewTyConRhs tycon_name tycon con 
   = do { co_tycon_name <- newImplicitBinder tycon_name mkNewTyCoOcc
-       ; let co_tycon = mkNewTypeCoercion co_tycon_name tycon etad_tvs etad_rhs
-              cocon_maybe | all_coercions || isRecursiveTyCon tycon 
-                         = Just co_tycon
-                         | otherwise              
-                         = Nothing
-       ; traceIf (text "mkNewTyConRhs" <+> ppr cocon_maybe)
+       ; let co_tycon = mkNewTypeCo co_tycon_name tycon etad_tvs etad_rhs
+       ; traceIf (text "mkNewTyConRhs" <+> ppr co_tycon)
        ; return (NewTyCon { data_con    = con, 
                             nt_rhs      = rhs_ty,
                             nt_etad_rhs = (etad_tvs, etad_rhs),
-                            nt_co       = cocon_maybe } ) }
+                            nt_co       = co_tycon } ) }
                              -- Coreview looks through newtypes with a Nothing
                              -- for nt_co, or uses explicit coercions otherwise
   where
-        -- If all_coercions is True then we use coercions for all newtypes
-        -- otherwise we use coercions for recursive newtypes and look through
-        -- non-recursive newtypes
-    all_coercions = True
     tvs    = tyConTyVars tycon
     inst_con_ty = applyTys (dataConUserType con) (mkTyVarTys tvs)
     rhs_ty = ASSERT( isFunTy inst_con_ty ) funArgTy inst_con_ty
@@ -155,7 +147,7 @@ mkNewTyConRhs tycon_name tycon con
        -- has a single argument (Foo a) that is a *type class*, so
        -- dataConInstOrigArgTys returns [].
 
-    etad_tvs :: [TyVar]        -- Matched lazily, so that mkNewTypeCoercion can
+    etad_tvs :: [TyVar]        -- Matched lazily, so that mkNewTypeCo can
     etad_rhs :: Type   -- return a TyCon without pulling on rhs_ty
                        -- See Note [Tricky iface loop] in LoadIface
     (etad_tvs, etad_rhs) = eta_reduce (reverse tvs) rhs_ty
index dcf2177..49fded9 100644 (file)
@@ -227,12 +227,13 @@ data IfaceExpr
   = IfaceLcl    IfLclName
   | IfaceExt    IfExtName
   | IfaceType   IfaceType
-  | IfaceTuple  Boxity [IfaceExpr]              -- Saturated; type arguments omitted
-  | IfaceLam    IfaceBndr IfaceExpr
-  | IfaceApp    IfaceExpr IfaceExpr
-  | IfaceCase   IfaceExpr IfLclName IfaceType [IfaceAlt]
-  | IfaceLet    IfaceBinding  IfaceExpr
-  | IfaceNote   IfaceNote IfaceExpr
+  | IfaceCo     IfaceType              -- We re-use IfaceType for coercions
+  | IfaceTuple         Boxity [IfaceExpr]      -- Saturated; type arguments omitted
+  | IfaceLam   IfaceBndr IfaceExpr
+  | IfaceApp   IfaceExpr IfaceExpr
+  | IfaceCase  IfaceExpr IfLclName [IfaceAlt]
+  | IfaceLet   IfaceBinding  IfaceExpr
+  | IfaceNote  IfaceNote IfaceExpr
   | IfaceCast   IfaceExpr IfaceCoercion
   | IfaceLit    Literal
   | IfaceFCall  ForeignCall IfaceType
@@ -588,6 +589,7 @@ pprIfaceExpr _       (IfaceLit l)       = ppr l
 pprIfaceExpr _       (IfaceFCall cc ty) = braces (ppr cc <+> ppr ty)
 pprIfaceExpr _       (IfaceTick m ix)   = braces (text "tick" <+> ppr m <+> ppr ix)
 pprIfaceExpr _       (IfaceType ty)     = char '@' <+> pprParendIfaceType ty
+pprIfaceExpr _       (IfaceCo co)       = text "@~" <+> pprParendIfaceType co
 
 pprIfaceExpr add_par app@(IfaceApp _ _) = add_par (pprIfaceApp app [])
 pprIfaceExpr _       (IfaceTuple c as)  = tupleParens c (interpp'SP as)
@@ -600,17 +602,17 @@ pprIfaceExpr add_par i@(IfaceLam _ _)
     collect bs (IfaceLam b e) = collect (b:bs) e
     collect bs e              = (reverse bs, e)
 
-pprIfaceExpr add_par (IfaceCase scrut bndr ty [(con, bs, rhs)])
-  = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
-                        <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
-                        <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
-                  pprIfaceExpr noParens rhs <+> char '}'])
+pprIfaceExpr add_par (IfaceCase scrut bndr [(con, bs, rhs)])
+  = add_par (sep [ptext (sLit "case") 
+                       <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
+                       <+> ppr bndr <+> char '{' <+> ppr_con_bs con bs <+> arrow,
+                 pprIfaceExpr noParens rhs <+> char '}'])
 
-pprIfaceExpr add_par (IfaceCase scrut bndr ty alts)
-  = add_par (sep [ptext (sLit "case") <+> char '@' <+> pprParendIfaceType ty
-                        <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of")
-                        <+> ppr bndr <+> char '{',
-                  nest 2 (sep (map ppr_alt alts)) <+> char '}'])
+pprIfaceExpr add_par (IfaceCase scrut bndr alts)
+  = add_par (sep [ptext (sLit "case") 
+                       <+> pprIfaceExpr noParens scrut <+> ptext (sLit "of") 
+                       <+> ppr bndr <+> char '{',
+                 nest 2 (sep (map ppr_alt alts)) <+> char '}'])
 
 pprIfaceExpr _       (IfaceCast expr co)
   = sep [pprParendIfaceExpr expr,
@@ -786,6 +788,8 @@ freeNamesIfType (IfaceTyConApp tc ts) =
 freeNamesIfType (IfaceForAllTy tv t)  =
    freeNamesIfTvBndr tv &&& freeNamesIfType t
 freeNamesIfType (IfaceFunTy s t)      = freeNamesIfType s &&& freeNamesIfType t
+freeNamesIfType (IfaceCoConApp tc ts) = 
+   freeNamesIfCo tc &&& fnList freeNamesIfType ts
 
 freeNamesIfTvBndrs :: [IfaceTvBndr] -> NameSet
 freeNamesIfTvBndrs = fnList freeNamesIfTvBndr
@@ -828,16 +832,16 @@ freeNamesIfExpr :: IfaceExpr -> NameSet
 freeNamesIfExpr (IfaceExt v)      = unitNameSet v
 freeNamesIfExpr (IfaceFCall _ ty) = freeNamesIfType ty
 freeNamesIfExpr (IfaceType ty)    = freeNamesIfType ty
+freeNamesIfExpr (IfaceCo co)      = freeNamesIfType co
 freeNamesIfExpr (IfaceTuple _ as) = fnList freeNamesIfExpr as
 freeNamesIfExpr (IfaceLam b body) = freeNamesIfBndr b &&& freeNamesIfExpr body
 freeNamesIfExpr (IfaceApp f a)    = freeNamesIfExpr f &&& freeNamesIfExpr a
 freeNamesIfExpr (IfaceCast e co)  = freeNamesIfExpr e &&& freeNamesIfType co
 freeNamesIfExpr (IfaceNote _n r)  = freeNamesIfExpr r
 
-freeNamesIfExpr (IfaceCase s _ ty alts)
-  = freeNamesIfExpr s
+freeNamesIfExpr (IfaceCase s _ alts)
+  = freeNamesIfExpr s 
     &&& fnList fn_alt alts &&& fn_cons alts
-    &&& freeNamesIfType ty
   where
     fn_alt (_con,_bs,r) = freeNamesIfExpr r
 
@@ -863,6 +867,10 @@ freeNamesIfTc (IfaceTc tc) = unitNameSet tc
 -- ToDo: shouldn't we include IfaceIntTc & co.?
 freeNamesIfTc _ = emptyNameSet
 
+freeNamesIfCo :: IfaceCoCon -> NameSet
+freeNamesIfCo (IfaceCoAx tc) = unitNameSet tc
+freeNamesIfCo _ = emptyNameSet
+
 freeNamesIfRule :: IfaceRule -> NameSet
 freeNamesIfRule (IfaceRule { ifRuleBndrs = bs, ifRuleHead = f
                            , ifRuleArgs = es, ifRuleRhs = rhs })
index c97e16e..7817b42 100644 (file)
@@ -9,15 +9,18 @@ This module defines interface types and binders
 module IfaceType (
        IfExtName, IfLclName,
 
-        IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..),
+        IfaceType(..), IfaceKind, IfacePredType(..), IfaceTyCon(..), IfaceCoCon(..),
        IfaceContext, IfaceBndr(..), IfaceTvBndr, IfaceIdBndr, IfaceCoercion,
        ifaceTyConName,
 
        -- Conversion from Type -> IfaceType
-       toIfaceType, toIfacePred, toIfaceContext, 
+        toIfaceType, toIfaceContext,
        toIfaceBndr, toIfaceIdBndr, toIfaceTvBndrs, 
        toIfaceTyCon, toIfaceTyCon_name,
 
+        -- Conversion from Coercion -> IfaceType
+        coToIfaceType,
+
        -- Printing
        pprIfaceType, pprParendIfaceType, pprIfaceContext, 
        pprIfaceIdBndr, pprIfaceTvBndr, pprIfaceTvBndrs, pprIfaceBndrs,
@@ -25,11 +28,13 @@ module IfaceType (
 
     ) where
 
-import TypeRep
+import Coercion
+import TypeRep hiding( maybeParen )
 import TyCon
 import Id
 import Var
 import TysWiredIn
+import TysPrim
 import Name
 import BasicTypes
 import Outputable
@@ -59,14 +64,15 @@ type IfaceTvBndr  = (IfLclName, IfaceKind)
 type IfaceKind     = IfaceType
 type IfaceCoercion = IfaceType
 
-data IfaceType
-  = IfaceTyVar    IfLclName                    -- Type variable only, not tycon
+data IfaceType    -- A kind of universal type, used for types, kinds, and coercions
+  = IfaceTyVar    IfLclName                    -- Type/coercion variable only, not tycon
   | IfaceAppTy    IfaceType IfaceType
+  | IfaceFunTy    IfaceType IfaceType
   | IfaceForAllTy IfaceTvBndr IfaceType
   | IfacePredTy   IfacePredType
-  | IfaceTyConApp IfaceTyCon [IfaceType]       -- Not necessarily saturated
-                                               -- Includes newtypes, synonyms, tuples
-  | IfaceFunTy  IfaceType IfaceType
+  | IfaceTyConApp IfaceTyCon [IfaceType]  -- Not necessarily saturated
+                                         -- Includes newtypes, synonyms, tuples
+  | IfaceCoConApp IfaceCoCon [IfaceType]  -- Always saturated
 
 data IfacePredType     -- NewTypes are handled as ordinary TyConApps
   = IfaceClassP IfExtName [IfaceType]
@@ -75,18 +81,28 @@ data IfacePredType  -- NewTypes are handled as ordinary TyConApps
 
 type IfaceContext = [IfacePredType]
 
-data IfaceTyCon        -- Abbreviations for common tycons with known names
+data IfaceTyCon        -- Encodes type consructors, kind constructors
+                       -- coercion constructors, the lot
   = IfaceTc IfExtName  -- The common case
   | IfaceIntTc | IfaceBoolTc | IfaceCharTc
   | IfaceListTc | IfacePArrTc
   | IfaceTupTc Boxity Arity 
   | IfaceAnyTc IfaceKind     -- Used for AnyTyCon (see Note [Any Types] in TysPrim)
                             -- other than 'Any :: *' itself
+  -- Kind constructors
   | IfaceLiftedTypeKindTc | IfaceOpenTypeKindTc | IfaceUnliftedTypeKindTc
   | IfaceUbxTupleKindTc | IfaceArgTypeKindTc 
 
-ifaceTyConName :: IfaceTyCon -> IfExtName
-ifaceTyConName IfaceIntTc             = intTyConName
+  -- Coercion constructors
+data IfaceCoCon
+  = IfaceCoAx IfExtName
+  | IfaceReflCo    | IfaceUnsafeCo  | IfaceSymCo
+  | IfaceTransCo   | IfaceInstCo
+  | IfaceNthCo Int
+
+ifaceTyConName :: IfaceTyCon -> Name
+ifaceTyConName IfaceIntTc              = intTyConName
 ifaceTyConName IfaceBoolTc            = boolTyConName
 ifaceTyConName IfaceCharTc            = charTyConName
 ifaceTyConName IfaceListTc            = listTyConName
@@ -208,6 +224,10 @@ ppr_ty _         (IfaceTyVar tyvar)     = ppr tyvar
 ppr_ty ctxt_prec (IfaceTyConApp tc tys) = ppr_tc_app ctxt_prec tc tys
 ppr_ty _         (IfacePredTy st)       = ppr st
 
+ppr_ty ctxt_prec (IfaceCoConApp tc tys) 
+  = maybeParen ctxt_prec tYCON_PREC 
+              (sep [ppr tc, nest 4 (sep (map pprParendIfaceType tys))])
+
        -- Function types
 ppr_ty ctxt_prec (IfaceFunTy ty1 ty2)
   = -- We don't want to lose synonyms, so we mustn't use splitFunTys here.
@@ -268,6 +288,15 @@ instance Outputable IfaceTyCon where
                             -- so we fake it.  It's only for debug printing!
   ppr other_tc       = ppr (ifaceTyConName other_tc)
 
+instance Outputable IfaceCoCon where
+  ppr (IfaceCoAx n)  = ppr n
+  ppr IfaceReflCo    = ptext (sLit "Refl")
+  ppr IfaceUnsafeCo  = ptext (sLit "Unsafe")
+  ppr IfaceSymCo     = ptext (sLit "Sym")
+  ppr IfaceTransCo   = ptext (sLit "Trans")
+  ppr IfaceInstCo    = ptext (sLit "Inst")
+  ppr (IfaceNthCo d) = ptext (sLit "Nth:") <> int d
+
 -------------------
 pprIfaceContext :: IfaceContext -> SDoc
 -- Prints "(C a, D b) =>", including the arrow
@@ -309,18 +338,15 @@ toIfaceKind = toIfaceType
 ---------------------
 toIfaceType :: Type -> IfaceType
 -- Synonyms are retained in the interface type
-toIfaceType (TyVarTy tv) =
-  IfaceTyVar (occNameFS (getOccName tv))
-toIfaceType (AppTy t1 t2) =
-  IfaceAppTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (FunTy t1 t2) =
-  IfaceFunTy (toIfaceType t1) (toIfaceType t2)
-toIfaceType (TyConApp tc tys) =
-  IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
-toIfaceType (ForAllTy tv t) =
-  IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
-toIfaceType (PredTy st) =
-  IfacePredTy (toIfacePred st)
+toIfaceType (TyVarTy tv)      = IfaceTyVar (toIfaceTyCoVar tv)
+toIfaceType (AppTy t1 t2)     = IfaceAppTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (FunTy t1 t2)     = IfaceFunTy (toIfaceType t1) (toIfaceType t2)
+toIfaceType (TyConApp tc tys) = IfaceTyConApp (toIfaceTyCon tc) (toIfaceTypes tys)
+toIfaceType (ForAllTy tv t)   = IfaceForAllTy (toIfaceTvBndr tv) (toIfaceType t)
+toIfaceType (PredTy st)       = IfacePredTy (toIfacePred toIfaceType st)
+
+toIfaceTyCoVar :: TyCoVar -> FastString
+toIfaceTyCoVar = occNameFS . getOccName
 
 ----------------
 -- A little bit of (perhaps optional) trickiness here.  When
@@ -364,16 +390,39 @@ toIfaceTypes :: [Type] -> [IfaceType]
 toIfaceTypes ts = map toIfaceType ts
 
 ----------------
-toIfacePred :: PredType -> IfacePredType
-toIfacePred (ClassP cls ts) = 
-  IfaceClassP (getName cls) (toIfaceTypes ts)
-toIfacePred (IParam ip t) = 
-  IfaceIParam (mapIPName getOccName ip) (toIfaceType t)
-toIfacePred (EqPred ty1 ty2) =
-  IfaceEqPred (toIfaceType ty1) (toIfaceType ty2)
+toIfacePred :: (a -> IfaceType) -> Pred a -> IfacePredType
+toIfacePred to (ClassP cls ts)  = IfaceClassP (getName cls) (map to ts)
+toIfacePred to (IParam ip t)    = IfaceIParam (mapIPName getOccName ip) (to t)
+toIfacePred to (EqPred ty1 ty2) =  IfaceEqPred (to ty1) (to ty2)
 
 ----------------
 toIfaceContext :: ThetaType -> IfaceContext
-toIfaceContext cs = map toIfacePred cs
+toIfaceContext cs = map (toIfacePred toIfaceType) cs
+
+----------------
+coToIfaceType :: Coercion -> IfaceType
+coToIfaceType (Refl ty)             = IfaceCoConApp IfaceReflCo [toIfaceType ty]
+coToIfaceType (TyConAppCo tc cos)   = IfaceTyConApp (toIfaceTyCon tc) 
+                                                    (map coToIfaceType cos)
+coToIfaceType (AppCo co1 co2)       = IfaceAppTy    (coToIfaceType co1) 
+                                                    (coToIfaceType co2)
+coToIfaceType (ForAllCo v co)       = IfaceForAllTy (toIfaceTvBndr v) 
+                                                    (coToIfaceType co)
+coToIfaceType (CoVarCo cv)          = IfaceTyVar  (toIfaceTyCoVar cv)
+coToIfaceType (AxiomInstCo con cos) = IfaceCoConApp (IfaceCoAx (coAxiomName con))
+                                                    (map coToIfaceType cos)
+coToIfaceType (UnsafeCo ty1 ty2)    = IfaceCoConApp IfaceUnsafeCo 
+                                                    [ toIfaceType ty1
+                                                    , toIfaceType ty2 ]
+coToIfaceType (SymCo co)            = IfaceCoConApp IfaceSymCo 
+                                                    [ coToIfaceType co ]
+coToIfaceType (TransCo co1 co2)     = IfaceCoConApp IfaceTransCo
+                                                    [ coToIfaceType co1
+                                                    , coToIfaceType co2 ]
+coToIfaceType (NthCo d co)          = IfaceCoConApp (IfaceNthCo d)
+                                                    [ coToIfaceType co ]
+coToIfaceType (InstCo co ty)        = IfaceCoConApp IfaceInstCo 
+                                                    [ coToIfaceType co
+                                                    , toIfaceType ty ]
 \end{code}
 
index 847e7c7..5c58a80 100644 (file)
@@ -59,10 +59,10 @@ import Annotations
 import CoreSyn
 import CoreFVs
 import Class
+import Kind
 import TyCon
 import DataCon
 import Type
-import Coercion
 import TcType
 import InstEnv
 import FamInstEnv
@@ -1386,14 +1386,16 @@ tyThingToIfaceDecl (ATyCon tycon)
        = IfCon   { ifConOcc     = getOccName (dataConName data_con),
                    ifConInfix   = dataConIsInfix data_con,
                    ifConWrapper = isJust (dataConWrapId_maybe data_con),
-                   ifConUnivTvs = toIfaceTvBndrs (dataConUnivTyVars data_con),
-                   ifConExTvs   = toIfaceTvBndrs (dataConExTyVars data_con),
-                   ifConEqSpec  = to_eq_spec (dataConEqSpec data_con),
-                   ifConCtxt    = toIfaceContext (dataConEqTheta data_con ++ dataConDictTheta data_con),
-                   ifConArgTys  = map toIfaceType (dataConOrigArgTys data_con),
+                   ifConUnivTvs = toIfaceTvBndrs univ_tvs,
+                   ifConExTvs   = toIfaceTvBndrs ex_tvs,
+                   ifConEqSpec  = to_eq_spec eq_spec,
+                   ifConCtxt    = toIfaceContext theta,
+                   ifConArgTys  = map toIfaceType arg_tys,
                    ifConFields  = map getOccName 
                                       (dataConFieldLabels data_con),
                    ifConStricts = dataConStrictMarks data_con }
+        where
+          (univ_tvs, ex_tvs, eq_spec, theta, arg_tys, _) = dataConFullSig data_con
 
     to_eq_spec spec = [(getOccName tv, toIfaceType ty) | (tv,ty) <- spec]
 
@@ -1401,6 +1403,8 @@ tyThingToIfaceDecl (ATyCon tycon)
     famInstToIface (Just (famTyCon, instTys)) = 
       Just (toIfaceTyCon famTyCon, map toIfaceType instTys)
 
+tyThingToIfaceDecl c@(ACoAxiom _) = pprPanic "tyThingToIfaceDecl (ACoCon _)" (ppr c)
+
 tyThingToIfaceDecl (ADataCon dc)
  = pprPanic "toIfaceDecl" (ppr dc)     -- Should be trimmed out earlier
 
@@ -1565,6 +1569,8 @@ coreRuleToIfaceRule mod rule@(Rule { ru_name = name, ru_fn = fn,
        -- construct the same ru_rough field as we have right now;
        -- see tcIfaceRule
     do_arg (Type ty) = IfaceType (toIfaceType (deNoteType ty))
+    do_arg (Coercion co) = IfaceType (coToIfaceType co)
+                           
     do_arg arg       = toIfaceExpr arg
 
        -- Compute orphanhood.  See Note [Orphans] in IfaceSyn
@@ -1584,15 +1590,16 @@ bogusIfaceRule id_name
 
 ---------------------
 toIfaceExpr :: CoreExpr -> IfaceExpr
-toIfaceExpr (Var v)       = toIfaceVar v
-toIfaceExpr (Lit l)       = IfaceLit l
-toIfaceExpr (Type ty)     = IfaceType (toIfaceType ty)
-toIfaceExpr (Lam x b)     = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
-toIfaceExpr (App f a)     = toIfaceApp f [a]
-toIfaceExpr (Case s x ty as) = IfaceCase (toIfaceExpr s) (getFS x) (toIfaceType ty) (map toIfaceAlt as)
-toIfaceExpr (Let b e)     = IfaceLet (toIfaceBind b) (toIfaceExpr e)
-toIfaceExpr (Cast e co)   = IfaceCast (toIfaceExpr e) (toIfaceType co)
-toIfaceExpr (Note n e)    = IfaceNote (toIfaceNote n) (toIfaceExpr e)
+toIfaceExpr (Var v)         = toIfaceVar v
+toIfaceExpr (Lit l)         = IfaceLit l
+toIfaceExpr (Type ty)       = IfaceType (toIfaceType ty)
+toIfaceExpr (Coercion co)   = IfaceCo   (coToIfaceType co)
+toIfaceExpr (Lam x b)       = IfaceLam (toIfaceBndr x) (toIfaceExpr b)
+toIfaceExpr (App f a)       = toIfaceApp f [a]
+toIfaceExpr (Case s x _ as) = IfaceCase (toIfaceExpr s) (getFS x) (map toIfaceAlt as)
+toIfaceExpr (Let b e)       = IfaceLet (toIfaceBind b) (toIfaceExpr e)
+toIfaceExpr (Cast e co)     = IfaceCast (toIfaceExpr e) (coToIfaceType co)
+toIfaceExpr (Note n e)      = IfaceNote (toIfaceNote n) (toIfaceExpr e)
 
 ---------------------
 toIfaceNote :: Note -> IfaceNote
index a4da138..7ac95b1 100644 (file)
@@ -21,6 +21,7 @@ import BuildTyCl
 import TcRnMonad
 import TcType
 import Type
+import Coercion
 import TypeRep
 import HscTypes
 import Annotations
@@ -39,7 +40,6 @@ import TyCon
 import DataCon
 import TysWiredIn
 import TysPrim         ( anyTyConOfKind )
-import Var              ( Var, TyVar )
 import BasicTypes      ( Arity, nonRuleLoopBreaker )
 import qualified Var
 import VarEnv
@@ -790,20 +790,56 @@ tcIfaceType (IfaceAppTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceTy
 tcIfaceType (IfaceFunTy t1 t2)    = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (FunTy t1' t2') }
 tcIfaceType (IfaceTyConApp tc ts) = do { tc' <- tcIfaceTyCon tc; ts' <- tcIfaceTypes ts; return (mkTyConApp tc' ts') }
 tcIfaceType (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' -> do { t' <- tcIfaceType t; return (ForAllTy tv' t') }
-tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePredType st; return (PredTy st') }
+tcIfaceType (IfacePredTy st)      = do { st' <- tcIfacePred tcIfaceType st; return (PredTy st') }
+tcIfaceType t@(IfaceCoConApp {})  = pprPanic "tcIfaceType" (ppr t)
 
 tcIfaceTypes :: [IfaceType] -> IfL [Type]
 tcIfaceTypes tys = mapM tcIfaceType tys
 
 -----------------------------------------
-tcIfacePredType :: IfacePredType -> IfL PredType
-tcIfacePredType (IfaceClassP cls ts) = do { cls' <- tcIfaceClass cls; ts' <- tcIfaceTypes ts; return (ClassP cls' ts') }
-tcIfacePredType (IfaceIParam ip t)   = do { ip' <- newIPName ip; t' <- tcIfaceType t; return (IParam ip' t') }
-tcIfacePredType (IfaceEqPred t1 t2)  = do { t1' <- tcIfaceType t1; t2' <- tcIfaceType t2; return (EqPred t1' t2') }
+tcIfacePred :: (IfaceType -> IfL a) -> IfacePredType -> IfL (Pred a)
+tcIfacePred tc (IfaceClassP cls ts)
+  = do { cls' <- tcIfaceClass cls; ts' <- mapM tc ts; return (ClassP cls' ts') }
+tcIfacePred tc (IfaceIParam ip t)
+  = do { ip' <- newIPName ip; t' <- tc t; return (IParam ip' t') }
+tcIfacePred tc (IfaceEqPred t1 t2)
+  = do { t1' <- tc t1; t2' <- tc t2; return (EqPred t1' t2') }
 
 -----------------------------------------
 tcIfaceCtxt :: IfaceContext -> IfL ThetaType
-tcIfaceCtxt sts = mapM tcIfacePredType sts
+tcIfaceCtxt sts = mapM (tcIfacePred tcIfaceType) sts
+\end{code}
+
+%************************************************************************
+%*                                                                     *
+                       Coercions
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+tcIfaceCo :: IfaceType -> IfL Coercion
+tcIfaceCo (IfaceTyVar n)        = mkCoVarCo <$> tcIfaceCoVar n
+tcIfaceCo (IfaceAppTy t1 t2)    = mkAppCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceFunTy t1 t2)    = mkFunCo <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCo (IfaceTyConApp tc ts) = mkTyConAppCo <$> tcIfaceTyCon tc <*> mapM tcIfaceCo ts
+tcIfaceCo (IfaceCoConApp tc ts) = tcIfaceCoApp tc ts
+tcIfaceCo (IfaceForAllTy tv t)  = bindIfaceTyVar tv $ \ tv' ->
+                                  mkForAllCo tv' <$> tcIfaceCo t
+-- tcIfaceCo (IfacePredTy co)      = mkPredCo <$> tcIfacePred tcIfaceCo co
+tcIfaceCo (IfacePredTy _)      = panic "tcIfaceCo"
+
+tcIfaceCoApp :: IfaceCoCon -> [IfaceType] -> IfL Coercion
+tcIfaceCoApp IfaceReflCo    [t]     = Refl         <$> tcIfaceType t
+tcIfaceCoApp (IfaceCoAx n)  ts      = AxiomInstCo  <$> tcIfaceCoAxiom n <*> mapM tcIfaceCo ts
+tcIfaceCoApp IfaceUnsafeCo  [t1,t2] = UnsafeCo     <$> tcIfaceType t1 <*> tcIfaceType t2
+tcIfaceCoApp IfaceSymCo     [t]     = SymCo        <$> tcIfaceCo t
+tcIfaceCoApp IfaceTransCo   [t1,t2] = TransCo      <$> tcIfaceCo t1 <*> tcIfaceCo t2
+tcIfaceCoApp IfaceInstCo    [t1,t2] = InstCo       <$> tcIfaceCo t1 <*> tcIfaceType t2
+tcIfaceCoApp (IfaceNthCo d) [t]     = NthCo d      <$> tcIfaceCo t
+tcIfaceCoApp cc ts = pprPanic "toIfaceCoApp" (ppr cc <+> ppr ts)
+
+tcIfaceCoVar :: FastString -> IfL CoVar
+tcIfaceCoVar = tcIfaceLclId
 \end{code}
 
 
@@ -818,6 +854,12 @@ tcIfaceExpr :: IfaceExpr -> IfL CoreExpr
 tcIfaceExpr (IfaceType ty)
   = Type <$> tcIfaceType ty
 
+tcIfaceExpr (IfaceCo co)
+  = Coercion <$> tcIfaceCo co
+
+tcIfaceExpr (IfaceCast expr co)
+  = Cast <$> tcIfaceExpr expr <*> tcIfaceCo co
+
 tcIfaceExpr (IfaceLcl name)
   = Var <$> tcIfaceLclId name
 
@@ -852,7 +894,7 @@ tcIfaceExpr (IfaceLam bndr body)
 tcIfaceExpr (IfaceApp fun arg)
   = App <$> tcIfaceExpr fun <*> tcIfaceExpr arg
 
-tcIfaceExpr (IfaceCase scrut case_bndr ty alts)  = do
+tcIfaceExpr (IfaceCase scrut case_bndr alts)  = do
     scrut' <- tcIfaceExpr scrut
     case_bndr_name <- newIfaceName (mkVarOccFS case_bndr)
     let
@@ -867,8 +909,7 @@ tcIfaceExpr (IfaceCase scrut case_bndr ty alts)  = do
 
     extendIfaceIdEnv [case_bndr'] $ do
      alts' <- mapM (tcIfaceAlt scrut' tc_app) alts
-     ty' <- tcIfaceType ty
-     return (Case scrut' case_bndr' ty' alts')
+     return (Case scrut' case_bndr' (coreAltsType alts') alts')
 
 tcIfaceExpr (IfaceLet (IfaceNonRec (IfLetBndr fs ty info) rhs) body)
   = do { name    <- newIfaceName (mkVarOccFS fs)
@@ -897,11 +938,6 @@ tcIfaceExpr (IfaceLet (IfaceRec pairs) body)
                                 (idName id) (idType id) info
           ; return (setIdInfo id id_info, rhs') }
 
-tcIfaceExpr (IfaceCast expr co) = do
-    expr' <- tcIfaceExpr expr
-    co' <- tcIfaceType co
-    return (Cast expr' co')
-
 tcIfaceExpr (IfaceNote note expr) = do
     expr' <- tcIfaceExpr expr
     case note of
@@ -941,14 +977,13 @@ tcIfaceDataAlt :: DataCon -> [Type] -> [FastString] -> IfaceExpr
 tcIfaceDataAlt con inst_tys arg_strs rhs
   = do { us <- newUniqueSupply
        ; let uniqs = uniqsFromSupply us
-       ; let (ex_tvs, co_tvs, arg_ids)
+       ; let (ex_tvs, arg_ids)
                      = dataConRepFSInstPat arg_strs uniqs con inst_tys
-              all_tvs = ex_tvs ++ co_tvs
 
-       ; rhs' <- extendIfaceTyVarEnv all_tvs   $
+       ; rhs' <- extendIfaceTyVarEnv ex_tvs    $
                  extendIfaceIdEnv arg_ids      $
                  tcIfaceExpr rhs
-       ; return (DataAlt con, all_tvs ++ arg_ids, rhs') }
+       ; return (DataAlt con, ex_tvs ++ arg_ids, rhs') }
 \end{code}
 
 
@@ -1216,6 +1251,10 @@ tcIfaceClass :: Name -> IfL Class
 tcIfaceClass name = do { thing <- tcIfaceGlobal name
                       ; return (tyThingClass thing) }
 
+tcIfaceCoAxiom :: Name -> IfL CoAxiom
+tcIfaceCoAxiom name = do { thing <- tcIfaceGlobal name
+                        ; return (tyThingCoAxiom thing) }
+
 tcIfaceDataCon :: Name -> IfL DataCon
 tcIfaceDataCon name = do { thing <- tcIfaceGlobal name
                         ; case thing of
index 488cf86..87bf391 100644 (file)
@@ -1985,14 +1985,13 @@ forceRecompile :: DynP ()
 -- recompiled which probably isn't what you want
 forceRecompile = do { dfs <- liftEwM getCmdLineState
                    ; when (force_recomp dfs) (setDynFlag Opt_ForceRecomp) }
-       where
+        where
          force_recomp dfs = isOneShot (ghcMode dfs)
 
 setVerboseCore2Core :: DynP ()
 setVerboseCore2Core = do forceRecompile
                          setDynFlag Opt_D_verbose_core2core 
                          upd (\dfs -> dfs { shouldDumpSimplPhase = Nothing })
-                        
 
 setDumpSimplPhases :: String -> DynP ()
 setDumpSimplPhases s = do forceRecompile
@@ -2133,7 +2132,6 @@ addImportPath, addLibraryPath, addIncludePath, addFrameworkPath :: FilePath -> D
 addImportPath "" = upd (\s -> s{importPaths = []})
 addImportPath p  = upd (\s -> s{importPaths = importPaths s ++ splitPathList p})
 
-
 addLibraryPath p =
   upd (\s -> s{libraryPaths = libraryPaths s ++ splitPathList p})
 
index a9e652d..44ec3ff 100644 (file)
@@ -171,7 +171,7 @@ module GHC (
        pprParendType, pprTypeApp, 
        Kind,
        PredType,
-       ThetaType, pprForAll, pprThetaArrow,
+       ThetaType, pprForAll, pprThetaArrow, pprThetaArrowTy,
 
        -- ** Entities
        TyThing(..), 
@@ -256,7 +256,6 @@ import Type
 import Coercion                ( synTyConResKind )
 import TcType          hiding( typeKind )
 import Id
-import Var
 import TysPrim         ( alphaTyVars )
 import TyCon
 import Class
@@ -388,7 +387,7 @@ runGhc :: Maybe FilePath  -- ^ See argument to 'initGhcMonad'.
        -> Ghc a           -- ^ The action to perform.
        -> IO a
 runGhc mb_top_dir ghc = do
-  ref <- newIORef undefined
+  ref <- newIORef (panic "empty session")
   let session = Session ref
   flip unGhc session $ do
     initGhcMonad mb_top_dir
@@ -406,7 +405,7 @@ runGhcT :: (ExceptionMonad m, Functor m, MonadIO m) =>
         -> GhcT m a        -- ^ The action to perform.
         -> m a
 runGhcT mb_top_dir ghct = do
-  ref <- liftIO $ newIORef undefined
+  ref <- liftIO $ newIORef (panic "empty session")
   let session = Session ref
   flip unGhcT session $ do
     initGhcMonad mb_top_dir
index 11f1a8b..4d096d2 100644 (file)
@@ -54,13 +54,13 @@ module HscTypes (
 
         -- * TyThings and type environments
        TyThing(..),
-       tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId,
+       tyThingClass, tyThingTyCon, tyThingDataCon, tyThingId, tyThingCoAxiom,
        implicitTyThings, isImplicitTyThing,
        
        TypeEnv, lookupType, lookupTypeHscEnv, mkTypeEnv, emptyTypeEnv,
        extendTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, lookupTypeEnv,
        typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds,
-       typeEnvDataCons,
+       typeEnvDataCons, typeEnvCoAxioms,
 
         -- * MonadThings
         MonadThings(..),
@@ -1037,7 +1037,10 @@ implicitTyThings (ATyCon tc)
       -- for each data constructor in order,
       --   the contructor, worker, and (possibly) wrapper
     concatMap (extras_plus . ADataCon) (tyConDataCons tc)
-                    
+
+implicitTyThings (ACoAxiom _cc)
+  = []
+            
 implicitTyThings (AClass cl) 
   = -- dictionary datatype:
     --    [extras_plus:]
@@ -1069,10 +1072,10 @@ extras_plus thing = thing : implicitTyThings thing
 -- add the implicit coercion tycon
 implicitCoTyCon :: TyCon -> [TyThing]
 implicitCoTyCon tc 
-  = map ATyCon . catMaybes $ [-- Just if newtype, Nothing if not
-                              newTyConCo_maybe tc, 
+  = map ACoAxiom . catMaybes $ [-- Just if newtype, Nothing if not
+                              newTyConCo_maybe tc,
                               -- Just if family instance, Nothing if not
-                               tyConFamilyCoercion_maybe tc] 
+                             tyConFamilyCoercion_maybe tc] 
 
 -- sortByOcc = sortBy (\ x -> \ y -> getOccName x < getOccName y)
 
@@ -1082,10 +1085,11 @@ implicitCoTyCon tc
 -- of some other declaration, or it is generated implicitly by some
 -- other declaration.
 isImplicitTyThing :: TyThing -> Bool
-isImplicitTyThing (ADataCon _)  = True
-isImplicitTyThing (AnId     id) = isImplicitId id
-isImplicitTyThing (AClass   _)  = False
-isImplicitTyThing (ATyCon   tc) = isImplicitTyCon tc
+isImplicitTyThing (ADataCon {}) = True
+isImplicitTyThing (AnId id)     = isImplicitId id
+isImplicitTyThing (AClass {})   = False
+isImplicitTyThing (ATyCon tc)   = isImplicitTyCon tc
+isImplicitTyThing (ACoAxiom {}) = True
 
 extendTypeEnvWithIds :: TypeEnv -> [Id] -> TypeEnv
 extendTypeEnvWithIds env ids
@@ -1107,6 +1111,7 @@ emptyTypeEnv    :: TypeEnv
 typeEnvElts     :: TypeEnv -> [TyThing]
 typeEnvClasses  :: TypeEnv -> [Class]
 typeEnvTyCons   :: TypeEnv -> [TyCon]
+typeEnvCoAxioms :: TypeEnv -> [CoAxiom]
 typeEnvIds      :: TypeEnv -> [Id]
 typeEnvDataCons :: TypeEnv -> [DataCon]
 lookupTypeEnv   :: TypeEnv -> Name -> Maybe TyThing
@@ -1115,6 +1120,7 @@ emptyTypeEnv          = emptyNameEnv
 typeEnvElts     env = nameEnvElts env
 typeEnvClasses  env = [cl | AClass cl   <- typeEnvElts env]
 typeEnvTyCons   env = [tc | ATyCon tc   <- typeEnvElts env] 
+typeEnvCoAxioms env = [ax | ACoAxiom ax <- typeEnvElts env] 
 typeEnvIds      env = [id | AnId id     <- typeEnvElts env] 
 typeEnvDataCons env = [dc | ADataCon dc <- typeEnvElts env] 
 
@@ -1170,6 +1176,11 @@ tyThingTyCon :: TyThing -> TyCon
 tyThingTyCon (ATyCon tc) = tc
 tyThingTyCon other      = pprPanic "tyThingTyCon" (pprTyThing other)
 
+-- | Get the 'CoAxiom' from a 'TyThing' if it is a coercion axiom thing. Panics otherwise
+tyThingCoAxiom :: TyThing -> CoAxiom
+tyThingCoAxiom (ACoAxiom ax) = ax
+tyThingCoAxiom other        = pprPanic "tyThingCoAxiom" (pprTyThing other)
+
 -- | Get the 'Class' from a 'TyThing' if it is a class thing. Panics otherwise
 tyThingClass :: TyThing -> Class
 tyThingClass (AClass cls) = cls
index d859784..6d5344d 100644 (file)
@@ -23,8 +23,8 @@ import DataCon
 import Id
 import IdInfo
 import TyCon
+import Coercion( pprCoAxiom )
 import TcType
-import Var
 import Name
 import Outputable
 import FastString
@@ -45,7 +45,7 @@ type ShowMe = Name -> Bool
 ----------------------------
 -- | Pretty-prints a 'TyThing' with its defining location.
 pprTyThingLoc :: PrintExplicitForalls -> TyThing -> SDoc
-pprTyThingLoc pefas tyThing 
+pprTyThingLoc pefas tyThing
   = showWithLoc loc (pprTyThing pefas tyThing)
   where loc = pprNameLoc (GHC.getName tyThing)
 
@@ -57,10 +57,11 @@ ppr_ty_thing :: PrintExplicitForalls -> ShowMe -> TyThing -> SDoc
 ppr_ty_thing pefas _    (AnId id)          = pprId         pefas id
 ppr_ty_thing pefas _    (ADataCon dataCon) = pprDataConSig pefas dataCon
 ppr_ty_thing pefas show_me (ATyCon tyCon)   = pprTyCon      pefas show_me tyCon
+ppr_ty_thing _     _       (ACoAxiom ax)    = pprCoAxiom    ax
 ppr_ty_thing pefas show_me (AClass cls)     = pprClass      pefas show_me cls
 
 -- | Pretty-prints a 'TyThing' in context: that is, if the entity
--- is a data constructor, record selector, or class method, then 
+-- is a data constructor, record selector, or class method, then
 -- the entity's parent declaration is pretty-printed with irrelevant
 -- parts omitted.
 pprTyThingInContext :: PrintExplicitForalls -> TyThing -> SDoc
@@ -77,7 +78,7 @@ pprTyThingInContextLoc pefas tyThing
                 (pprTyThingInContext pefas tyThing)
 
 pprTyThingParent_maybe :: TyThing -> Maybe TyThing
--- (pprTyThingParent_maybe x) returns (Just p) 
+-- (pprTyThingParent_maybe x) returns (Just p)
 -- when pprTyThingInContext sould print a declaration for p
 -- (albeit with some "..." in it) when asked to show x
 pprTyThingParent_maybe (ADataCon dc) = Just (ATyCon (dataConTyCon dc))
@@ -94,6 +95,7 @@ pprTyThingHdr :: PrintExplicitForalls -> TyThing -> SDoc
 pprTyThingHdr pefas (AnId id)          = pprId         pefas id
 pprTyThingHdr pefas (ADataCon dataCon) = pprDataConSig pefas dataCon
 pprTyThingHdr pefas (ATyCon tyCon)     = pprTyConHdr   pefas tyCon
+pprTyThingHdr _     (ACoAxiom ax)      = pprCoAxiom ax
 pprTyThingHdr pefas (AClass cls)       = pprClassHdr   pefas cls
 
 pprTyConHdr :: PrintExplicitForalls -> TyCon -> SDoc
@@ -103,7 +105,7 @@ pprTyConHdr _ tyCon
   | otherwise
   = ptext keyword <+> opt_family <+> opt_stupid <+> ppr_bndr tyCon <+> hsep (map ppr vars)
   where
-    vars | GHC.isPrimTyCon tyCon || 
+    vars | GHC.isPrimTyCon tyCon ||
           GHC.isFunTyCon tyCon = take (GHC.tyConArity tyCon) GHC.alphaTyVars
         | otherwise = GHC.tyConTyVars tyCon
 
@@ -116,7 +118,7 @@ pprTyConHdr _ tyCon
       | otherwise             = empty
 
     opt_stupid         -- The "stupid theta" part of the declaration
-       | isAlgTyCon tyCon = GHC.pprThetaArrow (tyConStupidTheta tyCon)
+       | isAlgTyCon tyCon = GHC.pprThetaArrowTy (tyConStupidTheta tyCon)
        | otherwise        = empty      -- Returns 'empty' if null theta
 
 pprDataConSig :: PrintExplicitForalls -> GHC.DataCon -> SDoc
@@ -125,14 +127,14 @@ pprDataConSig pefas dataCon
 
 pprClassHdr :: PrintExplicitForalls -> GHC.Class -> SDoc
 pprClassHdr _ cls
-  = ptext (sLit "class") <+> 
-    GHC.pprThetaArrow (GHC.classSCTheta cls) <+>
+  = ptext (sLit "class") <+>
+    GHC.pprThetaArrowTy (GHC.classSCTheta cls) <+>
     ppr_bndr cls <+>
     hsep (map ppr tyVars) <+>
     GHC.pprFundeps funDeps
   where
      (tyVars, funDeps) = GHC.classTvsFds cls
-     
+
 pprId :: PrintExplicitForalls -> Var -> SDoc
 pprId pefas ident
   = hang (ppr_bndr ident <+> dcolon)
@@ -147,7 +149,7 @@ pprTypeForUser :: PrintExplicitForalls -> GHC.Type -> SDoc
 --     forall a. C a => forall b. Ord b => stuff
 -- Then we want to display
 --     (C a, Ord b) => stuff
-pprTypeForUser print_foralls ty 
+pprTypeForUser print_foralls ty
   | print_foralls = ppr tidy_ty
   | otherwise     = ppr (mkPhiTy ctxt ty')
   where
@@ -160,7 +162,7 @@ pprTyCon pefas show_me tyCon
   = if GHC.isFamilyTyCon tyCon
     then pprTyConHdr pefas tyCon <+> dcolon <+> 
         pprTypeForUser pefas (GHC.synTyConResKind tyCon)
-    else 
+    else
       let rhs_type = GHC.synTyConType tyCon
       in hang (pprTyConHdr pefas tyCon <+> equals) 2 (pprTypeForUser pefas rhs_type)
   | otherwise
@@ -168,7 +170,7 @@ pprTyCon pefas show_me tyCon
 
 pprAlgTyCon :: PrintExplicitForalls -> ShowMe -> TyCon -> SDoc
 pprAlgTyCon pefas show_me tyCon
-  | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$ 
+  | gadt      = pprTyConHdr pefas tyCon <+> ptext (sLit "where") $$
                   nest 2 (vcat (ppr_trim show_con datacons))
   | otherwise = hang (pprTyConHdr pefas tyCon)
                   2 (add_bars (ppr_trim show_con datacons))
@@ -184,8 +186,8 @@ pprAlgTyCon pefas show_me tyCon
 pprDataConDecl :: PrintExplicitForalls -> ShowMe -> Bool -> GHC.DataCon -> SDoc
 pprDataConDecl pefas show_me gadt_style dataCon
   | not gadt_style = ppr_fields tys_w_strs
-  | otherwise      = ppr_bndr dataCon <+> dcolon <+> 
-                       sep [ pp_foralls, GHC.pprThetaArrow theta, pp_tau ]
+  | otherwise      = ppr_bndr dataCon <+> dcolon <+>
+                       sep [ pp_foralls, GHC.pprThetaArrowTy theta, pp_tau ]
        -- Printing out the dataCon as a type signature, in GADT style
   where
     (forall_tvs, theta, tau) = tcSplitSigmaTy (GHC.dataConUserType dataCon)
@@ -214,15 +216,15 @@ pprDataConDecl pefas show_me gadt_style dataCon
        | null labels
        = ppr_bndr dataCon <+> sep (map pprParendBangTy fields)
        | otherwise
-       = ppr_bndr dataCon <+> 
-               braces (sep (punctuate comma (ppr_trim maybe_show_label 
+       = ppr_bndr dataCon <+>
+               braces (sep (punctuate comma (ppr_trim maybe_show_label
                                        (zip labels fields))))
 
 pprClass :: PrintExplicitForalls -> ShowMe -> GHC.Class -> SDoc
 pprClass pefas show_me cls
   | null methods
   = pprClassHdr pefas cls
-  | otherwise 
+  | otherwise
   = hang (pprClassHdr pefas cls <+> ptext (sLit "where"))
        2 (vcat (ppr_trim show_meth methods))
   where
@@ -237,7 +239,7 @@ pprClassMethod pefas id
   -- Here's the magic incantation to strip off the dictionary
   -- from the class op type.  Stolen from IfaceSyn.tyThingToIfaceDecl.
   --
-  -- It's important to tidy it *before* splitting it up, so that if 
+  -- It's important to tidy it *before* splitting it up, so that if
   -- we have   class C a b where
   --             op :: forall a. a -> b
   -- then the inner forall on op gets renamed to a1, and we print
@@ -268,7 +270,7 @@ ppr_bndr :: GHC.NamedThing a => a -> SDoc
 ppr_bndr a = GHC.pprParenSymName a
 
 showWithLoc :: SDoc -> SDoc -> SDoc
-showWithLoc loc doc 
+showWithLoc loc doc
     = hang doc 2 (char '\t' <> comment <+> loc)
                -- The tab tries to make them line up a bit
   where
index f23280b..b4296cb 100644 (file)
@@ -1156,6 +1156,7 @@ cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts
 cafRefs p (Note _n e)         = cafRefs p e
 cafRefs p (Cast e _co)         = cafRefs p e
 cafRefs _ (Type _)            = fastBool False
+cafRefs _ (Coercion _)         = fastBool False
 
 cafRefss :: VarEnv Id -> [Expr a] -> FastBool
 cafRefss _ []    = fastBool False
index 8bf9453..3f2b32a 100644 (file)
@@ -269,7 +269,7 @@ exp :: { IfaceExpr }
        | '%let' let_bind '%in' exp   { IfaceLet $2 $4 }
 -- gaw 2004
        | '%case' '(' ty ')' aexp '%of' id_bndr
-         '{' alts1 '}'               { IfaceCase $5 (fst $7) $3 $9 }
+         '{' alts1 '}'               { IfaceCase $5 (fst $7) $9 }
         | '%cast' aexp aty { IfaceCast $2 $3 }
 -- No InlineMe any more
 --     | '%note' STRING exp       
index a678a9d..101780d 100644 (file)
@@ -1129,11 +1129,12 @@ statePrimTyConKey, stableNamePrimTyConKey, stableNameTyConKey,
     word32PrimTyConKey, word32TyConKey, word64PrimTyConKey, word64TyConKey,
     liftedConKey, unliftedConKey, anyBoxConKey, kindConKey, boxityConKey,
     typeConKey, threadIdPrimTyConKey, bcoPrimTyConKey, ptrTyConKey,
-    funPtrTyConKey, tVarPrimTyConKey :: Unique
+    funPtrTyConKey, tVarPrimTyConKey, eqPredPrimTyConKey :: Unique
 statePrimTyConKey                      = mkPreludeTyConUnique 50
 stableNamePrimTyConKey                 = mkPreludeTyConUnique 51
-stableNameTyConKey                     = mkPreludeTyConUnique 52
-mutVarPrimTyConKey                     = mkPreludeTyConUnique 55
+stableNameTyConKey                      = mkPreludeTyConUnique 52
+eqPredPrimTyConKey                      = mkPreludeTyConUnique 53
+mutVarPrimTyConKey                      = mkPreludeTyConUnique 55
 ioTyConKey                             = mkPreludeTyConUnique 56
 wordPrimTyConKey                       = mkPreludeTyConUnique 58
 wordTyConKey                           = mkPreludeTyConUnique 59
@@ -1167,9 +1168,8 @@ eitherTyConKey :: Unique
 eitherTyConKey                         = mkPreludeTyConUnique 84
 
 -- Super Kinds constructors
-tySuperKindTyConKey, coSuperKindTyConKey :: Unique
+tySuperKindTyConKey :: Unique
 tySuperKindTyConKey                    = mkPreludeTyConUnique 85
-coSuperKindTyConKey                    = mkPreludeTyConUnique 86
 
 -- Kind constructors
 liftedTypeKindTyConKey, openTypeKindTyConKey, unliftedTypeKindTyConKey,
@@ -1393,6 +1393,9 @@ mapIdKey        = mkPreludeMiscIdUnique 69
 groupWithIdKey        = mkPreludeMiscIdUnique 70
 dollarIdKey           = mkPreludeMiscIdUnique 71
 
+coercionTokenIdKey :: Unique
+coercionTokenIdKey    = mkPreludeMiscIdUnique 72
+
 -- Parallel array functions
 singletonPIdKey, nullPIdKey, lengthPIdKey, replicatePIdKey, mapPIdKey,
     filterPIdKey, zipPIdKey, crossMapPIdKey, indexPIdKey, toPIdKey,
index 8f2d21f..93cc576 100644 (file)
@@ -527,7 +527,7 @@ For dataToTag#, we can reduce if either
 dataToTagRule :: IdUnfoldingFun -> [Expr CoreBndr] -> Maybe (Arg CoreBndr)
 dataToTagRule _ [Type ty1, Var tag_to_enum `App` Type ty2 `App` tag]
   | tag_to_enum `hasKey` tagToEnumKey
-  , ty1 `coreEqType` ty2
+  , ty1 `eqType` ty2
   = Just tag  -- dataToTag (tagToEnum x)   ==>   x
 
 dataToTagRule id_unf [_, val_arg]
@@ -600,7 +600,7 @@ match_append_lit _ [Type ty1,
                    ]
   | unpk `hasKey` unpackCStringFoldrIdKey &&
     c1 `cheapEqExpr` c2
-  = ASSERT( ty1 `coreEqType` ty2 )
+  = ASSERT( ty1 `eqType` ty2 )
     Just (Var unpk `App` Type ty1
                    `App` Lit (MachStr (s1 `appendFS` s2))
                    `App` c1
index ac3a528..4b3492b 100644 (file)
@@ -14,7 +14,22 @@ module TysPrim(
        openAlphaTy, openBetaTy, openAlphaTyVar, openBetaTyVar, openAlphaTyVars,
         argAlphaTy, argAlphaTyVar, argBetaTy, argBetaTyVar,
 
-       primTyCons,
+        -- Kind constructors...
+        tySuperKindTyCon, tySuperKind,
+        liftedTypeKindTyCon, openTypeKindTyCon, unliftedTypeKindTyCon,
+        argTypeKindTyCon, ubxTupleKindTyCon,
+
+        tySuperKindTyConName, liftedTypeKindTyConName,
+        openTypeKindTyConName, unliftedTypeKindTyConName,
+        ubxTupleKindTyConName, argTypeKindTyConName,
+
+        -- Kinds
+       liftedTypeKind, unliftedTypeKind, openTypeKind,
+        argTypeKind, ubxTupleKind,
+        mkArrowKind, mkArrowKinds, isCoercionKind,
+
+        funTyCon, funTyConName,
+        primTyCons,
 
        charPrimTyCon,          charPrimTy,
        intPrimTyCon,           intPrimTy,
@@ -44,7 +59,9 @@ module TysPrim(
        word32PrimTyCon,        word32PrimTy,
 
        int64PrimTyCon,         int64PrimTy,
-       word64PrimTyCon,        word64PrimTy,
+        word64PrimTyCon,        word64PrimTy,
+
+        eqPredPrimTyCon,            -- ty1 ~ ty2
 
        -- * Any
        anyTyCon, anyTyConOfKind, anyTypeOfKind
@@ -54,11 +71,9 @@ module TysPrim(
 
 import Var             ( TyVar, mkTyVar )
 import Name            ( Name, BuiltInSyntax(..), mkInternalName, mkWiredInName )
-import OccName         ( mkTcOcc )
-import OccName         ( mkTyVarOccFS, mkTcOccFS )
-import TyCon           ( TyCon, mkPrimTyCon, mkLiftedPrimTyCon, mkAnyTyCon )
-import Type
-import Coercion
+import OccName          ( mkTcOcc,mkTyVarOccFS, mkTcOccFS )
+import TyCon
+import TypeRep
 import SrcLoc
 import Unique          ( mkAlphaTyVarUnique )
 import PrelNames
@@ -102,6 +117,7 @@ primTyCons
     , word32PrimTyCon
     , word64PrimTyCon
     , anyTyCon
+    , eqPredPrimTyCon
     ]
 
 mkPrimTc :: FastString -> Unique -> TyCon -> Name
@@ -111,7 +127,7 @@ mkPrimTc fs unique tycon
                  (ATyCon tycon)        -- Relevant TyCon
                  UserSyntax            -- None are built-in syntax
 
-charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName :: Name
+charPrimTyConName, intPrimTyConName, int32PrimTyConName, int64PrimTyConName, wordPrimTyConName, word32PrimTyConName, word64PrimTyConName, addrPrimTyConName, floatPrimTyConName, doublePrimTyConName, statePrimTyConName, realWorldTyConName, arrayPrimTyConName, byteArrayPrimTyConName, mutableArrayPrimTyConName, mutableByteArrayPrimTyConName, mutVarPrimTyConName, mVarPrimTyConName, tVarPrimTyConName, stablePtrPrimTyConName, stableNamePrimTyConName, bcoPrimTyConName, weakPrimTyConName, threadIdPrimTyConName, eqPredPrimTyConName :: Name
 charPrimTyConName            = mkPrimTc (fsLit "Char#") charPrimTyConKey charPrimTyCon
 intPrimTyConName             = mkPrimTc (fsLit "Int#") intPrimTyConKey  intPrimTyCon
 int32PrimTyConName           = mkPrimTc (fsLit "Int32#") int32PrimTyConKey int32PrimTyCon
@@ -122,8 +138,9 @@ word64PrimTyConName               = mkPrimTc (fsLit "Word64#") word64PrimTyConKey word
 addrPrimTyConName            = mkPrimTc (fsLit "Addr#") addrPrimTyConKey addrPrimTyCon
 floatPrimTyConName           = mkPrimTc (fsLit "Float#") floatPrimTyConKey floatPrimTyCon
 doublePrimTyConName          = mkPrimTc (fsLit "Double#") doublePrimTyConKey doublePrimTyCon
-statePrimTyConName           = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
-realWorldTyConName           = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
+statePrimTyConName            = mkPrimTc (fsLit "State#") statePrimTyConKey statePrimTyCon
+eqPredPrimTyConName           = mkPrimTc (fsLit "~") eqPredPrimTyConKey eqPredPrimTyCon
+realWorldTyConName            = mkPrimTc (fsLit "RealWorld") realWorldTyConKey realWorldTyCon
 arrayPrimTyConName           = mkPrimTc (fsLit "Array#") arrayPrimTyConKey arrayPrimTyCon
 byteArrayPrimTyConName       = mkPrimTc (fsLit "ByteArray#") byteArrayPrimTyConKey byteArrayPrimTyCon
 mutableArrayPrimTyConName     = mkPrimTc (fsLit "MutableArray#") mutableArrayPrimTyConKey mutableArrayPrimTyCon
@@ -193,109 +210,95 @@ argBetaTy  = mkTyVarTy argBetaTyVar
 
 %************************************************************************
 %*                                                                     *
-               Any
+                FunTyCon
 %*                                                                     *
 %************************************************************************
 
-Note [Any types]
-~~~~~~~~~~~~~~~~
-The type constructor Any::* has these properties
-
-  * It is defined in module GHC.Prim, and exported so that it is 
-    available to users.  For this reason it's treated like any other 
-    primitive type:
-      - has a fixed unique, anyTyConKey, 
-      - lives in the global name cache
-      - built with TyCon.PrimTyCon
-
-  * It is lifted, and hence represented by a pointer
-
-  * It is inhabited by at least one value, namely bottom
-
-  * You can unsafely coerce any lifted type to Ayny, and back.
-
-  * It does not claim to be a *data* type, and that's important for
-    the code generator, because the code gen may *enter* a data value
-    but never enters a function value. 
-
-  * It is used to instantiate otherwise un-constrained type variables of kind *
-    For example        length Any []
-    See Note [Strangely-kinded void TyCons]
-
-In addition, we have a potentially-infinite family of types, one for
-each kind /other than/ *, needed to instantiate otherwise
-un-constrained type variables of kinds other than *.  This is a bit
-like tuples; there is a potentially-infinite family.  They have slightly
-different characteristics to Any::*:
-  
-  * They are built with TyCon.AnyTyCon
-  * They have non-user-writable names like "Any(*->*)" 
-  * They are not exported by GHC.Prim
-  * They are uninhabited (of course; not kind *)
-  * They have a unique derived from their OccName (see Note [Uniques of Any])
-  * Their Names do not live in the global name cache
-
-Note [Uniques of Any]
-~~~~~~~~~~~~~~~~~~~~~
-Although Any(*->*), say, doesn't have a binding site, it still needs
-to have a Unique.  Unlike tuples (which are also an infinite family)
-there is no convenient way to index them, so we use the Unique from
-their OccName instead.  That should be unique, 
-  - both wrt each other, because their strings differ
-
-  - and wrt any other Name, because Names get uniques with 
-    various 'char' tags, but the OccName of Any will 
-    get a Unique built with mkTcOccUnique, which has a particular 'char' 
-    tag; see Unique.mkTcOccUnique!
-
-Note [Strangely-kinded void TyCons]
-~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-See Trac #959 for more examples
+\begin{code}
+funTyConName :: Name
+funTyConName = mkPrimTyConName (fsLit "(->)") funTyConKey funTyCon
+
+funTyCon :: TyCon
+funTyCon = mkFunTyCon funTyConName (mkArrowKinds [argTypeKind, openTypeKind] liftedTypeKind)
+        -- You might think that (->) should have type (?? -> ? -> *), and you'd be right
+       -- But if we do that we get kind errors when saying
+       --      instance Control.Arrow (->)
+       -- becuase the expected kind is (*->*->*).  The trouble is that the
+       -- expected/actual stuff in the unifier does not go contra-variant, whereas
+       -- the kind sub-typing does.  Sigh.  It really only matters if you use (->) in
+       -- a prefix way, thus:  (->) Int# Int#.  And this is unusual.
+        -- because they are never in scope in the source
+\end{code}
 
-When the type checker finds a type variable with no binding, which
-means it can be instantiated with an arbitrary type, it usually
-instantiates it to Void.  Eg.
 
-       length []
-===>
-       length Any (Nil Any)
+%************************************************************************
+%*                                                                     *
+                Kinds
+%*                                                                     *
+%************************************************************************