Commit 9729fe7c authored by batterseapower's avatar batterseapower

Implement -XConstraintKind

Basically as documented in http://hackage.haskell.org/trac/ghc/wiki/KindFact,
this patch adds a new kind Constraint such that:

  Show :: * -> Constraint
  (?x::Int) :: Constraint
  (Int ~ a) :: Constraint

And you can write *any* type with kind Constraint to the left of (=>):
even if that type is a type synonym, type variable, indexed type or so on.

The following (somewhat related) changes are also made:
 1. We now box equality evidence. This is required because we want
    to give (Int ~ a) the *lifted* kind Constraint
 2. For similar reasons, implicit parameters can now only be of
    a lifted kind. (?x::Int#) => ty is now ruled out
 3. Implicit parameter constraints are now allowed in superclasses
    and instance contexts (this just falls out as OK with the new
    constraint solver)

Internally the following major changes were made:
 1. There is now no PredTy in the Type data type. Instead
    GHC checks the kind of a type to figure out if it is a predicate
 2. There is now no AClass TyThing: we represent classes as TyThings
    just as a ATyCon (classes had TyCons anyway)
 3. What used to be (~) is now pretty-printed as (~#). The box
    constructor EqBox :: (a ~# b) -> (a ~ b)
 4. The type LCoercion is used internally in the constraint solver
    and type checker to represent coercions with free variables
    of type (a ~ b) rather than (a ~# b)
parent b98267ad
...@@ -44,7 +44,8 @@ module BasicTypes( ...@@ -44,7 +44,8 @@ module BasicTypes(
Boxity(..), isBoxed, Boxity(..), isBoxed,
TupCon(..), tupleParens, TupleSort(..), tupleSortBoxity, boxityNormalTupleSort,
tupleParens,
OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc, OccInfo(..), seqOccInfo, zapFragileOcc, isOneOcc,
isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc, isDeadOcc, isStrongLoopBreaker, isWeakLoopBreaker, isNoOcc,
...@@ -168,9 +169,10 @@ early in the hierarchy), but also in HsSyn. ...@@ -168,9 +169,10 @@ early in the hierarchy), but also in HsSyn.
\begin{code} \begin{code}
newtype IPName name = IPName name -- ?x newtype IPName name = IPName name -- ?x
deriving( Eq, Ord, Data, Typeable ) deriving( Eq, Data, Typeable )
-- Ord is used in the IP name cache finite map
-- (used in HscTypes.OrigIParamCache) instance Functor IPName where
fmap = mapIPName
ipNameName :: IPName name -> name ipNameName :: IPName name -> name
ipNameName (IPName n) = n ipNameName (IPName n) = n
...@@ -284,7 +286,7 @@ instance Outputable TopLevelFlag where ...@@ -284,7 +286,7 @@ instance Outputable TopLevelFlag where
%************************************************************************ %************************************************************************
%* * %* *
Top-level/not-top level flag Boxity flag
%* * %* *
%************************************************************************ %************************************************************************
...@@ -382,14 +384,25 @@ pprSafeOverlap False = empty ...@@ -382,14 +384,25 @@ pprSafeOverlap False = empty
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
data TupCon = TupCon Boxity Arity data TupleSort
= BoxedTuple
instance Eq TupCon where | UnboxedTuple
(TupCon b1 a1) == (TupCon b2 a2) = b1==b2 && a1==a2 | FactTuple
deriving( Eq, Data, Typeable )
tupleParens :: Boxity -> SDoc -> SDoc
tupleParens Boxed p = parens p tupleSortBoxity :: TupleSort -> Boxity
tupleParens Unboxed p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)") tupleSortBoxity BoxedTuple = Boxed
tupleSortBoxity UnboxedTuple = Unboxed
tupleSortBoxity FactTuple = Boxed
boxityNormalTupleSort :: Boxity -> TupleSort
boxityNormalTupleSort Boxed = BoxedTuple
boxityNormalTupleSort Unboxed = UnboxedTuple
tupleParens :: TupleSort -> SDoc -> SDoc
tupleParens BoxedTuple p = parens p
tupleParens FactTuple p = parens p -- The user can't write fact tuples directly, we overload the (,,) syntax
tupleParens UnboxedTuple p = ptext (sLit "(#") <+> p <+> ptext (sLit "#)")
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -47,11 +47,11 @@ import TyCon ...@@ -47,11 +47,11 @@ import TyCon
import Class import Class
import Name import Name
import Var import Var
import BasicTypes
import Outputable import Outputable
import Unique import Unique
import ListSetOps import ListSetOps
import Util import Util
import BasicTypes
import FastString import FastString
import Module import Module
...@@ -535,7 +535,7 @@ mkDataCon name declared_infix ...@@ -535,7 +535,7 @@ mkDataCon name declared_infix
-- source-language arguments. We add extra ones for the -- source-language arguments. We add extra ones for the
-- dictionary arguments right here. -- dictionary arguments right here.
full_theta = eqSpecPreds eq_spec ++ theta full_theta = eqSpecPreds eq_spec ++ theta
real_arg_tys = mkPredTys full_theta ++ orig_arg_tys real_arg_tys = full_theta ++ orig_arg_tys
real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts real_stricts = map mk_dict_strict_mark full_theta ++ arg_stricts
-- Representation arguments and demands -- Representation arguments and demands
...@@ -551,8 +551,9 @@ eqSpecPreds :: [(TyVar,Type)] -> ThetaType ...@@ -551,8 +551,9 @@ eqSpecPreds :: [(TyVar,Type)] -> ThetaType
eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ] eqSpecPreds spec = [ mkEqPred (mkTyVarTy tv, ty) | (tv,ty) <- spec ]
mk_dict_strict_mark :: PredType -> HsBang mk_dict_strict_mark :: PredType -> HsBang
mk_dict_strict_mark pred | isStrictPred pred = HsStrict mk_dict_strict_mark pred | isEqPred pred = HsUnpack
| otherwise = HsNoBang | otherwise = HsNoBang
\end{code} \end{code}
\begin{code} \begin{code}
...@@ -658,7 +659,7 @@ dataConStrictMarks = dcStrictMarks ...@@ -658,7 +659,7 @@ dataConStrictMarks = dcStrictMarks
-- | Strictness of evidence arguments to the wrapper function -- | Strictness of evidence arguments to the wrapper function
dataConExStricts :: DataCon -> [HsBang] dataConExStricts :: DataCon -> [HsBang]
-- Usually empty, so we don't bother to cache this -- Usually empty, so we don't bother to cache this
dataConExStricts dc = map mk_dict_strict_mark $ (dataConTheta dc) dataConExStricts dc = map mk_dict_strict_mark (dataConTheta dc)
-- | Source-level arity of the data constructor -- | Source-level arity of the data constructor
dataConSourceArity :: DataCon -> Arity dataConSourceArity :: DataCon -> Arity
...@@ -746,7 +747,7 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs, ...@@ -746,7 +747,7 @@ dataConUserType (MkData { dcUnivTyVars = univ_tvs,
dcOtherTheta = theta, dcOrigArgTys = arg_tys, dcOtherTheta = theta, dcOrigArgTys = arg_tys,
dcOrigResTy = res_ty }) dcOrigResTy = res_ty })
= mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $ = mkForAllTys ((univ_tvs `minusList` map fst eq_spec) ++ ex_tvs) $
mkFunTys (mkPredTys theta) $ mkFunTys theta $
mkFunTys arg_tys $ mkFunTys arg_tys $
res_ty res_ty
...@@ -841,11 +842,16 @@ dataConCannotMatch tys con ...@@ -841,11 +842,16 @@ dataConCannotMatch tys con
| all isTyVarTy tys = False -- Also common | all isTyVarTy tys = False -- Also common
| otherwise | otherwise
= typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2) = typesCantMatch [(Type.substTy subst ty1, Type.substTy subst ty2)
| EqPred ty1 ty2 <- theta ] | (ty1, ty2) <- concatMap (predEqs . predTypePredTree) theta ]
where where
dc_tvs = dataConUnivTyVars con dc_tvs = dataConUnivTyVars con
theta = dataConTheta con theta = dataConTheta con
subst = zipTopTvSubst dc_tvs tys subst = zipTopTvSubst dc_tvs tys
-- TODO: could gather equalities from superclasses too
predEqs (EqPred ty1 ty2) = [(ty1, ty2)]
predEqs (TuplePred ts) = concatMap predEqs ts
predEqs _ = []
\end{code} \end{code}
%************************************************************************ %************************************************************************
...@@ -935,4 +941,4 @@ computeRep stricts tys ...@@ -935,4 +941,4 @@ computeRep stricts tys
where where
(_tycon, _tycon_args, arg_dc, arg_tys) (_tycon, _tycon_args, arg_dc, arg_tys)
= deepSplitProductType "unbox_strict_arg_ty" ty = deepSplitProductType "unbox_strict_arg_ty" ty
\end{code} \end{code}
\ No newline at end of file
...@@ -293,20 +293,23 @@ mkDataConIds wrap_name wkr_name data_con ...@@ -293,20 +293,23 @@ mkDataConIds wrap_name wkr_name data_con
-- extra constraints where necessary. -- extra constraints where necessary.
wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs wrap_tvs = (univ_tvs `minusList` map fst eq_spec) ++ ex_tvs
res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs res_ty_args = substTyVars (mkTopTvSubst eq_spec) univ_tvs
ev_tys = mkPredTys other_theta ev_tys = other_theta
wrap_ty = mkForAllTys wrap_tvs $ wrap_ty = mkForAllTys wrap_tvs $
mkFunTys ev_tys $ mkFunTys ev_tys $
mkFunTys orig_arg_tys $ res_ty mkFunTys orig_arg_tys $ res_ty
----------- Wrappers for algebraic data types -------------- ----------- Wrappers for algebraic data types --------------
alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info alg_wrap_id = mkGlobalId (DataConWrapId data_con) wrap_name wrap_ty alg_wrap_info
alg_wrap_info = noCafIdInfo -- The NoCaf-ness is set by noCafIdInfo alg_wrap_info = noCafIdInfo
`setArityInfo` wrap_arity `setArityInfo` wrap_arity
-- It's important to specify the arity, so that partial -- It's important to specify the arity, so that partial
-- applications are treated as values -- applications are treated as values
`setInlinePragInfo` alwaysInlinePragma `setInlinePragInfo` alwaysInlinePragma
`setUnfoldingInfo` wrap_unf `setUnfoldingInfo` wrap_unf
`setStrictnessInfo` Just wrap_sig `setStrictnessInfo` Just wrap_sig
-- We need to get the CAF info right here because TidyPgm
-- does not tidy the IdInfo of implicit bindings (like the wrapper)
-- so it not make sure that the CAF info is sane
all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con all_strict_marks = dataConExStricts data_con ++ dataConStrictMarks data_con
wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info) wrap_sig = mkStrictSig (mkTopDmdType wrap_arg_dmds cpr_info)
...@@ -339,6 +342,8 @@ mkDataConIds wrap_name wkr_name data_con ...@@ -339,6 +342,8 @@ mkDataConIds wrap_name wkr_name data_con
`mkVarApps` ex_tvs `mkVarApps` ex_tvs
`mkCoApps` map (mkReflCo . snd) eq_spec `mkCoApps` map (mkReflCo . snd) eq_spec
`mkVarApps` reverse rep_ids `mkVarApps` reverse rep_ids
-- Dont box the eq_spec coercions since they are
-- marked as HsUnpack by mk_dict_strict_mark
(ev_args,i2) = mkLocals 1 ev_tys (ev_args,i2) = mkLocals 1 ev_tys
(id_args,i3) = mkLocals i2 orig_arg_tys (id_args,i3) = mkLocals i2 orig_arg_tys
...@@ -481,7 +486,7 @@ mkDictSelId no_unf name clas ...@@ -481,7 +486,7 @@ mkDictSelId no_unf name clas
the_arg_id = arg_ids !! val_index the_arg_id = arg_ids !! val_index
pred = mkClassPred clas (mkTyVarTys tyvars) pred = mkClassPred clas (mkTyVarTys tyvars)
dict_id = mkTemplateLocal 1 $ mkPredTy pred dict_id = mkTemplateLocal 1 pred
arg_ids = mkTemplateLocalsNum 2 arg_tys arg_ids = mkTemplateLocalsNum 2 arg_tys
rhs = mkLams tyvars (Lam dict_id rhs_body) rhs = mkLams tyvars (Lam dict_id rhs_body)
...@@ -838,7 +843,7 @@ mkDictFunId dfun_name tvs theta clas tys ...@@ -838,7 +843,7 @@ mkDictFunId dfun_name tvs theta clas tys
mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type mkDictFunTy :: [TyVar] -> ThetaType -> Class -> [Type] -> Type
mkDictFunTy tvs theta clas tys mkDictFunTy tvs theta clas tys
= mkSigmaTy tvs theta (mkDictTy clas tys) = mkSigmaTy tvs theta (mkClassPred clas tys)
\end{code} \end{code}
...@@ -1038,7 +1043,7 @@ voidArgId -- :: State# RealWorld ...@@ -1038,7 +1043,7 @@ voidArgId -- :: State# RealWorld
coercionTokenId :: Id -- :: () ~ () coercionTokenId :: Id -- :: () ~ ()
coercionTokenId -- Used to replace Coercion terms when we go to STG coercionTokenId -- Used to replace Coercion terms when we go to STG
= pcMiscPrelId coercionTokenName = pcMiscPrelId coercionTokenName
(mkTyConApp eqPredPrimTyCon [unitTy, unitTy]) (mkTyConApp eqPrimTyCon [unitTy, unitTy])
noCafIdInfo noCafIdInfo
\end{code} \end{code}
......
...@@ -40,7 +40,7 @@ module Name ( ...@@ -40,7 +40,7 @@ module Name (
mkSystemName, mkSystemNameAt, mkSystemName, mkSystemNameAt,
mkInternalName, mkDerivedInternalName, mkInternalName, mkDerivedInternalName,
mkSystemVarName, mkSysTvName, mkSystemVarName, mkSysTvName,
mkFCallName, mkIPName, mkFCallName,
mkTickBoxOpName, mkTickBoxOpName,
mkExternalName, mkWiredInName, mkExternalName, mkWiredInName,
...@@ -302,14 +302,6 @@ mkTickBoxOpName :: Unique -> String -> Name ...@@ -302,14 +302,6 @@ mkTickBoxOpName :: Unique -> String -> Name
mkTickBoxOpName uniq str mkTickBoxOpName uniq str
= Name { n_uniq = getKeyFastInt uniq, n_sort = Internal, = Name { n_uniq = getKeyFastInt uniq, n_sort = Internal,
n_occ = mkVarOcc str, n_loc = noSrcSpan } n_occ = mkVarOcc str, n_loc = noSrcSpan }
-- | Make the name of an implicit parameter
mkIPName :: Unique -> OccName -> Name
mkIPName uniq occ
= Name { n_uniq = getKeyFastInt uniq,
n_sort = Internal,
n_occ = occ,
n_loc = noSrcSpan }
\end{code} \end{code}
\begin{code} \begin{code}
......
...@@ -51,7 +51,7 @@ module OccName ( ...@@ -51,7 +51,7 @@ module OccName (
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc, mkDerivedTyConOcc, mkNewTyCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc, mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc,
mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc, mkClassDataConOcc, mkDictOcc, mkIPOcc,
mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS, mkGenD, mkGenR, mkGenRCo, mkGenC, mkGenS,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc,
...@@ -541,12 +541,12 @@ isDerivedOccName occ = ...@@ -541,12 +541,12 @@ isDerivedOccName occ =
\begin{code} \begin{code}
mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc, mkDataConWrapperOcc, mkWorkerOcc, mkDefaultMethodOcc, mkGenDefMethodOcc,
mkDerivedTyConOcc, mkClassTyConOcc, mkClassDataConOcc, mkDictOcc, mkDerivedTyConOcc, mkClassDataConOcc, mkDictOcc,
mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2, mkIPOcc, mkSpecOcc, mkForeignExportOcc, mkGenOcc1, mkGenOcc2,
mkGenD, mkGenR, mkGenRCo, mkGenD, mkGenR, mkGenRCo,
mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc, mkDataTOcc, mkDataCOcc, mkDataConWorkerOcc, mkNewTyCoOcc,
mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc, mkInstTyCoOcc, mkEqPredCoOcc, mkClassOpAuxOcc,
mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc mkCon2TagOcc, mkTag2ConOcc, mkMaxTagOcc
:: OccName -> OccName :: OccName -> OccName
-- These derived variables have a prefix that no Haskell value could have -- These derived variables have a prefix that no Haskell value could have
...@@ -555,8 +555,7 @@ mkWorkerOcc = mk_simple_deriv varName "$w" ...@@ -555,8 +555,7 @@ mkWorkerOcc = mk_simple_deriv varName "$w"
mkDefaultMethodOcc = mk_simple_deriv varName "$dm" mkDefaultMethodOcc = mk_simple_deriv varName "$dm"
mkGenDefMethodOcc = mk_simple_deriv varName "$gdm" mkGenDefMethodOcc = mk_simple_deriv varName "$gdm"
mkClassOpAuxOcc = mk_simple_deriv varName "$c" mkClassOpAuxOcc = mk_simple_deriv varName "$c"
mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies mkDerivedTyConOcc = mk_simple_deriv tcName ":" -- The : prefix makes sure it classifies as a tycon/datacon
mkClassTyConOcc = mk_simple_deriv tcName "T:" -- as a tycon/datacon
mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con mkClassDataConOcc = mk_simple_deriv dataName "D:" -- We go straight to the "real" data con
-- for datacons from classes -- for datacons from classes
mkDictOcc = mk_simple_deriv varName "$d" mkDictOcc = mk_simple_deriv varName "$d"
...@@ -624,8 +623,8 @@ mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ ...@@ -624,8 +623,8 @@ mkDataConWorkerOcc datacon_occ = setOccNameSpace varName datacon_occ
mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3 mkSuperDictSelOcc :: Int -- ^ Index of superclass, e.g. 3
-> OccName -- ^ Class, e.g. @Ord@ -> OccName -- ^ Class, e.g. @Ord@
-> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@ -> OccName -- ^ Derived 'Occname', e.g. @$p3Ord@
mkSuperDictSelOcc index cls_occ mkSuperDictSelOcc index cls_tc_occ
= mk_deriv varName "$p" (show index ++ occNameString cls_occ) = mk_deriv varName "$p" (show index ++ occNameString cls_tc_occ)
mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName' mkLocalOcc :: Unique -- ^ Unique to combine with the 'OccName'
-> OccName -- ^ Local name, e.g. @sat@ -> OccName -- ^ Local name, e.g. @sat@
...@@ -751,24 +750,43 @@ tidyOccName in_scope occ@(OccName occ_sp fs) ...@@ -751,24 +750,43 @@ tidyOccName in_scope occ@(OccName occ_sp fs)
%************************************************************************ %************************************************************************
\begin{code} \begin{code}
mkTupleOcc :: NameSpace -> Boxity -> Arity -> OccName mkTupleOcc :: NameSpace -> TupleSort -> Arity -> OccName
mkTupleOcc ns bx ar = OccName ns (mkFastString str) mkTupleOcc ns sort ar = OccName ns (mkFastString str)
where where
-- no need to cache these, the caching is done in the caller -- no need to cache these, the caching is done in the caller
-- (TysWiredIn.mk_tuple) -- (TysWiredIn.mk_tuple)
str = case bx of str = case sort of
Boxed -> '(' : commas ++ ")" UnboxedTuple -> '(' : '#' : commas ++ "#)"
Unboxed -> '(' : '#' : commas ++ "#)" BoxedTuple -> '(' : commas ++ ")"
FactTuple -> '(' : commas ++ ")"
-- Cute hack: reuse the standard tuple OccNames (and hence code)
-- for fact tuples, but give them different Uniques so they are not equal.
--
-- You might think that this will go wrong because isTupleOcc_maybe won't
-- be able to tell the difference between boxed tuples and fact tuples. BUT:
-- 1. Fact tuples never occur directly in user code, so it doesn't matter
-- that we can't detect them in Orig OccNames originating from the user
-- programs (or those built by setRdrNameSpace used on an Exact tuple Name)
-- 2. Interface files have a special representation for tuple *occurrences*
-- in IfaceTyCons, their workers (in IfaceSyn) and their DataCons (in case
-- alternatives). Thus we don't rely on the OccName to figure out what kind
-- of tuple an occurrence was trying to use in these situations.
-- 3. We *don't* represent tuple data type declarations specially, so those
-- are still turned into wired-in names via isTupleOcc_maybe. But that's OK
-- because we don't actually need to declare fact tuples thanks to this hack.
--
-- So basically any OccName like (,,) flowing to isTupleOcc_maybe will always
-- refer to the standard boxed tuple. Cool :-)
commas = take (ar-1) (repeat ',') commas = take (ar-1) (repeat ',')
isTupleOcc_maybe :: OccName -> Maybe (NameSpace, Boxity, Arity) isTupleOcc_maybe :: OccName -> Maybe (NameSpace, TupleSort, Arity)
-- Tuples are special, because there are so many of them! -- Tuples are special, because there are so many of them!
isTupleOcc_maybe (OccName ns fs) isTupleOcc_maybe (OccName ns fs)
= case unpackFS fs of = case unpackFS fs of
'(':'#':',':rest -> Just (ns, Unboxed, 2 + count_commas rest) '(':'#':',':rest -> Just (ns, UnboxedTuple, 2 + count_commas rest)
'(':',':rest -> Just (ns, Boxed, 2 + count_commas rest) '(':',':rest -> Just (ns, BoxedTuple, 2 + count_commas rest)
_other -> Nothing _other -> Nothing
where where
count_commas (',':rest) = 1 + count_commas rest count_commas (',':rest) = 1 + count_commas rest
count_commas _ = 0 count_commas _ = 0
......
...@@ -99,6 +99,10 @@ data RealSrcLoc ...@@ -99,6 +99,10 @@ data RealSrcLoc
{-# UNPACK #-} !Int -- line number, begins at 1 {-# UNPACK #-} !Int -- line number, begins at 1
{-# UNPACK #-} !Int -- column number, begins at 1 {-# UNPACK #-} !Int -- column number, begins at 1
#ifdef DEBUG
deriving Show -- debugging
#endif
data SrcLoc data SrcLoc
= RealSrcLoc {-# UNPACK #-}!RealSrcLoc = RealSrcLoc {-# UNPACK #-}!RealSrcLoc
| UnhelpfulLoc FastString -- Just a general indication | UnhelpfulLoc FastString -- Just a general indication
......
...@@ -34,9 +34,7 @@ module Unique ( ...@@ -34,9 +34,7 @@ module Unique (
newTagUnique, -- Used in CgCase newTagUnique, -- Used in CgCase
initTyVarUnique, initTyVarUnique,
isTupleKey, -- ** Making built-in uniques
-- ** Making built-in uniques
-- now all the built-in Uniques (and functions to make them) -- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...] -- [the Oh-So-Wonderful Haskell module system wins again...]
...@@ -47,7 +45,7 @@ module Unique ( ...@@ -47,7 +45,7 @@ module Unique (
mkPreludeTyConUnique, mkPreludeClassUnique, mkPreludeTyConUnique, mkPreludeClassUnique,
mkPArrDataConUnique, mkPArrDataConUnique,
mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique, mkVarOccUnique, mkDataOccUnique, mkTvOccUnique, mkTcOccUnique,
mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique, mkRegSingleUnique, mkRegPairUnique, mkRegClassUnique, mkRegSubUnique,
mkBuiltinUnique, mkBuiltinUnique,
...@@ -105,8 +103,6 @@ getKeyFastInt :: Unique -> FastInt -- for Var ...@@ -105,8 +103,6 @@ getKeyFastInt :: Unique -> FastInt -- for Var
incrUnique :: Unique -> Unique incrUnique :: Unique -> Unique
deriveUnique :: Unique -> Int -> Unique deriveUnique :: Unique -> Int -> Unique
newTagUnique :: Unique -> Char -> Unique newTagUnique :: Unique -> Char -> Unique
isTupleKey :: Unique -> Bool
\end{code} \end{code}
...@@ -311,9 +307,9 @@ Allocation of unique supply characters: ...@@ -311,9 +307,9 @@ Allocation of unique supply characters:
mkAlphaTyVarUnique :: Int -> Unique mkAlphaTyVarUnique :: Int -> Unique
mkPreludeClassUnique :: Int -> Unique mkPreludeClassUnique :: Int -> Unique
mkPreludeTyConUnique :: Int -> Unique mkPreludeTyConUnique :: Int -> Unique
mkTupleTyConUnique :: Boxity -> Int -> Unique mkTupleTyConUnique :: TupleSort -> Int -> Unique
mkPreludeDataConUnique :: Int -> Unique mkPreludeDataConUnique :: Int -> Unique
mkTupleDataConUnique :: Boxity -> Int -> Unique mkTupleDataConUnique :: TupleSort -> Int -> Unique
mkPrimOpIdUnique :: Int -> Unique mkPrimOpIdUnique :: Int -> Unique
mkPreludeMiscIdUnique :: Int -> Unique mkPreludeMiscIdUnique :: Int -> Unique
mkPArrDataConUnique :: Int -> Unique mkPArrDataConUnique :: Int -> Unique
...@@ -327,8 +323,9 @@ mkPreludeClassUnique i = mkUnique '2' i ...@@ -327,8 +323,9 @@ mkPreludeClassUnique i = mkUnique '2' i
-- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info. -- are for the generic to/from Ids. See TysWiredIn.mk_tc_gen_info.
mkPreludeTyConUnique i = mkUnique '3' (3*i) mkPreludeTyConUnique i = mkUnique '3' (3*i)
mkTupleTyConUnique Boxed a = mkUnique '4' (3*a) mkTupleTyConUnique BoxedTuple a = mkUnique '4' (3*a)
mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) mkTupleTyConUnique UnboxedTuple a = mkUnique '5' (3*a)
mkTupleTyConUnique FactTuple a = mkUnique 'k' (3*a)
-- Data constructor keys occupy *two* slots. The first is used for the -- Data constructor keys occupy *two* slots. The first is used for the
-- data constructor itself and its wrapper function (the function that -- data constructor itself and its wrapper function (the function that
...@@ -337,13 +334,9 @@ mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a) ...@@ -337,13 +334,9 @@ mkTupleTyConUnique Unboxed a = mkUnique '5' (3*a)
-- representation). -- representation).
mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic mkPreludeDataConUnique i = mkUnique '6' (2*i) -- Must be alphabetic
mkTupleDataConUnique Boxed a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels) mkTupleDataConUnique BoxedTuple a = mkUnique '7' (2*a) -- ditto (*may* be used in C labels)
mkTupleDataConUnique Unboxed a = mkUnique '8' (2*a) mkTupleDataConUnique UnboxedTuple a = mkUnique '8' (2*a)
mkTupleDataConUnique FactTuple a = mkUnique 'h' (2*a)
-- This one is used for a tiresome reason
-- to improve a consistency-checking error check in the renamer
isTupleKey u = case unpkUnique u of
(tag,_) -> tag == '4' || tag == '5' || tag == '7' || tag == '8'
mkPrimOpIdUnique op = mkUnique '9' op mkPrimOpIdUnique op = mkUnique '9' op
mkPreludeMiscIdUnique i = mkUnique '0' i mkPreludeMiscIdUnique i = mkUnique '0' i
......
...@@ -32,7 +32,7 @@ ...@@ -32,7 +32,7 @@
module Var ( module Var (
-- * The main data type and synonyms -- * The main data type and synonyms
Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EvId, IpId, Var, TyVar, CoVar, Id, DictId, DFunId, EvVar, EqVar, EvId, IpId,
-- ** Taking 'Var's apart -- ** Taking 'Var's apart
varName, varUnique, varType, varName, varUnique, varType,
...@@ -98,11 +98,12 @@ type DFunId = Id -- A dictionary function ...@@ -98,11 +98,12 @@ type DFunId = Id -- A dictionary function
type EvId = Id -- Term-level evidence: DictId or IpId type EvId = Id -- Term-level evidence: DictId or IpId
type DictId = EvId -- A dictionary variable type DictId = EvId -- A dictionary variable
type IpId = EvId -- A term-level implicit parameter type IpId = EvId -- A term-level implicit parameter
type EqVar = EvId -- Boxed equality evidence
type TyVar = Var type TyVar = Var
type CoVar = Id -- A coercion variable is simply an Id type CoVar = Id -- A coercion variable is simply an Id
-- variable of kind @ty1 ~ ty2@. Hence its -- variable of kind @#@. Its
-- 'varType' is always @PredTy (EqPred t1 t2)@ -- 'varType' is always @ty1 ~# ty2@
\end{code} \end{code}
%************************************************************************ %************************************************************************
......
...@@ -1091,15 +1091,9 @@ getTyDescription ty ...@@ -1091,15 +1091,9 @@ getTyDescription ty
AppTy fun _ -> getTyDescription fun AppTy fun _ -> getTyDescription fun
FunTy _ res -> '-' : '>' : fun_result res FunTy _ res -> '-' : '>' : fun_result res
TyConApp tycon _ -> getOccString tycon TyConApp tycon _ -> getOccString tycon
PredTy sty -> getPredTyDescription sty
ForAllTy _ ty -> getTyDescription ty ForAllTy _ ty -> getTyDescription ty
} }
where where
fun_result (FunTy _ res) = '>' : fun_result res fun_result (FunTy _ res) = '>' : fun_result res
fun_result other = getTyDescription other fun_result other = getTyDescription other
getPredTyDescription :: PredType -> String
getPredTyDescription (ClassP cl _) = getOccString cl
getPredTyDescription (IParam ip _) = getOccString (ipNameName ip)