diff --git a/ghc/compiler/Jmakefile b/ghc/compiler/Jmakefile
index ae3ed276f85d9bc49c82027d85b9c6e6a6eb5e7d..c54b9b5108db366c44bd639403cf3f475a331785 100644
--- a/ghc/compiler/Jmakefile
+++ b/ghc/compiler/Jmakefile
@@ -503,7 +503,7 @@ types/TyLoop.hi : types/TyLoop.lhi
rename/ParseIface.hs : rename/ParseIface.y
$(RM) rename/ParseIface.hs rename/ParseIface.hinfo
- happy -i rename/ParseIface.hinfo rename/ParseIface.y
+ happy -g -i rename/ParseIface.hinfo rename/ParseIface.y
@chmod 444 rename/ParseIface.hs
compile(absCSyn/AbsCUtils,lhs,)
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs
index a2b00f49190ee7e76f2b964125524f472af857aa..977bf8806392d3b08ef18067e8bc8677ae3d4799 100644
--- a/ghc/compiler/basicTypes/Id.lhs
+++ b/ghc/compiler/basicTypes/Id.lhs
@@ -81,6 +81,8 @@ module Id {- (
showId,
pprIdInUnfolding,
+ nmbrId,
+
-- "Environments" keyed off of Ids, and sets of Ids
IdEnv(..),
lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
@@ -104,15 +106,17 @@ import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName,
mkTupleDataConName, mkCompoundName,
- isLexSym, getLocalName,
+ isLexSym, isLexSpecialSym, getLocalName,
isLocallyDefined, isPreludeDefined,
getOccName, moduleNamePair, origName, nameOf,
isExported, ExportFlag(..),
RdrName(..), Name
)
-import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
+import FieldLabel ( fieldLabelName, FieldLabel(..){-instances-} )
import PragmaInfo ( PragmaInfo(..) )
+import PprEnv -- ( NmbrM(..), NmbrEnv(..) )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
+ nmbrType, addTyVar,
GenType, GenTyVar
)
import PprStyle
@@ -127,8 +131,8 @@ import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
import TyVar ( alphaTyVars, isEmptyTyVarSet, TyVarEnv(..) )
import UniqFM
import UniqSet -- practically all of it
-import UniqSupply ( getBuiltinUniques )
-import Unique ( pprUnique, showUnique,
+import Unique ( getBuiltinUniques, pprUnique, showUnique,
+ incrUnique,
Unique{-instance Ord3-}
)
import Util ( mapAccumL, nOfThem, zipEqual,
@@ -656,7 +660,7 @@ pprIdInUnfolding in_scopes v
(m_str, n_str) = moduleNamePair v
pp_n =
- if isLexSym n_str then
+ if isLexSym n_str && not (isLexSpecialSym n_str) then
ppBesides [ppLparen, ppPStr n_str, ppRparen]
else
ppPStr n_str
@@ -1938,3 +1942,69 @@ minusIdSet = minusUniqSet
isEmptyIdSet = isEmptyUniqSet
mkIdSet = mkUniqSet
\end{code}
+
+\begin{code}
+addId, nmbrId :: Id -> NmbrM Id
+
+addId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = case (lookupUFM_Directly idenv u) of
+ Just xx -> _trace "addId: already in map!" $
+ (nenv, xx)
+ Nothing ->
+ if toplevelishId id then
+ _trace "addId: can't add toplevelish!" $
+ (nenv, id)
+ else -- alloc a new unique for this guy
+ -- and add an entry in the idenv
+ -- NB: *** KNOT-TYING ***
+ let
+ nenv_plus_id = NmbrEnv (incrUnique ui) ut uu
+ (addToUFM_Directly idenv u new_id)
+ tvenv uvenv
+
+ (nenv2, new_ty) = nmbrType ty nenv_plus_id
+ (nenv3, new_det) = nmbr_details det nenv2
+
+ new_id = Id ui new_ty new_det prag info
+ in
+ (nenv3, new_id)
+
+nmbrId id@(Id u ty det prag info) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = case (lookupUFM_Directly idenv u) of
+ Just xx -> (nenv, xx)
+ Nothing ->
+ if not (toplevelishId id) then
+ _trace "nmbrId: lookup failed" $
+ (nenv, id)
+ else
+ let
+ (nenv2, new_ty) = nmbrType ty nenv
+ (nenv3, new_det) = nmbr_details det nenv2
+
+ new_id = Id u new_ty new_det prag info
+ in
+ (nenv3, new_id)
+
+------------
+nmbr_details :: IdDetails -> NmbrM IdDetails
+
+nmbr_details (DataConId n tag marks fields tvs theta arg_tys tc)
+ = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
+ mapNmbr nmbrField fields `thenNmbr` \ new_fields ->
+ mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
+ mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys ->
+ returnNmbr (DataConId n tag marks new_fields new_tvs new_theta new_arg_tys tc)
+ where
+ nmbr_theta (c,t)
+ = --nmbrClass c `thenNmbr` \ new_c ->
+ nmbrType t `thenNmbr` \ new_t ->
+ returnNmbr (c, new_t)
+
+ -- ToDo:add more cases as needed
+nmbr_details other_details = returnNmbr other_details
+
+------------
+nmbrField (FieldLabel n ty tag)
+ = nmbrType ty `thenNmbr` \ new_ty ->
+ returnNmbr (FieldLabel n new_ty tag)
+\end{code}
diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi
index bdc4f120ffdada61da22c118f6fc919c7e5a910e..abd59f35667a1633b9f254b2575613f843bd8a8e 100644
--- a/ghc/compiler/basicTypes/IdLoop.lhi
+++ b/ghc/compiler/basicTypes/IdLoop.lhi
@@ -11,7 +11,7 @@ import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg )
import CoreUnfold ( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
import CoreUtils ( unTagBinders )
import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
- unfoldingUnfriendlyId, getIdInfo,
+ unfoldingUnfriendlyId, getIdInfo, nmbrId,
nullIdEnv, lookupIdEnv, IdEnv(..),
Id(..), GenId
)
@@ -19,6 +19,7 @@ import IdInfo ( IdInfo )
import Literal ( Literal )
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import Outputable ( Outputable(..) )
+import PprEnv ( NmbrEnv )
import PprStyle ( PprStyle )
import PprType ( pprParendGenType )
import Pretty ( PrettyRep )
@@ -39,6 +40,7 @@ getIdInfo :: Id -> IdInfo
nullIdEnv :: UniqFM a
lookupIdEnv :: UniqFM b -> GenId a -> Maybe b
mAX_WORKER_ARGS :: Int
+nmbrId :: Id -> NmbrEnv -> (NmbrEnv, Id)
pprParendGenType :: (Eq a, Outputable a, Eq b, Outputable b) => PprStyle -> GenType a b -> Int -> Bool -> PrettyRep
unTagBinders :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), a) b c d -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) b c d
@@ -58,6 +60,7 @@ instance Outputable (GenTyVar a)
instance (Outputable a) => Outputable (GenId a)
instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
+data NmbrEnv
data MagicUnfoldingFun
data FormSummary = WhnfForm | BottomForm | OtherForm
data UnfoldingDetails
diff --git a/ghc/compiler/basicTypes/IdUtils.lhs b/ghc/compiler/basicTypes/IdUtils.lhs
index c1aa203b8dcf9032ae918f233dc7ab9f2ad5918c..043b37dea4b8ec4e8aaa66bf92d465310ad54305 100644
--- a/ghc/compiler/basicTypes/IdUtils.lhs
+++ b/ghc/compiler/basicTypes/IdUtils.lhs
@@ -43,7 +43,7 @@ primOpId op
Compare str ty ->
mk_prim_Id op pRELUDE_BUILTIN str [] [ty,ty] (compare_fun_ty ty) 2
- Coerce str ty1 ty2 ->
+ Coercing str ty1 ty2 ->
mk_prim_Id op pRELUDE_BUILTIN str [] [ty1] (mkFunTys [ty1] ty2) 1
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs
index 303fd042184b927e103dbb14f99b636adec82985..2a44651a5dd996a27d9c1e80157fc9ed969a303c 100644
--- a/ghc/compiler/basicTypes/Name.lhs
+++ b/ghc/compiler/basicTypes/Name.lhs
@@ -48,7 +48,7 @@ module Name (
getLocalName, ltLexical,
isSymLexeme, pprSym, pprNonSym,
- isLexCon, isLexVar, isLexId, isLexSym,
+ isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym
) where
@@ -123,7 +123,6 @@ instance Outputable RdrName where
ppr sty (Unqual n) = pp_name sty n
ppr sty (Qual m n) = ppBeside (pp_mod sty m) (pp_name sty n)
-pp_mod PprInterface m = ppNil
pp_mod PprForC m = ppBesides [identToC m, ppPStr cSEP]
pp_mod (PprForAsm False _) m = ppBesides [identToC m, ppPStr cSEP]
pp_mod (PprForAsm True _) m = ppBesides [ppPStr cSEP, identToC m, ppPStr cSEP]
@@ -423,7 +422,8 @@ defined in the Haskell report. Normally applied as in e.g. @isCon
(getLocalName foo)@.
\begin{code}
-isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym, isLexVarId, isLexVarSym :: FAST_STRING -> Bool
+isLexCon, isLexVar, isLexId, isLexSym, isLexConId, isLexConSym,
+ isLexVarId, isLexVarSym, isLexSpecialSym :: FAST_STRING -> Bool
isLexCon cs = isLexConId cs || isLexConSym cs
isLexVar cs = isLexVarId cs || isLexVarSym cs
@@ -449,10 +449,10 @@ isLexVarId cs
isLexConSym cs
| _NULL_ cs = False
- | otherwise = c == ':'
- || c == '(' -- (), (,), (,,), ...
+ | otherwise = c == ':'
+-- || c == '(' -- (), (,), (,,), ...
|| cs == SLIT("->")
- || cs == SLIT("[]")
+-- || cs == SLIT("[]")
where
c = _HEAD_ cs
@@ -460,7 +460,14 @@ isLexVarSym cs
| _NULL_ cs = False
| otherwise = isSymbolASCII c
|| isSymbolISO c
- || c == '(' -- (), (,), (,,), ...
+-- || c == '(' -- (), (,), (,,), ...
+-- || cs == SLIT("[]")
+ where
+ c = _HEAD_ cs
+
+isLexSpecialSym cs
+ | _NULL_ cs = False
+ | otherwise = c == '(' -- (), (,), (,,), ...
|| cs == SLIT("[]")
where
c = _HEAD_ cs
@@ -484,13 +491,16 @@ isSymLexeme v
pprSym, pprNonSym :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
pprSym sty var
- = if isSymLexeme var
+ = let
+ str = nameOf (origName var)
+ in
+ if isLexSym str && not (isLexSpecialSym str)
then ppr sty var
else ppBesides [ppChar '`', ppr sty var, ppChar '`']
pprNonSym sty var
= if isSymLexeme var
- then ppBesides [ppLparen, ppr sty var, ppRparen]
+ then ppParens (ppr sty var)
else ppr sty var
#ifdef USE_ATTACK_PRAGMAS
diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs
index 1cd1071a1f4be3bf4a22fd159d7c8a97bdf4cb17..d29b8755b30df72916c1f54e66c5a3adcc658009 100644
--- a/ghc/compiler/basicTypes/PprEnv.lhs
+++ b/ghc/compiler/basicTypes/PprEnv.lhs
@@ -12,13 +12,22 @@ module PprEnv (
initPprEnv,
pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle,
- pTy, pTyVar, pUVar, pUse
+ pTy, pTyVar, pUVar, pUse,
+
+ NmbrEnv(..),
+ NmbrM(..), initNmbr,
+ returnNmbr, thenNmbr,
+ mapNmbr, mapAndUnzipNmbr
+-- nmbr1, nmbr2, nmbr3
+-- rnumValVar, rnumTyVar, rnumUVar,
+-- lookupValVar, lookupTyVar, lookupUVar
) where
import Ubiq{-uitous-}
-import Id ( DataCon(..) )
import Pretty ( Pretty(..) )
+import Unique ( initRenumberingUniques )
+import UniqFM ( emptyUFM )
import Util ( panic )
\end{code}
@@ -32,7 +41,7 @@ data PprEnv tyvar uvar bndr occ
= PE PprStyle -- stored for safe keeping
(Literal -> Pretty) -- Doing these this way saves
- (DataCon -> Pretty) -- carrying around a PprStyle
+ (Id -> Pretty) -- carrying around a PprStyle
(PrimOp -> Pretty)
(CostCentre -> Pretty)
@@ -51,7 +60,7 @@ data PprEnv tyvar uvar bndr occ
initPprEnv
:: PprStyle
-> Maybe (Literal -> Pretty)
- -> Maybe (DataCon -> Pretty)
+ -> Maybe (Id -> Pretty)
-> Maybe (PrimOp -> Pretty)
-> Maybe (CostCentre -> Pretty)
-> Maybe (tyvar -> Pretty)
@@ -119,3 +128,75 @@ pOcc (PE _ _ _ _ _ _ _ _ _ pp _ _) = pp
pTy (PE _ _ _ _ _ _ _ _ _ _ pp _) = pp
pUse (PE _ _ _ _ _ _ _ _ _ _ _ pp) = pp
\end{code}
+
+We tend to {\em renumber} everything before printing, so that
+we get consistent Uniques on everything from run to run.
+\begin{code}
+data NmbrEnv
+ = NmbrEnv Unique -- next "Unique" to give out for a value
+ Unique -- ... for a tyvar
+ Unique -- ... for a usage var
+ (UniqFM Id) -- mapping for value vars we know about
+ (UniqFM TyVar) -- ... for tyvars
+ (UniqFM Unique{-UVar-}) -- ... for usage vars
+
+type NmbrM a = NmbrEnv -> (NmbrEnv, a)
+
+initNmbr :: NmbrM a -> a
+initNmbr m
+ = let
+ (v1,t1,u1) = initRenumberingUniques
+ init_nmbr_env = NmbrEnv v1 t1 u1 emptyUFM emptyUFM emptyUFM
+ in
+ snd (m init_nmbr_env)
+
+returnNmbr x nenv = (nenv, x)
+
+thenNmbr m k nenv
+ = let
+ (nenv2, res) = m nenv
+ in
+ k res nenv2
+
+mapNmbr f [] = returnNmbr []
+mapNmbr f (x:xs)
+ = f x `thenNmbr` \ r ->
+ mapNmbr f xs `thenNmbr` \ rs ->
+ returnNmbr (r:rs)
+
+mapAndUnzipNmbr f [] = returnNmbr ([],[])
+mapAndUnzipNmbr f (x:xs)
+ = f x `thenNmbr` \ (r1, r2) ->
+ mapAndUnzipNmbr f xs `thenNmbr` \ (rs1, rs2) ->
+ returnNmbr (r1:rs1, r2:rs2)
+
+{-
+nmbr1 nenv thing x1
+ = let
+ (nenv1, new_x1) = x1 nenv
+ in
+ (nenv1, thing new_x1)
+
+nmbr2 nenv thing x1 x2
+ = let
+ (nenv1, new_x1) = x1 nenv
+ (nenv2, new_x2) = x2 nenv1
+ in
+ (nenv2, thing new_x1 new_x2)
+
+nmbr3 nenv thing x1 x2 x3
+ = let
+ (nenv1, new_x1) = x1 nenv
+ (nenv2, new_x2) = x2 nenv1
+ (nenv3, new_x3) = x3 nenv2
+ in
+ (nenv3, thing new_x1 new_x2 new_x3)
+-}
+
+rnumValVar = panic "rnumValVar"
+rnumTyVar = panic "rnumTyVar"
+rnumUVar = panic "rnumUVar"
+lookupValVar = panic "lookupValVar"
+lookupTyVar = panic "lookupTyVar"
+lookupUVar = panic "lookupUVar"
+\end{code}
diff --git a/ghc/compiler/basicTypes/UniqSupply.lhs b/ghc/compiler/basicTypes/UniqSupply.lhs
index d9ae896f2b79efb030eb337b607781c9b7b300e4..7c155f326cc4a41ac5d54457707eaefc5c435e44 100644
--- a/ghc/compiler/basicTypes/UniqSupply.lhs
+++ b/ghc/compiler/basicTypes/UniqSupply.lhs
@@ -18,11 +18,7 @@ module UniqSupply (
thenMaybeUs, mapAccumLUs,
mkSplitUniqSupply,
- splitUniqSupply,
-
- -- and the access functions for the `builtin' UniqueSupply
- getBuiltinUniques, mkBuiltinUnique,
- mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
+ splitUniqSupply
) where
import Ubiq{-uitous-}
@@ -190,28 +186,3 @@ mapAccumLUs f b (x:xs)
mapAccumLUs f b__2 xs `thenUs` \ (b__3, xs__2) ->
returnUs (b__3, x__2:xs__2)
\end{code}
-
-%************************************************************************
-%* *
-\subsubsection[UniqueSupplies-compiler]{@UniqueSupplies@ specific to the compiler}
-%* *
-%************************************************************************
-
-\begin{code}
-mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
- mkBuiltinUnique :: Int -> Unique
-
-mkBuiltinUnique i = mkUnique 'B' i
-mkPseudoUnique1 i = mkUnique 'C' i -- used for uniqueOf on Regs
-mkPseudoUnique2 i = mkUnique 'D' i -- ditto
-mkPseudoUnique3 i = mkUnique 'E' i -- ditto
-
-getBuiltinUniques :: Int -> [Unique]
-getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
-\end{code}
-
-The following runs a uniq monad expression, using builtin uniq values:
-\begin{code}
---runBuiltinUs :: UniqSM a -> a
---runBuiltinUs m = snd (initUs uniqSupply_B m)
-\end{code}
diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs
index 68f3975dabe3a2a0e7508bfd93613beac76d0e3c..36702cc905301254c5e991e1083519399524ed03 100644
--- a/ghc/compiler/basicTypes/Unique.lhs
+++ b/ghc/compiler/basicTypes/Unique.lhs
@@ -29,6 +29,9 @@ module Unique (
mkUnique, -- Used in UniqSupply
mkUniqueGrimily, -- Used in UniqSupply only!
+ incrUnique, -- Used for renumbering
+ initRenumberingUniques,
+
-- now all the built-in Uniques (and functions to make them)
-- [the Oh-So-Wonderful Haskell module system wins again...]
mkAlphaTyVarUnique,
@@ -36,6 +39,9 @@ module Unique (
mkTupleDataConUnique,
mkTupleTyConUnique,
+ getBuiltinUniques, mkBuiltinUnique,
+ mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+
absentErrorIdKey, -- alphabetical...
addrDataConKey,
addrPrimTyConKey,
@@ -224,25 +230,19 @@ Now come the functions which construct uniques from their pieces, and vice versa
The stuff about unique *supplies* is handled further down this module.
\begin{code}
-mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
-unpkUnique :: Unique -> (Char, Int) -- The reverse
-
-mkUnifiableTyVarUnique :: Int -> Unique -- Injects a subst-array index into the Unique type
-unpkUnifiableTyVarUnique :: Unique -> Int -- The reverse process
+mkUnique :: Char -> Int -> Unique -- Builds a unique from pieces
+unpkUnique :: Unique -> (Char, Int) -- The reverse
mkUniqueGrimily :: Int# -> Unique -- A trap-door for UniqSupply
+
+incrUnique :: Unique -> Unique
\end{code}
\begin{code}
mkUniqueGrimily x = MkUnique x
-mkUnifiableTyVarUnique i = mkUnique '_'{-MAGIC CHAR-} i
-
-unpkUnifiableTyVarUnique uniq
- = case (unpkUnique uniq) of { (tag, i) ->
- ASSERT(tag == '_'{-MAGIC CHAR-})
- i }
+incrUnique (MkUnique i) = MkUnique (i +# 1#)
-- pop the Char in the top 8 bits of the Unique(Supply)
@@ -375,9 +375,10 @@ chars62
%************************************************************************
Allocation of unique supply characters:
- a-z: lower case chars for unique supplies (see Main.lhs)
- B: builtin (see UniqSupply.lhs)
- C-E: pseudo uniques (see UniqSupply.lhs)
+ v,t,u : for renumbering value-, type- and usage- vars.
+ other a-z: lower case chars for unique supplies (see Main.lhs)
+ B: builtin
+ C-E: pseudo uniques (used in native-code generator)
_: unifiable tyvars (above)
1-8: prelude things below
@@ -393,6 +394,19 @@ mkTupleDataConUnique a = mkUnique '6' a -- ditto (*may* be used in C labels)
mkPrimOpIdUnique op = mkUnique '7' op
mkPreludeMiscIdUnique i = mkUnique '8' i
+
+initRenumberingUniques = (mkUnique 'v' 1, mkUnique 't' 1, mkUnique 'u' 1)
+
+mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+ mkBuiltinUnique :: Int -> Unique
+
+mkBuiltinUnique i = mkUnique 'B' i
+mkPseudoUnique1 i = mkUnique 'C' i -- used for uniqueOf on Regs
+mkPseudoUnique2 i = mkUnique 'D' i -- ditto
+mkPseudoUnique3 i = mkUnique 'E' i -- ditto
+
+getBuiltinUniques :: Int -> [Unique]
+getBuiltinUniques n = map (mkUnique 'B') [1 .. n]
\end{code}
%************************************************************************
diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs
index f7eb45a53908ccea06d255fa7f708eaffe5b1d94..ae7cf40f2ceeeb911ec007fc3559a951a28cf53a 100644
--- a/ghc/compiler/codeGen/ClosureInfo.lhs
+++ b/ghc/compiler/codeGen/ClosureInfo.lhs
@@ -92,7 +92,7 @@ import PprType ( GenType{-instance Outputable-} )
import PrimRep ( getPrimRepSize, separateByPtrFollowness )
import SMRep -- all of it
import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type ( isPrimType, splitForAllTy, splitFunTy, mkFunTys )
+import Type ( isPrimType, splitForAllTy, splitFunTyWithDictsAsArgs, mkFunTys )
import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)"
@@ -1163,7 +1163,7 @@ closureReturnsUnboxedType other_closure = False
fun_result_ty arity id
= let
(_, de_foralld_ty) = splitForAllTy (idType id)
- (arg_tys, res_ty) = splitFunTy{-w/ dicts as args?-} de_foralld_ty
+ (arg_tys, res_ty) = splitFunTyWithDictsAsArgs de_foralld_ty
in
ASSERT(arity >= 0 && length arg_tys >= arity)
mkFunTys (drop arity arg_tys) res_ty
diff --git a/ghc/compiler/coreSyn/AnnCoreSyn.lhs b/ghc/compiler/coreSyn/AnnCoreSyn.lhs
index 9f51e1a4b1c847a0f91b034e4b13f7a701135daa..f1095d8cdd09d546bb1fa6aa7bbe4b22eadf5b15 100644
--- a/ghc/compiler/coreSyn/AnnCoreSyn.lhs
+++ b/ghc/compiler/coreSyn/AnnCoreSyn.lhs
@@ -54,6 +54,10 @@ data AnnCoreExpr' val_bdr val_occ tyvar uvar annot
| AnnSCC CostCentre
(AnnCoreExpr val_bdr val_occ tyvar uvar annot)
+
+ | AnnCoerce Coercion
+ (GenType tyvar uvar)
+ (AnnCoreExpr val_bdr val_occ tyvar uvar annot)
\end{code}
\begin{code}
@@ -83,6 +87,7 @@ deAnnotate (_, AnnPrim op args) = Prim op args
deAnnotate (_, AnnLam binder body)= Lam binder (deAnnotate body)
deAnnotate (_, AnnApp fun arg) = App (deAnnotate fun) arg
deAnnotate (_, AnnSCC lbl body) = SCC lbl (deAnnotate body)
+deAnnotate (_, AnnCoerce c ty body) = Coerce c ty (deAnnotate body)
deAnnotate (_, AnnLet bind body)
= Let (deAnnBind bind) (deAnnotate body)
diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs
index 71383a55ed7ec7dd91792092214a94a9ee154473..381c500629401be53026165ad2572ad541c45ab2 100644
--- a/ghc/compiler/coreSyn/CoreLift.lhs
+++ b/ghc/compiler/coreSyn/CoreLift.lhs
@@ -129,6 +129,10 @@ liftCoreExpr (SCC label expr)
= liftCoreExpr expr `thenL` \ expr ->
returnL (SCC label expr)
+liftCoreExpr (Coerce coerce ty expr)
+ = liftCoreExpr expr `thenL` \ expr ->
+ returnL (Coerce coerce ty expr) -- ToDo:right?:Coerce
+
liftCoreExpr (Let (NonRec binder rhs) body) -- special case: no lifting
= liftCoreExpr rhs `thenL` \ rhs ->
liftCoreExpr body `thenL` \ body ->
diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs
index 0e836879e3f0ed66ca5ded95673e4fea1673183f..e2c826997eb80f1282348993cb649d050f617743 100644
--- a/ghc/compiler/coreSyn/CoreLint.lhs
+++ b/ghc/compiler/coreSyn/CoreLint.lhs
@@ -16,7 +16,7 @@ import Ubiq
import CoreSyn
import Bag
-import Kind ( isSubKindOf, Kind{-instance-} )
+import Kind ( Kind{-instance-} )
import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId,
dataConArgTys, GenId{-instances-}
@@ -184,6 +184,9 @@ lintCoreExpr :: CoreExpr -> LintM (Maybe Type) -- Nothing if error found
lintCoreExpr (Var var) = checkInScope var `seqL` returnL (Just (idType var))
lintCoreExpr (Lit lit) = returnL (Just (literalType lit))
lintCoreExpr (SCC _ expr) = lintCoreExpr expr
+lintCoreExpr (Coerce _ ty expr)
+ = _trace "lintCoreExpr:Coerce" $
+ lintCoreExpr expr `seqL` returnL (Just ty)
lintCoreExpr (Let binds body)
= lintCoreBinding binds `thenL` \binders ->
@@ -222,10 +225,7 @@ lintCoreExpr (Lam (TyBinder tyvar) expr)
lintCoreExpr e@(Case scrut alts)
= lintCoreExpr scrut `thenMaybeL` \ty ->
- -- Check that it is a data type
- case maybeAppDataTyCon ty of
- Nothing -> addErrL (mkCaseDataConMsg e) `seqL` returnL Nothing
- Just(tycon, _, _) -> lintCoreAlts alts ty tycon
+ lintCoreAlts alts ty
\end{code}
%************************************************************************
@@ -281,8 +281,10 @@ lintCoreArg checkTyApp e ty a@(TyArg arg_ty)
tyvar_kind = tyVarKind tyvar
argty_kind = typeKind arg_ty
in
- if (tyvar_kind `isSubKindOf` argty_kind
- || argty_kind `isSubKindOf` tyvar_kind) then
+ if tyvar_kind == argty_kind
+-- SUSPICIOUS! (tyvar_kind `isSubKindOf` argty_kind
+-- || argty_kind `isSubKindOf` tyvar_kind)
+ then
returnL(Just(instantiateTy [(tyvar,arg_ty)] body))
else
pprTrace "lintCoreArg:kinds:" (ppCat [ppr PprDebug tyvar_kind, ppr PprDebug argty_kind]) $
@@ -306,20 +308,20 @@ lintCoreArg _ e ty (UsageArg u)
\begin{code}
lintCoreAlts :: CoreCaseAlts
-> Type -- Type of scrutinee
- -> TyCon -- TyCon pinned on the case
+-- -> TyCon -- TyCon pinned on the case
-> LintM (Maybe Type) -- Type of alternatives
-lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
+lintCoreAlts whole_alts@(AlgAlts alts deflt) ty --tycon
= -- Check tycon is not a primitive tycon
- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
- `seqL`
+-- addErrIfL (isPrimTyCon tycon) (mkCasePrimMsg tycon)
+-- `seqL`
-- Check we are scrutinising a proper datatype
-- (ToDo: robustify)
- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
- `seqL`
+-- addErrIfL (not (tyConFamilySize tycon >= 1)) (mkCaseAbstractMsg tycon)
+-- `seqL`
lintDeflt deflt ty
`thenL` \maybe_deflt_ty ->
- mapL (lintAlgAlt ty tycon) alts
+ mapL (lintAlgAlt ty {-tycon-}) alts
`thenL` \maybe_alt_tys ->
-- Check the result types
case catMaybes (maybe_deflt_ty : maybe_alt_tys) of
@@ -330,10 +332,10 @@ lintCoreAlts whole_alts@(AlgAlts alts deflt) ty tycon
where
check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
-lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
+lintCoreAlts whole_alts@(PrimAlts alts deflt) ty --tycon
= -- Check tycon is a primitive tycon
- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
- `seqL`
+-- addErrIfL (not (isPrimTyCon tycon)) (mkCaseNotPrimMsg tycon)
+-- `seqL`
mapL (lintPrimAlt ty) alts
`thenL` \maybe_alt_tys ->
lintDeflt deflt ty
@@ -347,7 +349,7 @@ lintCoreAlts whole_alts@(PrimAlts alts deflt) ty tycon
where
check ty = checkTys first_ty ty (mkCaseAltMsg whole_alts)
-lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
+lintAlgAlt scrut_ty {-tycon-ToDo: use it!-} (con,args,rhs)
= (case maybeAppDataTyCon scrut_ty of
Nothing ->
addErrL (mkAlgAltMsg1 scrut_ty)
diff --git a/ghc/compiler/coreSyn/CoreSyn.lhs b/ghc/compiler/coreSyn/CoreSyn.lhs
index 4d8284d4d364b75dca92b130b7bbe14376e4f724..c816aa1881ee59078af6559832ea70fc5c7d1e04 100644
--- a/ghc/compiler/coreSyn/CoreSyn.lhs
+++ b/ghc/compiler/coreSyn/CoreSyn.lhs
@@ -10,6 +10,7 @@ module CoreSyn (
GenCoreBinding(..), GenCoreExpr(..),
GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
GenCoreCaseDefault(..),
+ Coercion(..),
bindersOf, pairsFromCoreBinds, rhssOfBind,
@@ -182,6 +183,21 @@ transformations of which we are unaware.
(GenCoreExpr val_bdr val_occ tyvar uvar) -- scc expression
\end{code}
+Coercions arise from uses of the constructor of a @newtype@
+declaration, either in construction (resulting in a @CoreceIn@) or
+pattern matching (resulting in a @CoerceOut@).
+
+\begin{code}
+ | Coerce Coercion
+ (GenType tyvar uvar) -- Type of the whole expression
+ (GenCoreExpr val_bdr val_occ tyvar uvar)
+\end{code}
+
+\begin{code}
+data Coercion = CoerceIn Id -- Apply this constructor
+ | CoerceOut Id -- Strip this constructor
+\end{code}
+
%************************************************************************
%* *
@@ -484,32 +500,21 @@ collectArgs :: GenCoreExpr val_bdr val_occ tyvar uvar
[GenCoreArg val_occ tyvar uvar]{-ValArgs-})
collectArgs expr
- = usages expr []
+ = valvars expr []
where
- usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
- usages fun uacc
- = case (tyvars fun []) of { (expr, tacc, vacc) ->
+ valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
+ valvars fun vacc
+ = case (tyvars fun []) of { (expr, uacc, tacc) ->
(expr, uacc, tacc, vacc) }
tyvars (App fun (TyArg t)) tacc = tyvars fun (t:tacc)
tyvars fun tacc
- = ASSERT(not (usage_app fun))
- case (valvars fun []) of { (expr, vacc) ->
- (expr, tacc, vacc) }
-
- valvars (App fun v) vacc | isValArg v = valvars fun (v:vacc)
- valvars fun vacc
- = --ASSERT(not (usage_app fun))
- --ASSERT(not (ty_app fun))
- (if (usage_app fun || ty_app fun) then trace "CoreSyn:valvars" {-(ppr PprDebug fun)-} else id) $
- (fun, vacc)
-
- ---------------------------------------
- usage_app (App _ (UsageArg _)) = True
- usage_app _ = False
+ = case (usages fun []) of { (expr, uacc) ->
+ (expr, uacc, tacc) }
- ty_app (App _ (TyArg _)) = True
- ty_app _ = False
+ usages (App fun (UsageArg u)) uacc = usages fun (u:uacc)
+ usages fun uacc
+ = (fun,uacc)
\end{code}
%************************************************************************
diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs
index 146b1f31c47545eb5a2d78e67300557f0eca8f3b..39893059856b1fba1a22d2f1a847b948ffe22cf1 100644
--- a/ghc/compiler/coreSyn/CoreUnfold.lhs
+++ b/ghc/compiler/coreSyn/CoreUnfold.lhs
@@ -78,7 +78,7 @@ data UnfoldingDetails
| ConForm
Id -- The constructor
- [CoreArg] -- Value arguments; NB OutArgs, already cloned
+ [CoreArg] -- Type/value arguments; NB OutArgs, already cloned
| OtherConForm
[Id] -- It definitely isn't one of these constructors
@@ -289,6 +289,8 @@ sizeExpr scc_s_OK bOMB_OUT_SIZE args expr
size_up (SCC lbl body)
= if scc_s_OK then size_up body else Nothing
+ size_up (Coerce _ _ body) = size_up body
+
size_up (Con con args) = -- 1 + # of val args
sizeN (1 + numValArgs args)
size_up (Prim op args) = sizeN op_cost -- NB: no charge for PrimOp args
@@ -582,6 +584,8 @@ ment_expr (SCC cc expr)
)
`thenUf_` ment_expr expr
+ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce"
+
-------------
ment_ty ty
= let
@@ -739,6 +743,8 @@ ppr_uf_Expr in_scopes (SCC cc body)
= ASSERT(not (noCostCentreAttached cc))
ASSERT(not (currentOrSubsumedCosts cc))
ppBesides [ppStr "_scc_ { ", ppStr (showCostCentre ppr_Unfolding False{-not as string-} cc), ppStr " } ", ppr_uf_Expr in_scopes body]
+
+ppr_uf_Expr in_scopes (Coerce _ _ _) = panic "ppr_uf_Expr:Coerce"
\end{code}
\begin{code}
diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs
index d3afc57ce04d04a2a02a8d85738a47a67c51920f..3721baaaf9d468d0d77932c5a5ed0e4e499d5ed3 100644
--- a/ghc/compiler/coreSyn/CoreUtils.lhs
+++ b/ghc/compiler/coreSyn/CoreUtils.lhs
@@ -18,7 +18,8 @@ module CoreUtils (
, maybeErrorApp
, nonErrorRHSs
, squashableDictishCcExpr
-{- exprSmallEnoughToDup,
+ , exprSmallEnoughToDup
+{-
coreExprArity,
isWrapperFor,
@@ -45,7 +46,7 @@ import Pretty ( ppAboves )
import PrelInfo ( trueDataCon, falseDataCon,
augmentId, buildId
)
-import PrimOp ( primOpType, PrimOp(..) )
+import PrimOp ( primOpType, fragilePrimOp, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
import TyVar ( isNullTyVarEnv, TyVarEnv(..) )
import Type ( mkFunTys, mkForAllTy, mkForAllUsageTy, mkTyVarTy,
@@ -80,6 +81,8 @@ coreExprType (Let _ body) = coreExprType body
coreExprType (SCC _ expr) = coreExprType expr
coreExprType (Case _ alts) = coreAltsType alts
+coreExprType (Coerce _ ty _) = ty -- that's the whole point!
+
-- a Con is a fully-saturated application of a data constructor
-- a Prim is <ditto> of a PrimOp
@@ -129,8 +132,12 @@ default_ty (BindDefault _ rhs) = coreExprType rhs
\end{code}
\begin{code}
-applyTypeToArgs op_ty args
- = foldl applyTy op_ty [ ty | TyArg ty <- args ]
+applyTypeToArgs op_ty args = foldl applyTypeToArg op_ty args
+
+applyTypeToArg op_ty (TyArg ty) = applyTy op_ty ty
+applyTypeToArg op_ty (UsageArg _) = panic "applyTypeToArg: UsageArg"
+applyTypeToArg op_ty val_or_lit_arg = case (getFunTy_maybe op_ty) of
+ Just (_, res_ty) -> res_ty
\end{code}
%************************************************************************
@@ -205,13 +212,18 @@ argToExpr (LitArg lit) = Lit lit
\end{code}
\begin{code}
-{- LATER:
-exprSmallEnoughToDup :: GenCoreExpr binder Id -> Bool
-
-exprSmallEnoughToDup (Con _ _ _) = True -- Could check # of args
-exprSmallEnoughToDup (Prim op _ _) = not (fragilePrimOp op) -- Could check # of args
-exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
+exprSmallEnoughToDup (Con _ _) = True -- Could check # of args
+exprSmallEnoughToDup (Prim op _) = not (fragilePrimOp op) -- Could check # of args
+exprSmallEnoughToDup (Lit lit) = not (isNoRepLit lit)
+exprSmallEnoughToDup expr
+ = case (collectArgs expr) of { (fun, _, _, vargs) ->
+ case fun of
+ Var v | length vargs == 0 -> True
+ _ -> False
+ }
+{- LATER:
+WAS: MORE CLEVER:
exprSmallEnoughToDup expr -- for now, just: <var> applied to <args>
= case (collectArgs expr) of { (fun, _, _, vargs) ->
case fun of
@@ -233,12 +245,13 @@ left something out... [WDP]
\begin{code}
manifestlyWHNF :: GenCoreExpr bndr Id tyvar uvar -> Bool
-manifestlyWHNF (Var _) = True
-manifestlyWHNF (Lit _) = True
-manifestlyWHNF (Con _ _) = True
-manifestlyWHNF (SCC _ e) = manifestlyWHNF e
-manifestlyWHNF (Let _ e) = False
-manifestlyWHNF (Case _ _) = False
+manifestlyWHNF (Var _) = True
+manifestlyWHNF (Lit _) = True
+manifestlyWHNF (Con _ _) = True
+manifestlyWHNF (SCC _ e) = manifestlyWHNF e
+manifestlyWHNF (Coerce _ _ e) = _trace "manifestlyWHNF:Coerce" $ manifestlyWHNF e
+manifestlyWHNF (Let _ e) = False
+manifestlyWHNF (Case _ _) = False
manifestlyWHNF (Lam x e) = if isValBinder x then True else manifestlyWHNF e
@@ -268,12 +281,13 @@ some point. It isn't a disaster if it errs on the conservative side
\begin{code}
manifestlyBottom :: GenCoreExpr bndr Id tyvar uvar -> Bool
-manifestlyBottom (Var v) = isBottomingId v
-manifestlyBottom (Lit _) = False
-manifestlyBottom (Con _ _) = False
-manifestlyBottom (Prim _ _) = False
-manifestlyBottom (SCC _ e) = manifestlyBottom e
-manifestlyBottom (Let _ e) = manifestlyBottom e
+manifestlyBottom (Var v) = isBottomingId v
+manifestlyBottom (Lit _) = False
+manifestlyBottom (Con _ _) = False
+manifestlyBottom (Prim _ _) = False
+manifestlyBottom (SCC _ e) = manifestlyBottom e
+manifestlyBottom (Coerce _ _ e) = _trace "manifestlyBottom:Coerce" $ manifestlyBottom e
+manifestlyBottom (Let _ e) = manifestlyBottom e
-- We do not assume \x.bottom == bottom:
manifestlyBottom (Lam x e) = if isValBinder x then False else manifestlyBottom e
@@ -413,6 +427,7 @@ bop_expr f (Prim op args) = Prim op args
bop_expr f (Lam binder expr) = Lam (bop_binder f binder) (bop_expr f expr)
bop_expr f (App expr arg) = App (bop_expr f expr) arg
bop_expr f (SCC label expr) = SCC label (bop_expr f expr)
+bop_expr f (Coerce c ty e) = Coerce c ty (bop_expr f e)
bop_expr f (Let bind expr) = Let (bop_bind f bind) (bop_expr f expr)
bop_expr f (Case expr alts) = Case (bop_expr f expr) (bop_alts f alts)
@@ -768,4 +783,8 @@ do_CoreExpr venv tenv (Let core_bind expr)
do_CoreExpr venv tenv (SCC label expr)
= do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
returnUs (SCC label new_expr)
+
+do_CoreExpr venv tenv (Coerce c ty expr)
+ = do_CoreExpr venv tenv expr `thenUs` \ new_expr ->
+ returnUs (Coerce c (applyTypeEnvToTy tenv ty) new_expr)
\end{code}
diff --git a/ghc/compiler/coreSyn/FreeVars.lhs b/ghc/compiler/coreSyn/FreeVars.lhs
index 8703b34dfa0c867405e0cedaa36fa2a132983710..e6987a826f0f8108a6d218f1d642b50311177c73 100644
--- a/ghc/compiler/coreSyn/FreeVars.lhs
+++ b/ghc/compiler/coreSyn/FreeVars.lhs
@@ -295,6 +295,15 @@ fvExpr id_cands tyvar_cands (SCC label expr)
= (fvinfo, AnnSCC label expr2)
where
expr2@(fvinfo,_) = fvExpr id_cands tyvar_cands expr
+
+fvExpr id_cands tyvar_cands (Coerce c ty expr)
+ = (FVInfo (freeVarsOf expr2)
+ (freeTyVarsOf expr2 `combine` tfvs)
+ (leakinessOf expr2),
+ AnnCoerce c ty expr2)
+ where
+ expr2 = fvExpr id_cands tyvar_cands expr
+ tfvs = freeTy tyvar_cands ty
\end{code}
\begin{code}
@@ -477,6 +486,11 @@ addExprFVs fv_cand in_scope (SCC label expr)
= (SCC label expr2, expr_fvs)
where
(expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
+
+addExprFVs fv_cand in_scope (Coerce c ty expr)
+ = (Coerce c ty expr2, expr_fvs)
+ where
+ (expr2, expr_fvs) = addExprFVs fv_cand in_scope expr
\end{code}
\begin{code}
diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs
index 2aff67f223293ed973012b21c8b97160b4da877a..ed00cac6202037d8bda50466cbfc896ab043ef51 100644
--- a/ghc/compiler/coreSyn/PprCore.lhs
+++ b/ghc/compiler/coreSyn/PprCore.lhs
@@ -296,6 +296,13 @@ ppr_expr pe (Let bind expr)
ppr_expr pe (SCC cc expr)
= ppSep [ppCat [ppPStr SLIT("_scc_"), pSCC pe cc],
ppr_parend_expr pe expr ]
+
+ppr_expr pe (Coerce c ty expr)
+ = ppSep [ppCat [ppPStr SLIT("_coerce_"), pp_coerce c],
+ pTy pe ty, ppr_parend_expr pe expr ]
+ where
+ pp_coerce (CoerceIn v) = ppBeside (ppStr "{-in-}") (ppr (pStyle pe) v)
+ pp_coerce (CoerceOut v) = ppBeside (ppStr "{-out-}") (ppr (pStyle pe) v)
\end{code}
\begin{code}
diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs
index a9c4ffcfdd9d804a3951831f7b9883103b04281b..db63f509582b650678c865e08e99029e162dd527 100644
--- a/ghc/compiler/deSugar/DsExpr.lhs
+++ b/ghc/compiler/deSugar/DsExpr.lhs
@@ -45,8 +45,11 @@ import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon,
rEC_UPD_ERROR_ID
)
import Pretty ( ppShow, ppBesides, ppPStr, ppStr )
-import Type ( splitSigmaTy, splitFunTy, typePrimRep, getAppDataTyCon )
-import TyVar ( GenTyVar, nullTyVarEnv, addOneToTyVarEnv )
+import TyCon ( isDataTyCon, isNewTyCon )
+import Type ( splitSigmaTy, splitFunTy, typePrimRep,
+ getAppDataTyCon, getAppTyCon, applyTy
+ )
+import TyVar ( nullTyVarEnv, addOneToTyVarEnv, GenTyVar{-instance Eq-} )
import Usage ( UVar(..) )
import Util ( zipEqual, pprError, panic, assertPanic )
@@ -308,10 +311,23 @@ dsExpr (ExplicitTuple expr_list)
(map coreExprType core_exprs)
core_exprs
+-- Two cases, one for ordinary constructors and one for newtype constructors
dsExpr (HsCon con tys args)
+ | isDataTyCon tycon -- The usual datatype case
= mapDs dsExpr args `thenDs` \ args_exprs ->
mkConDs con tys args_exprs
+ | otherwise -- The newtype case
+ = ASSERT( isNewTyCon tycon )
+ ASSERT( null rest_args )
+ dsExpr first_arg `thenDs` \ arg_expr ->
+ returnDs (Coerce (CoerceIn con) result_ty arg_expr)
+
+ where
+ (first_arg:rest_args) = args
+ (args_tys, result_ty) = splitFunTy (foldl applyTy (idType con) tys)
+ (tycon,_) = getAppTyCon result_ty
+
dsExpr (ArithSeqOut expr (From from))
= dsExpr expr `thenDs` \ expr2 ->
dsExpr from `thenDs` \ from2 ->
diff --git a/ghc/compiler/deSugar/DsHsSyn.lhs b/ghc/compiler/deSugar/DsHsSyn.lhs
index 3d1205982d6857de3a878c676ee8a5592e9ce707..8fae20c9e89e47f3ea169d6919ad08d66d6ca575 100644
--- a/ghc/compiler/deSugar/DsHsSyn.lhs
+++ b/ghc/compiler/deSugar/DsHsSyn.lhs
@@ -36,10 +36,12 @@ outPatType (TuplePat pats) = mkTupleTy (length pats) (map outPatType pats)
outPatType (RecPat _ ty _) = ty
outPatType (LitPat lit ty) = ty
outPatType (NPat lit ty _) = ty
-outPatType (DictPat ds ms) = case (length ds + length ms) of
+outPatType (DictPat ds ms) = case (length ds_ms) of
0 -> unitTy
- 1 -> idType (head (ds ++ ms))
- n -> mkTupleTy n (map idType (ds ++ ms))
+ 1 -> idType (head ds_ms)
+ n -> mkTupleTy n (map idType ds_ms)
+ where
+ ds_ms = ds ++ ms
\end{code}
@@ -71,6 +73,7 @@ collectTypedPatBinders (ConPat _ _ pats) = concat (map collectTypedPatBinders
collectTypedPatBinders (ConOpPat p1 _ p2 _) = collectTypedPatBinders p1 ++ collectTypedPatBinders p2
collectTypedPatBinders (ListPat t pats) = concat (map collectTypedPatBinders pats)
collectTypedPatBinders (TuplePat pats) = concat (map collectTypedPatBinders pats)
+collectTypedPatBinders (RecPat _ _ fields) = concat (map (\ (f,pat,_) -> collectTypedPatBinders pat) fields)
collectTypedPatBinders (DictPat ds ms) = ds ++ ms
collectTypedPatBinders any_other_pat = [ {-no binders-} ]
\end{code}
diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs
index eeb8f26fc4ce9a45cbaa2a55828357217efbf71e..c4a46e2e3d2ce8132d2bff901efe50c1ef72e1ad 100644
--- a/ghc/compiler/deSugar/DsUtils.lhs
+++ b/ghc/compiler/deSugar/DsUtils.lhs
@@ -46,9 +46,10 @@ import Id ( idType, dataConArgTys, mkTupleCon,
pprId{-ToDo:rm-},
DataCon(..), DictVar(..), Id(..), GenId )
import Literal ( Literal(..) )
-import TyCon ( mkTupleTyCon )
+import TyCon ( mkTupleTyCon, isNewTyCon, tyConDataCons )
import Type ( mkTyVarTys, mkRhoTy, mkForAllTys, mkFunTys,
- isUnboxedType, applyTyCon, getAppDataTyCon
+ isUnboxedType, applyTyCon,
+ getAppDataTyCon, getAppTyCon
)
import UniqSet ( mkUniqSet, minusUniqSet, uniqSetToList, UniqSet(..) )
import Util ( panic, assertPanic, pprTrace{-ToDo:rm-} )
@@ -138,6 +139,11 @@ mkCoAlgCaseMatchResult :: Id -- Scrutinee
-> DsM MatchResult
mkCoAlgCaseMatchResult var alts
+ | isNewTyCon tycon -- newtype case; use a let
+ = ASSERT( newtype_sanity )
+ returnDs (mkCoLetsMatchResult [coercion_bind] match_result)
+
+ | otherwise -- datatype case
= -- Find all the constructors in the type which aren't
-- explicitly mentioned in the alternatives:
case un_mentioned_constructors of
@@ -171,8 +177,21 @@ mkCoAlgCaseMatchResult var alts
(mk_case alts (\fail_expr -> BindDefault wild fail_expr))
cxt1)
where
+ -- Common stuff
scrut_ty = idType var
- (tycon, tycon_arg_tys, data_cons) = pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $ getAppDataTyCon scrut_ty
+ (tycon, tycon_arg_tys) = --pprTrace "CoAlgCase:" (pprType PprDebug scrut_ty) $
+ getAppTyCon scrut_ty
+
+ -- Stuff for newtype
+ (con_id, arg_ids, match_result) = head alts
+ arg_id = head arg_ids
+ coercion_bind = NonRec arg_id (Coerce (CoerceOut con_id)
+ (idType arg_id)
+ (Var var))
+ newtype_sanity = null (tail alts) && null (tail arg_ids)
+
+ -- Stuff for data types
+ data_cons = tyConDataCons tycon
un_mentioned_constructors
= uniqSetToList (mkUniqSet data_cons `minusUniqSet` mkUniqSet [ con | (con, _, _) <- alts] )
diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs
index fd4bb5dfcef84b1d76f589a3da5435202610b554..5f1b90d4a215d95e9ee498535f33cc717628bce8 100644
--- a/ghc/compiler/deSugar/Match.lhs
+++ b/ghc/compiler/deSugar/Match.lhs
@@ -334,7 +334,7 @@ tidy1 v (RecPat con_id pat_ty rpats) match_result
pats = map mk_pat tagged_arg_tys
-- Boring stuff to find the arg-tys of the constructor
- (_, inst_tys, _) = _trace "getAppDataTyCon.Match" $ getAppDataTyCon pat_ty
+ (_, inst_tys, _) = {-_trace "getAppDataTyCon.Match" $-} getAppDataTyCon pat_ty
con_arg_tys' = dataConArgTys con_id inst_tys
tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags
@@ -513,21 +513,24 @@ matchUnmixedEqns :: [Id]
matchUnmixedEqns [] _ _ = panic "matchUnmixedEqns: no names"
matchUnmixedEqns all_vars@(var:vars) eqns_info shadows
- | unfailablePats column_1_pats -- Could check just one; we know they've been tidied, unmixed;
- -- this way is (arguably) a sanity-check
- = -- Real true variables, just like in matchVar, SLPJ p 94
+ | unfailablePat first_pat
+ = ASSERT( unfailablePats column_1_pats ) -- Sanity check
+ -- Real true variables, just like in matchVar, SLPJ p 94
match vars remaining_eqns_info remaining_shadows
- | patsAreAllCons column_1_pats -- ToDo: maybe check just one...
- = matchConFamily all_vars eqns_info shadows
+ | isConPat first_pat
+ = ASSERT( patsAreAllCons column_1_pats )
+ matchConFamily all_vars eqns_info shadows
- | patsAreAllLits column_1_pats -- ToDo: maybe check just one...
- = -- see notes in MatchLiteral
+ | isLitPat first_pat
+ = ASSERT( patsAreAllLits column_1_pats )
+ -- see notes in MatchLiteral
-- not worried about the same literal more than once in a column
-- (ToDo: sort this out later)
matchLiterals all_vars eqns_info shadows
where
+ first_pat = head column_1_pats
column_1_pats = [pat | EqnInfo (pat:_) _ <- eqns_info]
remaining_eqns_info = [EqnInfo pats match_result | EqnInfo (_:pats) match_result <- eqns_info]
remaining_shadows = [EqnInfo pats match_result | EqnInfo (pat:pats) match_result <- shadows,
diff --git a/ghc/compiler/deforest/Core2Def.lhs b/ghc/compiler/deforest/Core2Def.lhs
index b6bfea937ad66db90498a2d1ddb171a58e19675a..2739c6e6e972e2340ea9b5cd84f729db83ee2dac 100644
--- a/ghc/compiler/deforest/Core2Def.lhs
+++ b/ghc/compiler/deforest/Core2Def.lhs
@@ -115,6 +115,7 @@ ToDo:
> where recBind2def ((v,_),e) = (v, c2d p e)
>
> SCC l e -> SCC l (c2d p e)
+> Coerce _ _ _ -> panic "Core2Def:Coerce"
> coreCaseAlts2def
diff --git a/ghc/compiler/deforest/Def2Core.lhs b/ghc/compiler/deforest/Def2Core.lhs
index 6660f31c7ad49ed265a2615ebeb9cb9f228bebaf..d8267e4032b510d0267b8de7145e27cf3b2c0339 100644
--- a/ghc/compiler/deforest/Def2Core.lhs
+++ b/ghc/compiler/deforest/Def2Core.lhs
@@ -113,6 +113,8 @@
> SCC l e ->
> d2c e `thenUs` \e' ->
> returnUs (SCC l e')
+> Coerce _ _ _ ->
+> panic "Def2Core:Coerce"
> defCaseAlts2Core :: DefCaseAlternatives
> -> UniqSM CoreCaseAlts
diff --git a/ghc/compiler/deforest/DefExpr.lhs b/ghc/compiler/deforest/DefExpr.lhs
index 5cfd349b640b445c8c5031963dbc9710c4c7e941..22993716404709b5054b66ccd4d4167bd130bd62 100644
--- a/ghc/compiler/deforest/DefExpr.lhs
+++ b/ghc/compiler/deforest/DefExpr.lhs
@@ -127,6 +127,9 @@ This is extended by one rule only: reduction of a type application.
> mapArgs (\e -> tran sw p t e []) as `thenUs` \as ->
> returnUs (mkGenApp (SCC l e) as)
>
+> tran sw p t (Coerce c ty e) as =
+> panic "DefExpr:tran:Coerce"
+>
> tran sw p t (Case e ps) as =
> tranCase sw p t e [] ps as
>
@@ -246,6 +249,8 @@ Transformation for case expressions of the form (case e1..en of {..})
> returnUs (Case (mkGenApp (SCC l e) bs)
> ps)
>
+> Coerce _ _ _ -> panic "DefExpr:tranCase:Coerce"
+>
> Case e ps' ->
> tranCase sw p t e []
> (mapAlts (\e -> mkGenApp (Case e ps) bs) ps') as
@@ -502,6 +507,7 @@ Type Substitutions.
> Let (Rec (map substTyRecBind bs)) (substTy e)
> where substTyRecBind (v,e) = (applyTypeEnvToId p v, substTy e)
> SCC l e -> SCC l (substTy e)
+> Coerce _ _ _ -> panic "DefExpr:applyTypeEnvToExpr:Coerce"
> substTyAtom :: DefAtom -> DefAtom
> substTyAtom (VarArg v) = VarArg (substTyArg v)
diff --git a/ghc/compiler/deforest/DefUtils.lhs b/ghc/compiler/deforest/DefUtils.lhs
index 2170ecacebfad808fa0b9ebc9fcffa61cf3dda96..2a8edc9b501c741f7e304eb256ccb8b595ebbf2d 100644
--- a/ghc/compiler/deforest/DefUtils.lhs
+++ b/ghc/compiler/deforest/DefUtils.lhs
@@ -61,6 +61,7 @@ its left hand side. The result is a term with no labels.
> Let (Rec bs) e ->
> Let (Rec [ (v, strip e) | (v,e) <- bs ]) (strip e)
> SCC l e -> SCC l (strip e)
+> Coerce _ _ _ -> panic "DefUtils:strip:Coerce"
> stripAtom :: DefAtom -> DefAtom
> stripAtom (VarArg v) = VarArg (stripArg v)
@@ -113,6 +114,7 @@ but l is guranteed to be finite so we choose that one.
> Let (Rec bs) e -> free' vs (foldr free (free e fvs) es)
> where (vs,es) = unzip bs
> SCC l e -> free e fvs
+> Coerce _ _ _ -> panic "DefUtils.freeVars:Coerce"
> free' :: [Id] -> [Id] -> [Id]
> free' vs fvs = filter (\x -> notElem x vs) fvs
@@ -157,6 +159,7 @@ but l is guranteed to be finite so we choose that one.
> Let (NonRec v e) e' -> free e (freeId v (free e' tvs))
> Let (Rec bs) e -> foldr freeBind (free e tvs) bs
> SCC l e -> free e tvs
+> Coerce _ _ _ -> panic "DefUtils.freeTyVars:Coerce"
>
> freeId id tvs = tyVarsOfType (idType id) `union` tvs
> freeTy t tvs = tyVarsOfType t `union` tvs
@@ -282,6 +285,7 @@ with new uniques. Free variables are left unchanged.
> uniqueExpr p t e `thenUs` \e ->
> returnUs (SCC l e)
>
+> Coerce _ _ _ -> panic "DefUtils.uniqueExpr:Coerce"
>
> uniqueAtom :: IdEnv Id -> TypeEnv -> DefAtom -> UniqSM DefAtom
> uniqueAtom p t (LitArg l) = returnUs (LitArg l) -- XXX
@@ -571,6 +575,8 @@ Substitutions.
> returnUs (v,e)
> SCC l e -> sub e `thenUs` \e ->
> returnUs (SCC l e)
+>
+> Coerce _ _ _ -> panic "DefUtils.subst:Coerce"
> substAtom (VarArg v) =
> substArg v `thenUs` \v ->
diff --git a/ghc/compiler/deforest/TreelessForm.lhs b/ghc/compiler/deforest/TreelessForm.lhs
index 2526a5795c688f3416ea826af79b6049c5947143..279130ae906d2ec04ef5054042dec681088ffe19 100644
--- a/ghc/compiler/deforest/TreelessForm.lhs
+++ b/ghc/compiler/deforest/TreelessForm.lhs
@@ -119,6 +119,8 @@ ToDo: make this better.
> SCC l e ->
> convExpr e `thenUs` \e ->
> returnUs (SCC l e)
+>
+> Coerce _ _ _ -> panic "TreelessForm:convExpr:Coerce"
Mark all the recursive functions as deforestable. Might as well,
since they will be in treeless form anyway. This helps to cope with
diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs
index bc64534af4933ff1c196076cb69e0cf9c511aae1..5ad5ee52695e184fd27cdb200d518c7529f594fc 100644
--- a/ghc/compiler/hsSyn/HsExpr.lhs
+++ b/ghc/compiler/hsSyn/HsExpr.lhs
@@ -19,7 +19,7 @@ import HsTypes ( PolyType )
-- others:
import Id ( DictVar(..), GenId, Id(..) )
-import Name ( isSymLexeme, pprSym )
+import Name ( pprNonSym, pprSym )
import Outputable ( interppSP, interpp'SP, ifnotPprForUser )
import PprType ( pprGenType, pprParendGenType, GenType{-instance-} )
import Pretty
@@ -197,8 +197,7 @@ instance (NamedThing id, Outputable id, Outputable pat,
\end{code}
\begin{code}
-pprExpr sty (HsVar v)
- = (if (isSymLexeme v) then ppParens else id) (ppr sty v)
+pprExpr sty (HsVar v) = pprNonSym sty v
pprExpr sty (HsLit lit) = ppr sty lit
pprExpr sty (HsLitOut lit _) = ppr sty lit
diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs
index d7efe59e66e30f7cb6ecda12c9b7c57d8394fde6..c5d2d29824dec7a76d7cf7fd944026ad45f78485 100644
--- a/ghc/compiler/hsSyn/HsPat.lhs
+++ b/ghc/compiler/hsSyn/HsPat.lhs
@@ -62,7 +62,7 @@ data InPat name
[(name, InPat name, Bool)] -- True <=> source used punning
data OutPat tyvar uvar id
- = WildPat (GenType tyvar uvar) -- wild card
+ = WildPat (GenType tyvar uvar) -- wild card
| VarPat id -- variable (type is in the Id)
@@ -73,7 +73,7 @@ data OutPat tyvar uvar id
| ConPat Id -- Constructor is always an Id
(GenType tyvar uvar) -- the type of the pattern
- [(OutPat tyvar uvar id)]
+ [OutPat tyvar uvar id]
| ConOpPat (OutPat tyvar uvar id) -- just a special case...
Id
@@ -81,9 +81,9 @@ data OutPat tyvar uvar id
(GenType tyvar uvar)
| ListPat -- syntactic list
(GenType tyvar uvar) -- the type of the elements
- [(OutPat tyvar uvar id)]
+ [OutPat tyvar uvar id]
- | TuplePat [(OutPat tyvar uvar id)] -- tuple
+ | TuplePat [OutPat tyvar uvar id] -- tuple
-- UnitPat is TuplePat []
| RecPat Id -- record constructor
@@ -150,7 +150,7 @@ pprInPat sty (ParPatIn pat)
pprInPat sty (ListPatIn pats)
= ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
pprInPat sty (TuplePatIn pats)
- = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
+ = ppParens (interpp'SP sty pats)
pprInPat sty (RecPatIn con rpats)
= ppBesides [ppr sty con, ppSP, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
@@ -188,7 +188,7 @@ pprOutPat sty (ConOpPat pat1 op pat2 ty)
pprOutPat sty (ListPat ty pats)
= ppBesides [ppLbrack, interpp'SP sty pats, ppRbrack]
pprOutPat sty (TuplePat pats)
- = ppBesides [ppLparen, interpp'SP sty pats, ppRparen]
+ = ppParens (interpp'SP sty pats)
pprOutPat sty (RecPat con ty rpats)
= ppBesides [ppr sty con, ppChar '{', ppInterleave ppComma (map (pp_rpat sty) rpats), ppChar '}']
@@ -254,6 +254,7 @@ isConPat (ConPat _ _ _) = True
isConPat (ConOpPat _ _ _ _) = True
isConPat (ListPat _ _) = True
isConPat (TuplePat _) = True
+isConPat (RecPat _ _ _) = True
isConPat (DictPat ds ms) = (length ds + length ms) > 1
isConPat other = False
@@ -275,8 +276,9 @@ irrefutablePat (WildPat _) = True
irrefutablePat (VarPat _) = True
irrefutablePat (LazyPat _) = True
irrefutablePat (AsPat _ pat) = irrefutablePat pat
-irrefutablePat (ConPat con tys pats) = all irrefutablePat pats && only_con con
-irrefutablePat (ConOpPat pat1 con pat2 _) = irrefutablePat pat1 && irrefutablePat pat1 && only_con con
+irrefutablePat (ConPat con tys pats) = only_con con && all irrefutablePat pats
+irrefutablePat (ConOpPat pat1 con pat2 _) = only_con con && irrefutablePat pat1 && irrefutablePat pat1
+irrefutablePat (RecPat con _ fields) = only_con con && and [ irrefutablePat pat | (_,pat,_) <- fields ]
irrefutablePat (ListPat _ _) = False
irrefutablePat (TuplePat pats) = all irrefutablePat pats
irrefutablePat (DictPat _ _) = True
@@ -295,6 +297,7 @@ collectPatBinders :: InPat a -> [a]
collectPatBinders WildPatIn = []
collectPatBinders (VarPatIn var) = [var]
+collectPatBinders (LitPatIn _) = []
collectPatBinders (LazyPatIn pat) = collectPatBinders pat
collectPatBinders (AsPatIn a pat) = a : collectPatBinders pat
collectPatBinders (ConPatIn c pats) = concat (map collectPatBinders pats)
diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs
index ef89a619c4ed529d737ac55a94dcd6916add2cfb..235fb4ada8a2c0cf6c7da582fa11163ba89790d1 100644
--- a/ghc/compiler/main/Main.lhs
+++ b/ghc/compiler/main/Main.lhs
@@ -80,7 +80,7 @@ doIt (core_cmds, stg_cmds) input_pgm
-- UniqueSupplies for later use (these are the only lower case uniques)
mkSplitUniqSupply 'r' >>= \ rn_uniqs -> -- renamer
- mkSplitUniqSupply 't' >>= \ tc_uniqs -> -- typechecker
+ mkSplitUniqSupply 'a' >>= \ tc_uniqs -> -- typechecker
mkSplitUniqSupply 'd' >>= \ ds_uniqs -> -- desugarer
mkSplitUniqSupply 's' >>= \ sm_uniqs -> -- core-to-core simplifier
mkSplitUniqSupply 'c' >>= \ c2s_uniqs -> -- core-to-stg
diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs
index 9128954bb618631612a422c2faf5dfcbcff59959..aee025fa1e7bccaa89dd63256e682422b7a53796 100644
--- a/ghc/compiler/main/MkIface.lhs
+++ b/ghc/compiler/main/MkIface.lhs
@@ -6,32 +6,64 @@
\begin{code}
#include "HsVersions.h"
-module MkIface {-( mkInterface )-} where
+module MkIface (
+ startIface, endIface,
+ ifaceVersions,
+ ifaceExportList,
+ ifaceFixities,
+ ifaceInstanceModules,
+ ifaceDecls,
+ ifaceInstances,
+ ifacePragmas
+ ) where
import Ubiq{-uitous-}
import Bag ( emptyBag, snocBag, bagToList )
-import Class ( GenClass{-instance NamedThing-} )
+import Class ( GenClass(..){-instance NamedThing-}, GenClassOp(..) )
import CmdLineOpts ( opt_ProduceHi )
+import FieldLabel ( FieldLabel{-instance NamedThing-} )
import HsSyn
-import Id ( GenId{-instance NamedThing/Outputable-} )
-import Name ( nameOrigName, origName,
+import Id ( idType, dataConSig, dataConFieldLabels,
+ dataConStrictMarks, StrictnessMark(..),
+ GenId{-instance NamedThing/Outputable-}
+ )
+import Name ( nameOrigName, origName, nameOf,
exportFlagOn, nameExportFlag, ExportFlag(..),
- ltLexical, isExported,
- RdrName{-instance Outputable-}
+ ltLexical, isExported, getExportFlag,
+ isLexSym, isLocallyDefined,
+ RdrName(..){-instance Outputable-},
+ Name{-instance NamedThing-}
)
+import PprEnv -- not sure how much...
import PprStyle ( PprStyle(..) )
-import PprType ( pprType, TyCon{-instance Outputable-}, GenClass{-ditto-} )
+import PprType -- most of it (??)
import Pretty -- quite a bit
import RnHsSyn ( RenamedHsModule(..), RnName{-instance NamedThing-} )
import RnIfaces ( VersionInfo(..) )
import TcModule ( TcIfaceInfo(..) )
import TcInstUtil ( InstInfo(..) )
-import TyCon ( TyCon{-instance NamedThing-} )
+import TyCon ( TyCon(..){-instance NamedThing-}, NewOrData(..) )
import Type ( mkSigmaTy, mkDictTy, getAppTyCon )
-import Util ( sortLt, assertPanic )
+import Util ( sortLt, zipWithEqual, zipWith3Equal, assertPanic, panic{-ToDo:rm-}, pprTrace{-ToDo:rm-} )
-ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util
+ppSemid x = ppBeside (ppr PprInterface x) ppSemi -- micro util
+ppr_ty ty = pprType PprInterface ty
+ppr_tyvar tv = ppr PprInterface tv
+ppr_name n
+ = let
+ on = origName n
+ s = nameOf on
+ pp = ppr PprInterface on
+ in
+ (if isLexSym s then ppParens else id) pp
+ppr_unq_name n
+ = let
+ on = origName n
+ s = nameOf on
+ pp = ppPStr s
+ in
+ (if isLexSym s then ppParens else id) pp
\end{code}
We have a function @startIface@ to open the output file and put
@@ -69,7 +101,10 @@ ifaceInstances
:: Maybe Handle
-> TcIfaceInfo -- as above
-> IO ()
---ifacePragmas
+ifacePragmas
+ :: Maybe Handle
+ -> IO ()
+ifacePragmas = panic "ifacePragmas" -- stub
\end{code}
\begin{code}
@@ -157,7 +192,7 @@ ifaceExportList (Just if_hdl)
--------------
pp_pair (n, ef)
- = ppBeside (ppr PprInterface (nameOrigName n)) (pp_export ef)
+ = ppBeside (ppr_name n) (pp_export ef)
where
pp_export ExportAll = ppPStr SLIT("(..)")
pp_export ExportAbs = ppNil
@@ -167,11 +202,18 @@ ifaceExportList (Just if_hdl)
ifaceFixities Nothing{-no iface handle-} _ = return ()
ifaceFixities (Just if_hdl) (HsModule _ _ _ _ fixities _ _ _ _ _ _ _ _ _)
- = if null fixities then
+ = let
+ local_fixities = filter from_here fixities
+ in
+ if null local_fixities then
return ()
else
hPutStr if_hdl "\n__fixities__\n" >>
- hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid fixities)))
+ hPutStr if_hdl (ppShow 100 (ppAboves (map ppSemid local_fixities)))
+ where
+ from_here (InfixL v _) = isLocallyDefined v
+ from_here (InfixR v _) = isLocallyDefined v
+ from_here (InfixN v _) = isLocallyDefined v
\end{code}
\begin{code}
@@ -191,9 +233,9 @@ ifaceDecls (Just if_hdl) (vals, tycons, classes, _)
hPutStr if_hdl "\n__declarations__\n" >>
hPutStr if_hdl (ppShow 100 (ppAboves [
- ppAboves (map ppSemid sorted_classes),
- ppAboves (map ppSemid sorted_tycons),
- ppAboves (map ppSemid sorted_vals)]))
+ ppAboves (map ppr_class sorted_classes),
+ ppAboves (map ppr_tycon sorted_tycons),
+ ppAboves [ppr_val v (idType v) | v <- sorted_vals]]))
\end{code}
\begin{code}
@@ -228,551 +270,142 @@ ifaceInstances (Just if_hdl) (_, _, _, insts)
-------
pp_inst (InstInfo clas tvs ty theta _ _ _ _ _ _ _ _)
- = ppBeside (ppPStr SLIT("instance "))
- (pprType PprInterface (mkSigmaTy tvs theta (mkDictTy clas ty)))
-\end{code}
-
-=== ALL OLD BELOW HERE ==============
-
-%************************************************************************
-%* *
-\subsection[main-MkIface]{Main routine for making interfaces}
-%* *
-%************************************************************************
-
-Misc points:
-\begin{enumerate}
-\item
-We get the general what-to-export information from the ``environments''
-produced by the typechecker (the \tr{[RenamedFixityDecl]} through
-\tr{Bag InstInfo} arguments).
-
-\item
-{\em However:} Whereas (for example) an \tr{InstInfo} will have
-\tr{Ids} in it that identify the constant methods for that instance,
-those particular \tr{Ids} {\em do not have} the best @IdInfos@!!!
-Those @IdInfos@ were figured out long after the \tr{InstInfo} was
-created.
-
-That's why we actually look at the final \tr{StgBindings} that go
-into the code-generator: they have the best @IdInfos@ on them.
-Whenever, we are about to print info about an @Id@, we look in the
-Ids-from-STG-bindings list to see if we have an ``equivalent'' @Id@
-with presumably-better @IdInfo@.
-
-\item
-We play this same game whether for values, classes (for their
-method-selectors and default-methods), or instances (for their
-@DictFunIds@ or constant-methods).
-
-Of course, for imported things, what we got from the typechecker is
-all we're gonna get.
-
-\item
-We {\em sort} things in the interface into some ``canonical'' order;
-otherwise, with heavily-recursive modules, you can have (unchanged)
-information ``move around'' in the interface file---deeply unfriendly
-to \tr{make}.
-\end{enumerate}
-
-\begin{code}
-{- OLD: to the end
-mkInterface :: FAST_STRING
- -> (FAST_STRING -> Bool, -- is something in export list, explicitly?
- FAST_STRING -> Bool) -- is a module among the "dotdot" exported modules?
- -> IdEnv UnfoldingDetails
- -> FiniteMap TyCon [(Bool, [Maybe Type])]
- -> ([RenamedFixityDecl], -- interface info from the typecheck
- [Id],
- CE,
- TCE,
- Bag InstInfo)
- -> [StgBinding]
- -> Pretty
-
-mkInterface modname export_list_fns inline_env tycon_specs
- (fixity_decls, global_ids, ce, tce, inst_infos)
- stg_binds
- = let
- -- first, gather up the things we want to export:
-
- exported_tycons = [ tc | tc <- rngTCE tce,
- isExported tc,
- is_exportable_tycon_or_class export_list_fns tc ]
- exported_classes = [ c | c <- rngCE ce,
- isExported c,
- is_exportable_tycon_or_class export_list_fns c ]
- exported_inst_infos = [ i | i <- bagToList inst_infos,
- is_exported_inst_info export_list_fns i ]
- exported_vals
- = [ v | v <- global_ids,
- isExported v && not (isDataCon v) && not (isClassOpId v) ]
-
- -- We also have to worry about TyCons/Classes that are
- -- *mentioned* in exported things (e.g., values' types or
- -- instances), so that we can be sure to do an import decl for
- -- them, for original-naming purposes:
-
- (mentioned_tycons, mentioned_classes)
- = foldr ( \ (tcs1, cls1) (tcs2, cls2)
- -> (tcs1 `unionBags` tcs2, cls1 `unionBags` cls2) )
- (emptyBag, emptyBag)
- (map getMentionedTyConsAndClassesFromClass exported_classes ++
- map getMentionedTyConsAndClassesFromTyCon exported_tycons ++
- map getMentionedTyConsAndClassesFromId exported_vals ++
- map getMentionedTyConsAndClassesFromInstInfo exported_inst_infos)
-
- mentionable_classes
- = filter is_mentionable (bagToList mentioned_classes)
- mentionable_tycons
- = [ tc | tc <- bagToList mentioned_tycons,
- is_mentionable tc,
- not (isPrimTyCon tc) ]
-
- nondup_mentioned_tycons = fst (removeDups cmp mentionable_tycons)
- nondup_mentioned_classes = fst (removeDups cmp mentionable_classes)
-
- -- Next: as discussed in the notes, we want the top-level
- -- Ids straight from the final STG code, so we can use
- -- their IdInfos to print pragmas; we slurp them out here,
- -- then pass them to the printing functions, which may
- -- use them.
-
- better_ids = collectExportedStgBinders stg_binds
-
- -- Make a lookup function for convenient access:
-
- better_id_fn i
- = if not (isLocallyDefined i)
- then i -- can't be among our "better_ids"
- else
- let
- eq_fn = if isTopLevId i -- can't trust uniqs
- then (\ x y -> origName x == origName y)
- else eqId
- in
- case [ x | x <- better_ids, x `eq_fn` i ] of
- [] -> pprPanic "better_id_fn:" (ppr PprShowAll i)
- i
- [x] -> x
- _ -> panic "better_id_fn"
-
- -- Finally, we sort everything lexically, so that we always
- -- get the same interface from the same information:
-
- sorted_mentioned_tycons = sortLt ltLexical nondup_mentioned_tycons
- sorted_mentioned_classes = sortLt ltLexical nondup_mentioned_classes
-
- sorted_tycons = sortLt ltLexical exported_tycons
- sorted_classes = sortLt ltLexical exported_classes
- sorted_vals = sortLt ltLexical exported_vals
- sorted_inst_infos = sortLt lt_lexical_inst_info exported_inst_infos
- in
- if (any_purely_local sorted_tycons sorted_classes sorted_vals) then
- -- this will be less of a HACK when we teach
- -- mkInterface to do I/O (WDP 94/10)
- error "Can't produce interface file because of errors!\n"
- else
- ppAboves
- [ppPStr SLIT("{-# GHC_PRAGMA INTERFACE VERSION 7 #-}"),
- ppCat [ppPStr SLIT("interface"), ppPStr modname, ppPStr SLIT("where")],
-
- do_import_decls modname
- sorted_vals sorted_mentioned_classes sorted_mentioned_tycons,
- -- Mustn't give the data constructors to do_import_decls,
- -- because they aren't explicitly imported; their tycon is.
-
- ppAboves (map do_fixity fixity_decls),
- ppAboves (map (pprIfaceClass better_id_fn inline_env) sorted_classes),
- ppAboves (map (do_tycon tycon_specs) sorted_tycons),
- ppAboves (map (do_value better_id_fn inline_env) sorted_vals),
- ppAboves (map (do_instance better_id_fn inline_env) sorted_inst_infos),
-
- ppChar '\n'
- ]
- where
- any_purely_local tycons classes vals
- = any bad_tc tycons || any bad_cl classes || any bad_id vals
- where
- bad_cl cl
- = case (maybePurelyLocalClass cl) of
- Nothing -> False
- Just xs -> naughty_trace cl xs
-
- bad_id id
- = case (maybePurelyLocalType (idType id)) of
- Nothing -> False
- Just xs -> naughty_trace id xs
-
- bad_tc tc
- = case (maybePurelyLocalTyCon tc) of
- Nothing -> False
- Just xs -> if exported_abs then False else naughty_trace tc xs
- where
- exported_abs = case (getExportFlag tc) of { ExportAbs -> True; _ -> False }
-
- naughty_trace x things
- = pprTrace "Can't export -- `"
- (ppBesides [ppr PprForUser x, ppStr "' mentions purely local things: ",
- ppInterleave pp'SP things])
- True
+ = let
+ forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty)
+ renumbered_ty = initNmbr (nmbrType forall_ty)
+ in
+ ppBesides [ppPStr SLIT("instance "), ppr_ty renumbered_ty, ppSemi]
\end{code}
%************************************************************************
%* *
-\subsection[imports-MkIface]{Generating `import' declarations in an interface}
+\subsection{Printing tycons, classes, ...}
%* *
%************************************************************************
-We gather up lots of (module, name) pairs for which we might print an
-import declaration. We sort them, for the usual canonicalisation
-reasons. NB: We {\em assume} the lists passed in don't have duplicates in
-them! expect).
-
-All rather horribly turgid (WDP).
-
\begin{code}
-do_import_decls
- :: FAST_STRING
- -> [Id] -> [Class] -> [TyCon]
- -> Pretty
-
-do_import_decls mod_name vals classes tycons
- = let
- -- Conjure up (module, name) pairs for all
- -- the potentially import-decls things:
-
- vals_names, classes_names, tycons_names :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])]
- vals_names = map get_val_pair vals
- classes_names = map get_class_pair classes
- tycons_names = map get_tycon_pair tycons
-
- -- sort the (module, name) pairs and chop
- -- them into per-module groups:
-
- ie_list = sortLt lt (tycons_names ++ classes_names ++ vals_names)
-
- per_module_groups = runs same_module ie_list
- in
- ppAboves (map print_a_decl per_module_groups)
+ppr_class :: Class -> Pretty
+
+ppr_class c
+ = --pprTrace "ppr_class:" (ppr PprDebug c) $
+ case (initNmbr (nmbrClass c)) of { -- renumber it!
+ Class _ n tyvar super_classes sdsels ops sels defms insts links ->
+
+ ppAbove (ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
+ ppr_name n, ppr_tyvar tyvar,
+ if null ops then ppSemi else ppStr "where {"])
+ (if (null ops)
+ then ppNil
+ else ppAbove (ppNest 2 (ppAboves (map ppr_op ops)))
+ (ppStr "};")
+ )
+ }
where
- lt, same_module :: (FAST_STRING, FAST_STRING)
- -> (FAST_STRING, FAST_STRING) -> Bool
-
- lt (m1, ie1, ie2)
- = case (_CMP_STRING_ m1 m2) of { LT_ -> True; EQ_ -> ie1 < ie2; GT__ -> False }
-
- same_module (m1, _, _) (m2, _, _) = m1 == m2
-
- compiling_the_prelude = opt_CompilingPrelude
-
- print_a_decl :: [(FAST_STRING, FAST_STRING, [Maybe FAST_STRING])] -> Pretty
- {-
- Obviously, if the module in question is this one,
- don't print an import declaration.
-
- If it's a Prelude* module, we don't print the TyCons/
- Classes, because the compiler supposedly knows about
- them already (and they are PreludeCore things anyway).
-
- But if we are compiling a Prelude module, then we
- try to do it as "normally" as possible.
- -}
- print_a_decl (ielist@((m,_,_) : _))
- | m == mod_name
- || (not compiling_the_prelude &&
- ({-OLD:m == pRELUDE_CORE ||-} m == pRELUDE_BUILTIN))
- = ppNil
-
- | otherwise
- = ppBesides [ppPStr SLIT("import "), ppPStr m, ppLparen,
- ppIntersperse pp'SP{-'-} (map pp_str [n | (_,n,_) <- ielist]),
- ppRparen
- ]
- where
- isnt_tycon_ish :: FAST_STRING -> Bool
- isnt_tycon_ish str = not (isLexCon str)
+ ppr_theta :: TyVar -> [Class] -> Pretty
- grab_non_Nothings :: [[Maybe FAST_STRING]] -> [FAST_STRING]
+ ppr_theta tv [] = ppNil
+ ppr_theta tv [sc] = ppBeside (ppr_assert tv sc) (ppStr " =>")
+ ppr_theta tv super_classes
+ = ppBesides [ppLparen,
+ ppIntersperse pp'SP{-'-} (map (ppr_assert tv) super_classes),
+ ppStr ") =>"]
- grab_non_Nothings rns = catMaybes (concat rns)
+ ppr_assert tv (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr_name n, ppr_tyvar tv]
- pp_str :: FAST_STRING -> Pretty
- pp_str pstr
- = if isLexVarSym pstr then ppStr ("("++str++")") else ppPStr pstr
- where
- str = _UNPK_ pstr
+ ppr_op (ClassOp o _ ty) = pp_sig (Unqual o) ty
\end{code}
\begin{code}
-get_val_pair :: Id -> (FAST_STRING, FAST_STRING)
-get_class_pair :: Class -> (FAST_STRING, FAST_STRING)
-get_tycon_pair :: TyCon -> (FAST_STRING, FAST_STRING)
-
-get_val_pair id
- = generic_pair id
-
-get_class_pair clas
- = case (generic_pair clas) of { (orig_mod, orig_nm) ->
- let
- nm_to_print = case (getExportFlag clas) of
- ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
- ExportAbs -> orig_nm
- NotExported -> orig_nm
- in
- (orig_mod, nm_to_print) }
-
-get_tycon_pair tycon
- = case (generic_pair tycon) of { (orig_mod, orig_nm) ->
- let
- nm_to_print = case (getExportFlag tycon) of
- ExportAll -> orig_nm _APPEND_ SLIT("(..)") -- nothing like a good HACK!
- ExportAbs -> orig_nm
- NotExported -> orig_nm
+ppr_val v ty -- renumber the type first!
+ = --pprTrace "ppr_val:" (ppr PprDebug v) $
+ pp_sig v (initNmbr (nmbrType ty))
- cons = tyConDataCons tycon
- in
- (orig_mod, nm_to_print) }
-
-generic_pair thing
- = case (moduleNamePair thing) of { (orig_mod, orig_nm) ->
- case (getOccName thing) of { occur_name ->
- (orig_mod, orig_nm) }}
+pp_sig op ty
+ = ppBesides [ppr_name op, ppPStr SLIT(" :: "), ppr_ty ty, ppSemi]
\end{code}
-%************************************************************************
-%* *
-\subsection[fixities-MkIface]{Generating fixity declarations in an interface}
-%* *
-%************************************************************************
-
-
\begin{code}
-do_fixity :: -> RenamedFixityDecl -> Pretty
+ppr_tycon tycon
+ = --pprTrace "ppr_tycon:" (ppr PprDebug tycon) $
+ ppr_tc (initNmbr (nmbrTyCon tycon))
-do_fixity fixity_decl
- = case (isLocallyDefined name, getExportFlag name) of
- (True, ExportAll) -> ppr PprInterface fixity_decl
- _ -> ppNil
- where
- name = get_name fixity_decl
- get_name (InfixL n _) = n
- get_name (InfixR n _) = n
- get_name (InfixN n _) = n
-\end{code}
+------------------------
+ppr_tc (PrimTyCon _ n _)
+ = ppCat [ ppStr "{- data", ppr_name n, ppStr " *built-in* -}" ]
-%************************************************************************
-%* *
-\subsection[tycons-MkIface]{Generating tycon declarations in an interface}
-%* *
-%************************************************************************
-
-\begin{code}
-do_tycon :: FiniteMap TyCon [(Bool, [Maybe Type])] -> TyCon -> Pretty
-
-do_tycon tycon_specs_map tycon
- = pprTyCon PprInterface tycon tycon_specs
- where
- tycon_specs = map snd (lookupWithDefaultFM tycon_specs_map [] tycon)
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[values-MkIface]{Generating a value's signature in an interface}
-%* *
-%************************************************************************
-
-\begin{code}
-do_value :: (Id -> Id)
- -> IdEnv UnfoldingDetails
- -> Id
- -> Pretty
-
-do_value better_id_fn inline_env val
- = let
- sty = PprInterface
- better_val = better_id_fn val
- name_str = getOccName better_val -- NB: not orig name!
-
- id_info = getIdInfo better_val
-
- val_ty = let
- orig_ty = idType val
- final_ty = idType better_val
- in
--- ASSERT (orig_ty == final_ty || mkLiftTy orig_ty == final_ty)
- ASSERT (if (orig_ty == final_ty || mkLiftTy orig_ty == final_ty) then True else pprTrace "do_value:" (ppCat [ppr PprDebug val, ppr PprDebug better_val]) False)
- orig_ty
-
- -- Note: We export the type of the original val
- -- The type of an unboxed val will have been *lifted* by the desugarer
- -- In this case we export an unlifted type, but id_info which assumes
- -- a lifted Id i.e. extracted from better_val (above)
- -- The importing module must lift the Id before using the imported id_info
-
- pp_id_info
- = if opt_OmitInterfacePragmas
- || boringIdInfo id_info
- then ppNil
- else ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"),
- ppIdInfo sty better_val True{-yes specs-}
- better_id_fn inline_env id_info,
- ppPStr SLIT("#-}")]
- in
- ppAbove (ppCat [ppr_non_op name_str,
- ppPStr SLIT("::"), pprGenType sty val_ty])
- pp_id_info
-
--- sadly duplicates Name.pprNonSym (ToDo)
-
-ppr_non_op str
- = if isLexVarSym str -- NOT NEEDED: || isAconop
- then ppBesides [ppLparen, ppPStr str, ppRparen]
- else ppPStr str
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[instances-MkIface]{Generating instance declarations in an interface}
-%* *
-%************************************************************************
+ppr_tc FunTyCon
+ = ppCat [ ppStr "{- data", ppr_name FunTyCon, ppStr " *built-in* -}" ]
-The types of ``dictionary functions'' (dfuns) have just the required
-info for instance declarations in interfaces. However, the dfuns that
-GHC really uses have {\em extra} dictionaries passed to them (for
-efficiency). When we print interfaces, we want to omit that
-dictionary information. (It can be reconsituted on the other end,
-from instance and class decls).
+ppr_tc (TupleTyCon _ n _)
+ = ppCat [ ppStr "{- ", ppr_name n, ppStr "-}" ]
-\begin{code}
-do_instance :: (Id -> Id)
- -> IdEnv UnfoldingDetails
- -> InstInfo
- -> Pretty
-
-do_instance better_id_fn inline_env
- (InstInfo clas tv_tmpls ty inst_decl_theta dfun_theta dfun_id constm_ids _ from_here modname _ _)
+ppr_tc (SynTyCon _ n _ _ tvs expand)
= let
- sty = PprInterface
-
- better_dfun = better_id_fn dfun_id
- better_dfun_info = getIdInfo better_dfun
- better_constms = map better_id_fn constm_ids
-
- class_op_strs = map classOpString (classOps clas)
-
- pragma_begin
- = ppCat [ppPStr SLIT("\t{-# GHC_PRAGMA"), pp_modname, ppPStr SLIT("{-dfun-}"),
- ppIdInfo sty better_dfun False{-NO specs-}
- better_id_fn inline_env better_dfun_info]
-
- pragma_end = ppPStr SLIT("#-}")
-
- pp_modname = if _NULL_ modname
- then ppNil
- else ppCat [ppStr "_M_", ppPStr modname]
-
- name_pragma_pairs
- = pp_the_list [ ppCat [ppChar '\t', ppr_non_op op, ppEquals,
- ppChar '{' ,
- ppIdInfo sty constm True{-YES, specs-}
- better_id_fn inline_env
- (getIdInfo constm),
- ppChar '}' ]
- | (op, constm) <- class_op_strs `zip` better_constms ]
-
-#ifdef DEBUG
- pp_the_list [] = panic "MkIface: no class_ops or better_constms?"
-#endif
- pp_the_list [p] = p
- pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
-
- real_stuff
- = ppCat [ppPStr SLIT("instance"),
- ppr sty (mkSigmaTy tv_tmpls inst_decl_theta (mkDictTy clas ty))]
+ pp_tyvars = map ppr_tyvar tvs
in
- if opt_OmitInterfacePragmas
- || boringIdInfo better_dfun_info
- then real_stuff
- else ppAbove real_stuff
- ({-ppNest 8 -} -- ppNest does nothing
- if null better_constms
- then ppCat [pragma_begin, pragma_end]
- else ppAbove pragma_begin (ppCat [name_pragma_pairs, pragma_end])
- )
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[utils-InstInfos]{Utility functions for @InstInfos@}
-%* *
-%************************************************************************
-
-ToDo: perhaps move.
-
-Classes/TyCons are ``known,'' more-or-less. Prelude TyCons are
-``completely'' known---they don't need to be mentioned in interfaces.
-Classes usually don't need to be mentioned in interfaces, but if we're
-compiling the prelude, then we treat them without special favours.
-\begin{code}
-is_exportable_tycon_or_class export_list_fns tc
- = if not (fromPreludeCore tc) then
- True
- else
- in_export_list_or_among_dotdot_modules
- opt_CompilingPrelude -- ignore M.. stuff if compiling prelude
- export_list_fns tc
-
-in_export_list_or_among_dotdot_modules ignore_Mdotdots (in_export_list, among_dotdot_modules) tc
- = if in_export_list (getOccName tc) then
- True
- else
--- pprTrace "in_export:" (ppAbove (ppr PprDebug ignore_Mdotdots) (ppPStr (getOccName tc))) (
- if ignore_Mdotdots then
- False
- else
- any among_dotdot_modules (getInformingModules tc)
--- )
-
-is_mentionable tc
- = not (from_PreludeCore_or_Builtin tc) || opt_CompilingPrelude
+ ppBesides [ppPStr SLIT("type "), ppr_name n, ppSP, ppIntersperse ppSP pp_tyvars,
+ ppPStr SLIT(" = "), ppr_ty expand, ppSemi]
+
+ppr_tc this_tycon@(DataTyCon u n k tvs ctxt cons derivings data_or_new)
+ = ppHang (ppCat [pp_data_or_new,
+ ppr_context ctxt,
+ ppr_name n,
+ ppIntersperse ppSP (map ppr_tyvar tvs)])
+ 2
+ (ppBeside pp_unabstract_condecls ppSemi)
+ -- NB: we do not print deriving info in interfaces
where
- from_PreludeCore_or_Builtin thing
+ pp_data_or_new = case data_or_new of
+ DataType -> ppPStr SLIT("data")
+ NewType -> ppPStr SLIT("newtype")
+
+ ppr_context [] = ppNil
+ ppr_context [(c,t)] = ppCat [ppr_name c, ppr_ty t, ppStr "=>"]
+ ppr_context cs
+ = ppBesides[ppLparen,
+ ppInterleave ppComma [ppCat [ppr_name c, ppr_ty t] | (c,t) <- cs],
+ ppRparen, ppStr " =>"]
+
+ yes_we_print_condecls
+ = case (getExportFlag n) of
+ ExportAbs -> False
+ other -> True
+
+ pp_unabstract_condecls
+ = if yes_we_print_condecls
+ then ppCat [ppEquals, pp_condecls]
+ else ppNil
+
+ pp_condecls
= let
- mod_name = fst (moduleNamePair thing)
+ (c:cs) = cons
in
- mod_name == pRELUDE_CORE || mod_name == pRELUDE_BUILTIN
-
-is_exported_inst_info export_list_fns
- (InstInfo clas _ ty _ _ _ _ _ from_here _ _ _)
- = let
- seems_exported = instanceIsExported clas ty from_here
- (tycon, _, _) = getAppTyCon ty
- in
- if (opt_OmitReexportedInstances && not from_here) then
- False -- Flag says to violate Haskell rules, blatantly
-
- else if not opt_CompilingPrelude
- || not (isFunTyCon tycon || fromPreludeCore tycon)
- || not (fromPreludeCore clas) then
- seems_exported -- take what we got
-
- else -- compiling Prelude & tycon/class are Prelude things...
- from_here
- || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns clas
- || in_export_list_or_among_dotdot_modules True{-ignore M..s-} export_list_fns tycon
-\end{code}
+ ppSep ((ppr_con c) : (map ppr_next_con cs))
-\begin{code}
-lt_lexical_inst_info (InstInfo _ _ _ _ _ dfun1 _ _ _ _ _ _) (InstInfo _ _ _ _ _ dfun2 _ _ _ _ _ _)
- = ltLexical dfun1 dfun2
-\end{code}
+ ppr_next_con con = ppCat [ppChar '|', ppr_con con]
-\begin{code}
-getMentionedTyConsAndClassesFromInstInfo (InstInfo clas _ ty _ dfun_theta _ _ _ _ _ _ _)
- = case (getMentionedTyConsAndClassesFromType ty) of { (ts, cs) ->
- case [ c | (c, _) <- dfun_theta ] of { theta_classes ->
- (ts, (cs `unionBags` listToBag theta_classes) `snocBag` clas)
- }}
-OLD from the beginning -}
+ ppr_con con
+ = let
+ (_, _, con_arg_tys, _) = dataConSig con
+ labels = dataConFieldLabels con -- none if not a record
+ strict_marks = dataConStrictMarks con
+ in
+ ppCat [ppr_unq_name con, ppr_fields labels strict_marks con_arg_tys]
+
+ ppr_fields labels strict_marks con_arg_tys
+ = if null labels then -- not a record thingy
+ ppIntersperse ppSP (zipWithEqual ppr_bang_ty strict_marks con_arg_tys)
+ else
+ ppCat [ ppChar '{',
+ ppInterleave ppComma (zipWith3Equal ppr_field labels strict_marks con_arg_tys),
+ ppChar '}' ]
+
+ ppr_bang_ty b t
+ = ppBeside (case b of { MarkedStrict -> ppChar '!'; _ -> ppNil })
+ (pprParendType PprInterface t)
+
+ ppr_field l b t
+ = ppBesides [ppr_unq_name l, ppPStr SLIT(" :: "),
+ case b of { MarkedStrict -> ppChar '!'; _ -> ppNil },
+ ppr_ty t]
\end{code}
diff --git a/ghc/compiler/nativeGen/AsmRegAlloc.lhs b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
index 8e574e6ccde4e27b8b41ed5b302a826b68fb390c..6f8df0b713d59e19f8b71a8a58ecc01339fa4167 100644
--- a/ghc/compiler/nativeGen/AsmRegAlloc.lhs
+++ b/ghc/compiler/nativeGen/AsmRegAlloc.lhs
@@ -22,7 +22,7 @@ import OrdList ( mkEmptyList, mkUnitList, mkSeqList, mkParList,
flattenOrdList, OrdList
)
import Stix ( StixTree )
-import UniqSupply ( mkBuiltinUnique )
+import Unique ( mkBuiltinUnique )
import Util ( mapAccumB, panic )
\end{code}
diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs
index 420f5017ccf0cb26c5462b2f9bc4ab4e5df0a7a2..156dab372962494dbdcac4ae2976184a0eb94b18 100644
--- a/ghc/compiler/nativeGen/MachRegs.lhs
+++ b/ghc/compiler/nativeGen/MachRegs.lhs
@@ -69,10 +69,10 @@ import PrimRep ( PrimRep(..) )
import Stix ( sStLitLbl, StixTree(..), StixReg(..),
CodeSegment
)
-import Unique ( Unique{-instance Ord3-} )
-import UniqSupply ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
- getUnique, returnUs, thenUs, UniqSM(..)
+import Unique ( mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+ Unique{-instance Ord3-}
)
+import UniqSupply ( getUnique, returnUs, thenUs, UniqSM(..) )
import Unpretty ( uppStr, Unpretty(..) )
import Util ( panic )
\end{code}
diff --git a/ghc/compiler/parser/pbinding.ugn b/ghc/compiler/parser/pbinding.ugn
index 03e76889ad10d2bb9091c8b4cf54754fa4a73255..2700417e5a414f6441d3c508509e2d551235d164 100644
--- a/ghc/compiler/parser/pbinding.ugn
+++ b/ghc/compiler/parser/pbinding.ugn
@@ -8,8 +8,6 @@ import UgenUtil
import U_constr ( U_constr ) -- interface only
import U_binding
-import U_coresyn ( U_coresyn ) -- ditto
-import U_hpragma ( U_hpragma ) -- ditto
import U_list
import U_literal ( U_literal ) -- ditto
import U_maybe ( U_maybe ) -- ditto
diff --git a/ghc/compiler/parser/tree.ugn b/ghc/compiler/parser/tree.ugn
index 79bbabc5764fe847650b0b55f1dd653237f17640..fb69ec100cc23413c9b4c5ee4e8e62b45d3fb30b 100644
--- a/ghc/compiler/parser/tree.ugn
+++ b/ghc/compiler/parser/tree.ugn
@@ -8,8 +8,6 @@ import UgenUtil
import U_constr ( U_constr ) -- interface only
import U_binding
-import U_coresyn ( U_coresyn ) -- interface only
-import U_hpragma ( U_hpragma ) -- interface only
import U_list
import U_literal
import U_maybe
diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs
index 83449fe3e7c2744b570920f64cbb2761a3a4a7f1..8aac8e64ceed46cb78f957230f28ce50c94ba8e0 100644
--- a/ghc/compiler/prelude/PrelVals.lhs
+++ b/ghc/compiler/prelude/PrelVals.lhs
@@ -467,7 +467,7 @@ buildId
buildTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [build_ty] (mkListTy alphaTy))
where
build_ty = mkSigmaTy [betaTyVar] []
- (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
\end{code}
@mkBuild@ is sugar for building a build!
@@ -511,7 +511,7 @@ augmentId
augmentTy = mkSigmaTy [alphaTyVar] [] (mkFunTys [aug_ty, mkListTy alphaTy] (mkListTy alphaTy))
where
aug_ty = mkSigmaTy [betaTyVar] []
- (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy] betaTy)
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy] betaTy)
\end{code}
\begin{code}
@@ -520,7 +520,7 @@ foldrId = pcMiscPrelId foldrIdKey pRELUDE_FB{-not "List"-} SLIT("foldr")
where
foldrTy =
mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
+ (mkFunTys [mkFunTys [alphaTy, betaTy] betaTy, betaTy, mkListTy alphaTy] betaTy)
idInfo = (((((noIdInfo
`addInfo_UF` mkMagicUnfolding foldrIdKey)
@@ -534,7 +534,7 @@ foldlId = pcMiscPrelId foldlIdKey pRELUDE_FB{-not "List"-} SLIT("foldl")
where
foldlTy =
mkSigmaTy [alphaTyVar, betaTyVar] []
- (mkFunTys [alphaTy, mkFunTys [betaTy] betaTy, alphaTy, mkListTy betaTy] alphaTy)
+ (mkFunTys [mkFunTys [alphaTy, betaTy] alphaTy, alphaTy, mkListTy betaTy] alphaTy)
idInfo = (((((noIdInfo
`addInfo_UF` mkMagicUnfolding foldlIdKey)
diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs
index 0ea3f0aecdd8a3cd7c2ee35ba46e9c55ed9c51f2..11d5e284ba88ce00d2b19e4df45f51365a57f578 100644
--- a/ghc/compiler/prelude/PrimOp.lhs
+++ b/ghc/compiler/prelude/PrimOp.lhs
@@ -630,7 +630,7 @@ data PrimOpInfo
Type
| Compare FAST_STRING -- string :: T -> T -> Bool
Type
- | Coerce FAST_STRING -- string :: T1 -> T2
+ | Coercing FAST_STRING -- string :: T1 -> T2
Type
Type
@@ -734,8 +734,8 @@ primOpInfo DoubleLeOp = Compare SLIT("leDouble#") doublePrimTy
%************************************************************************
\begin{code}
-primOpInfo OrdOp = Coerce SLIT("ord#") charPrimTy intPrimTy
-primOpInfo ChrOp = Coerce SLIT("chr#") intPrimTy charPrimTy
+primOpInfo OrdOp = Coercing SLIT("ord#") charPrimTy intPrimTy
+primOpInfo ChrOp = Coercing SLIT("chr#") intPrimTy charPrimTy
\end{code}
%************************************************************************
@@ -781,8 +781,8 @@ primOpInfo ISraOp
primOpInfo ISrlOp
= PrimResult SLIT("iShiftRL#") [] [intPrimTy, intPrimTy] intPrimTyCon IntRep []
-primOpInfo Int2WordOp = Coerce SLIT("int2Word#") intPrimTy wordPrimTy
-primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy
+primOpInfo Int2WordOp = Coercing SLIT("int2Word#") intPrimTy wordPrimTy
+primOpInfo Word2IntOp = Coercing SLIT("word2Int#") wordPrimTy intPrimTy
\end{code}
%************************************************************************
@@ -792,8 +792,8 @@ primOpInfo Word2IntOp = Coerce SLIT("word2Int#") wordPrimTy intPrimTy
%************************************************************************
\begin{code}
-primOpInfo Int2AddrOp = Coerce SLIT("int2Addr#") intPrimTy addrPrimTy
-primOpInfo Addr2IntOp = Coerce SLIT("addr2Int#") addrPrimTy intPrimTy
+primOpInfo Int2AddrOp = Coercing SLIT("int2Addr#") intPrimTy addrPrimTy
+primOpInfo Addr2IntOp = Coercing SLIT("addr2Int#") addrPrimTy intPrimTy
\end{code}
%************************************************************************
@@ -812,8 +812,8 @@ primOpInfo FloatMulOp = Dyadic SLIT("timesFloat#") floatPrimTy
primOpInfo FloatDivOp = Dyadic SLIT("divideFloat#") floatPrimTy
primOpInfo FloatNegOp = Monadic SLIT("negateFloat#") floatPrimTy
-primOpInfo Float2IntOp = Coerce SLIT("float2Int#") floatPrimTy intPrimTy
-primOpInfo Int2FloatOp = Coerce SLIT("int2Float#") intPrimTy floatPrimTy
+primOpInfo Float2IntOp = Coercing SLIT("float2Int#") floatPrimTy intPrimTy
+primOpInfo Int2FloatOp = Coercing SLIT("int2Float#") intPrimTy floatPrimTy
primOpInfo FloatExpOp = Monadic SLIT("expFloat#") floatPrimTy
primOpInfo FloatLogOp = Monadic SLIT("logFloat#") floatPrimTy
@@ -846,11 +846,11 @@ primOpInfo DoubleMulOp = Dyadic SLIT("timesDouble#") doublePrimTy
primOpInfo DoubleDivOp = Dyadic SLIT("divideDouble#") doublePrimTy
primOpInfo DoubleNegOp = Monadic SLIT("negateDouble#") doublePrimTy
-primOpInfo Double2IntOp = Coerce SLIT("double2Int#") doublePrimTy intPrimTy
-primOpInfo Int2DoubleOp = Coerce SLIT("int2Double#") intPrimTy doublePrimTy
+primOpInfo Double2IntOp = Coercing SLIT("double2Int#") doublePrimTy intPrimTy
+primOpInfo Int2DoubleOp = Coercing SLIT("int2Double#") intPrimTy doublePrimTy
-primOpInfo Double2FloatOp = Coerce SLIT("double2Float#") doublePrimTy floatPrimTy
-primOpInfo Float2DoubleOp = Coerce SLIT("float2Double#") floatPrimTy doublePrimTy
+primOpInfo Double2FloatOp = Coercing SLIT("double2Float#") doublePrimTy floatPrimTy
+primOpInfo Float2DoubleOp = Coercing SLIT("float2Double#") floatPrimTy doublePrimTy
primOpInfo DoubleExpOp = Monadic SLIT("expDouble#") doublePrimTy
primOpInfo DoubleLogOp = Monadic SLIT("logDouble#") doublePrimTy
@@ -1569,7 +1569,7 @@ primOp_str op
Dyadic str _ -> str
Monadic str _ -> str
Compare str _ -> str
- Coerce str _ _ -> str
+ Coercing str _ _ -> str
PrimResult str _ _ _ _ _ -> str
AlgResult str _ _ _ _ -> str
\end{code}
@@ -1584,7 +1584,7 @@ primOpType op
Dyadic str ty -> dyadic_fun_ty ty
Monadic str ty -> monadic_fun_ty ty
Compare str ty -> compare_fun_ty ty
- Coerce str ty1 ty2 -> mkFunTys [ty1] ty2
+ Coercing str ty1 ty2 -> mkFunTys [ty1] ty2
PrimResult str tyvars arg_tys prim_tycon kind res_tys ->
mkForAllTys tyvars (mkFunTys arg_tys (applyTyCon prim_tycon res_tys))
@@ -1608,7 +1608,7 @@ getPrimOpResultInfo op
Dyadic _ ty -> ReturnsPrim (typePrimRep ty)
Monadic _ ty -> ReturnsPrim (typePrimRep ty)
Compare _ ty -> ReturnsAlg boolTyCon
- Coerce _ _ ty -> ReturnsPrim (typePrimRep ty)
+ Coercing _ _ ty -> ReturnsPrim (typePrimRep ty)
PrimResult _ _ _ _ kind _ -> ReturnsPrim kind
AlgResult _ _ _ tycon _ -> ReturnsAlg tycon
diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index cfb377d52806436ae5c41b9911f6b35d5c2e43a2..805a1dc813c8bdcf54e832d37321c3257e9e9a5a 100644
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -394,7 +394,7 @@ rnQuals (qual: quals)
= rnQual qual `thenRn` \ ((qual', bs1), fvQuals1) ->
extendSS2 bs1 (rnQuals quals) `thenRn` \ ((quals', bs2), fvQuals2) ->
returnRn
- ((qual' : quals', bs2 ++ bs1), -- The ones on the right (bs2) shadow the
+ ((qual' : quals', bs1 ++ bs2), -- The ones on the right (bs2) shadow the
-- ones on the left (bs1)
fvQuals1 `unionUniqSets` fvQuals2)
diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs
index 549107996c996eed3e7ed0d0810542499578a702..ff88c4fe23c209d1e0b35b051fda5dc633d53225 100644
--- a/ghc/compiler/rename/RnHsSyn.lhs
+++ b/ghc/compiler/rename/RnHsSyn.lhs
@@ -12,7 +12,7 @@ import Ubiq
import HsSyn
-import Id ( GenId, Id(..) )
+import Id ( isDataCon, GenId, Id(..) )
import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
mkLocalName{-ToDo:rm-}
)
@@ -75,6 +75,7 @@ isRnTyConOrClass (RnImplicitClass _) = True
isRnTyConOrClass _ = False
isRnConstr (RnConstr _ _) = True
+isRnConstr (WiredInId id) = isDataCon id
isRnConstr _ = False
isRnField (RnField _ _) = True
diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs
index 3327af9d83ecb875bec18c3b623d02c65538bcb2..01dc045d25923058e8798dd67540c6ce69b1d287 100644
--- a/ghc/compiler/rename/RnIfaces.lhs
+++ b/ghc/compiler/rename/RnIfaces.lhs
@@ -74,7 +74,10 @@ absolute-filename-for-that-interface.
findHiFiles :: [FilePath] -> [FilePath] -> IO (FiniteMap Module FilePath)
findHiFiles dirs sysdirs
- = do_dirs emptyFM (dirs ++ sysdirs)
+ = hPutStr stderr " findHiFiles " >>
+ do_dirs emptyFM (dirs ++ sysdirs) >>= \ result ->
+ hPutStr stderr " done\n" >>
+ return result
where
do_dirs env [] = return env
do_dirs env (dir:dirs)
@@ -82,7 +85,7 @@ findHiFiles dirs sysdirs
do_dirs new_env dirs
-------
do_dir env dir
- = --trace ("Having a go on..."++dir) $
+ = hPutStr stderr "D" >>
getDirectoryContents dir >>= \ entries ->
do_entries env entries
where
@@ -94,6 +97,7 @@ findHiFiles dirs sysdirs
do_entry env e
= case (acceptable_hi (reverse e)) of
Nothing -> --trace ("Deemed uncool:"++e) $
+ hPutStr stderr "." >>
return env
Just mod ->
let
@@ -101,10 +105,12 @@ findHiFiles dirs sysdirs
in
case (lookupFM env pmod) of
Nothing -> --trace ("Adding "++mod++" -> "++e) $
+ hPutStr stderr "!" >>
return (addToFM env pmod (dir ++ '/':e))
-- ToDo: use DIR_SEP, not /
Just xx -> ( if de_dot xx /= e then trace ("Already mapped!! "++mod++" -> "++xx++"; ignoring:"++e) else id) $
+ hPutStr stderr "." >>
return env
-------
acceptable_hi rev_e -- looking at pathname *backwards*
@@ -244,10 +250,14 @@ readIface :: FilePath -> Module
-> IO (MaybeErr ParsedIface Error)
readIface file mod
- = readFile file `thenPrimIO` \ read_result ->
+ = hPutStr stderr (" reading "++file) >>
+ readFile file `thenPrimIO` \ read_result ->
case read_result of
Left err -> return (Failed (cannaeReadErr file err))
- Right contents -> return (parseIface contents)
+ Right contents -> hPutStr stderr " parsing" >>
+ let parsed = parseIface contents in
+ hPutStr stderr " done\n" >>
+ return parsed
\end{code}
diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs
index dadfc613ff096d1dadecc1b6c863725237e1cce1..dd5be0c783d74d4fe349299be7be2f8fdcc80930 100644
--- a/ghc/compiler/rename/RnSource.lhs
+++ b/ghc/compiler/rename/RnSource.lhs
@@ -29,6 +29,7 @@ import Name ( Name, isLocallyDefined, isLexVarId, getLocalName, ExportFlag(..),
nameImportFlag, RdrName, pprNonSym )
import Outputable -- ToDo:rm
import PprStyle -- ToDo:rm
+import PrelInfo ( consDataCon )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
@@ -71,10 +72,10 @@ rnSource imp_mods unqual_imps imp_fixes
rnExports (mod:imp_mods) unqual_imps exports `thenRn` \ exported_fn ->
rnFixes fixes `thenRn` \ src_fixes ->
let
- pair_name inf = (nameFixDecl inf, inf)
+ all_fixes = src_fixes ++ bagToList imp_fixes
+ all_fixes_fm = listToUFM (map pair_name all_fixes)
- all_fixes = src_fixes ++ bagToList imp_fixes
- all_fixes_fm = listToUFM (map pair_name all_fixes)
+ pair_name inf = (nameFixDecl inf, inf)
in
setExtraRn all_fixes_fm $
diff --git a/ghc/compiler/simplCore/AnalFBWW.lhs b/ghc/compiler/simplCore/AnalFBWW.lhs
index 8422c18695235137e9e2891b0ab9c10b0ef54d7d..43a56463da21f8abd46d1901bd089246ed5b0649 100644
--- a/ghc/compiler/simplCore/AnalFBWW.lhs
+++ b/ghc/compiler/simplCore/AnalFBWW.lhs
@@ -140,6 +140,7 @@ analExprFBWW (CoTyLam tyvar e) env = analExprFBWW e env
analExprFBWW (App f atom) env = rmArg (analExprFBWW f env)
analExprFBWW (CoTyApp f ty) env = analExprFBWW f env
analExprFBWW (SCC lab e) env = analExprFBWW e env
+analExprFBWW (Coerce _ _ _) env = panic "AnalFBWW:analExprFBWW:Coerce"
analExprFBWW (Let binds e) env = analExprFBWW e (analBind binds env)
analExprFBWW (Case e alts) env = foldl1 joinFBType (analAltsFBWW alts env)
@@ -218,6 +219,7 @@ annotateExprFBWW (CoTyLam tyvar e) env = CoTyLam tyvar (annotateExprFBWW e env)
annotateExprFBWW (App f atom) env = App (annotateExprFBWW f env) atom
annotateExprFBWW (CoTyApp f ty) env = CoTyApp (annotateExprFBWW f env) ty
annotateExprFBWW (SCC lab e) env = SCC lab (annotateExprFBWW e env)
+annotateExprFBWW (Coerce c ty e) env = Coerce c ty (annotateExprFBWW e env)
annotateExprFBWW (Case e alts) env = Case (annotateExprFBWW e env)
(annotateAltsFBWW alts env)
annotateExprFBWW (Let bnds e) env = Let bnds' (annotateExprFBWW e env')
diff --git a/ghc/compiler/simplCore/FloatIn.lhs b/ghc/compiler/simplCore/FloatIn.lhs
index 0eb15290b29caf58326c5630965fb6a04284966e..b534011a6337655b9c3f01d993bea97b82cfb20b 100644
--- a/ghc/compiler/simplCore/FloatIn.lhs
+++ b/ghc/compiler/simplCore/FloatIn.lhs
@@ -200,6 +200,12 @@ fiExpr to_drop (_, AnnSCC cc expr)
= mkCoLets' to_drop (SCC cc (fiExpr [] expr))
\end{code}
+\begin{code}
+fiExpr to_drop (_, AnnCoerce c ty expr)
+ = _trace "fiExpr:Coerce:wimping out" $
+ mkCoLets' to_drop (Coerce c ty (fiExpr [] expr))
+\end{code}
+
For @Lets@, the possible ``drop points'' for the \tr{to_drop}
bindings are: (a)~in the body, (b1)~in the RHS of a NonRec binding,
or~(b2), in each of the RHSs of the pairs of a @Rec@.
diff --git a/ghc/compiler/simplCore/FloatOut.lhs b/ghc/compiler/simplCore/FloatOut.lhs
index d65112ac0b9b21c4e9f93e616282e9d02ac37129..c1de417350665c0d64d1526835ca902805143dfa 100644
--- a/ghc/compiler/simplCore/FloatOut.lhs
+++ b/ghc/compiler/simplCore/FloatOut.lhs
@@ -272,6 +272,10 @@ floatExpr env lvl (SCC cc expr)
-- Note: Nested SCC's are preserved for the benefit of
-- cost centre stack profiling (Durham)
+floatExpr env lvl (Coerce c ty expr)
+ = case (floatExpr env lvl expr) of { (fs, floating_defns, expr') ->
+ (fs, floating_defns, Coerce c ty expr') }
+
floatExpr env lvl (Let bind body)
= case (floatBind env lvl bind) of { (fsb, rhs_floats, bind', new_env) ->
case (floatExpr new_env lvl body) of { (fse, body_floats, body') ->
diff --git a/ghc/compiler/simplCore/FoldrBuildWW.lhs b/ghc/compiler/simplCore/FoldrBuildWW.lhs
index 99fa850513912ec747071f88a218bf84ac9fa1f2..a456fde4e1c146e7d79067dcd2605b2f958eec80 100644
--- a/ghc/compiler/simplCore/FoldrBuildWW.lhs
+++ b/ghc/compiler/simplCore/FoldrBuildWW.lhs
@@ -76,6 +76,9 @@ wwExpr (CoTyApp f ty) =
wwExpr (SCC lab e) =
wwExpr e `thenWw` \ e' ->
returnWw (SCC lab e')
+wwExpr (Coerce c ty e) =
+ wwExpr e `thenWw` \ e' ->
+ returnWw (Coerce c ty e')
wwExpr (Let bnds e) =
wwExpr e `thenWw` \ e' ->
wwBind bnds `thenWw` \ bnds' ->
diff --git a/ghc/compiler/simplCore/LiberateCase.lhs b/ghc/compiler/simplCore/LiberateCase.lhs
index 2b46c88dc64b904278b786c5c377c818a134bdce..a75cd48b196000f766e5b0de777aae9e29b8177c 100644
--- a/ghc/compiler/simplCore/LiberateCase.lhs
+++ b/ghc/compiler/simplCore/LiberateCase.lhs
@@ -196,14 +196,15 @@ libCase :: LibCaseEnv
-> CoreExpr
-> CoreExpr
-libCase env (Lit lit) = Lit lit
-libCase env (Var v) = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
-libCase env (App fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
-libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty
-libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
-libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
-libCase env (CoTyLam tyvar body) = CoTyLam tyvar (libCase env body)
-libCase env (SCC cc body) = SCC cc (libCase env body)
+libCase env (Lit lit) = Lit lit
+libCase env (Var v) = mkCoLetsNoUnboxed (libCaseId env v) (Var v)
+libCase env (App fun arg) = mkCoLetsNoUnboxed (libCaseAtom env arg) (App (libCase env fun) arg)
+libCase env (CoTyApp fun ty) = CoTyApp (libCase env fun) ty
+libCase env (Con con tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Con con tys args)
+libCase env (Prim op tys args) = mkCoLetsNoUnboxed (libCaseAtoms env args) (Prim op tys args)
+libCase env (CoTyLam tv body) = CoTyLam tv (libCase env body)
+libCase env (SCC cc body) = SCC cc (libCase env body)
+libCase env (Coerce c ty body) = Coerce c ty (libCase env body)
libCase env (Lam binder body)
= Lam binder (libCase (addBinders env [binder]) body)
diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs
index 0574b4150efe5d552328d49c5d7074b2c720c4e5..c6567dae65b01fe67b76d0b86c5956c5ea8793eb 100644
--- a/ghc/compiler/simplCore/OccurAnal.lhs
+++ b/ghc/compiler/simplCore/OccurAnal.lhs
@@ -387,6 +387,11 @@ occAnal env (SCC cc body)
where
(usage, body') = occAnal env body
+occAnal env (Coerce c ty body)
+ = (usage, Coerce c ty body')
+ where
+ (usage, body') = occAnal env body
+
occAnal env (App fun arg)
= (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
where
diff --git a/ghc/compiler/simplCore/SAT.lhs b/ghc/compiler/simplCore/SAT.lhs
index 28cb54cebb5e3feee8e2d85320644ad6235efd66..062dada607ebcff56acd2a7a46258e59c4c9befc 100644
--- a/ghc/compiler/simplCore/SAT.lhs
+++ b/ghc/compiler/simplCore/SAT.lhs
@@ -168,6 +168,10 @@ satExpr (Let (Rec binds) body)
satExpr (SCC cc expr)
= satExpr expr `thenSAT` \ expr2 ->
returnSAT (SCC cc expr2)
+
+satExpr (Coerce c ty expr)
+ = satExpr expr `thenSAT` \ expr2 ->
+ returnSAT (Coerce c ty expr2)
\end{code}
\begin{code}
diff --git a/ghc/compiler/simplCore/SetLevels.lhs b/ghc/compiler/simplCore/SetLevels.lhs
index 5e9fffc34bef1dce4999badc4b4eb20336f3f1ee..7427ad4c2ca390c8d1625744de13bd0c39e6f6fe 100644
--- a/ghc/compiler/simplCore/SetLevels.lhs
+++ b/ghc/compiler/simplCore/SetLevels.lhs
@@ -263,6 +263,10 @@ lvlExpr ctxt_lvl envs (_, AnnSCC cc expr)
= lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
returnLvl (SCC cc expr')
+lvlExpr ctxt_lvl envs (_, AnnCoerce c ty expr)
+ = lvlExpr ctxt_lvl envs expr `thenLvl` \ expr' ->
+ returnLvl (Coerce c ty expr')
+
lvlExpr ctxt_lvl envs@(venv, tenv) (_, AnnLam (ValBinder arg) rhs)
= lvlMFE incd_lvl (new_venv, tenv) rhs `thenLvl` \ rhs' ->
returnLvl (Lam (ValBinder (arg,incd_lvl)) rhs')
diff --git a/ghc/compiler/simplCore/SimplCase.lhs b/ghc/compiler/simplCore/SimplCase.lhs
index 6783e1154d070c7fd90598bcc1d7e606b7bfa0a9..a539af9e42c43716ee79d54cb93ce20653aaa4e7 100644
--- a/ghc/compiler/simplCore/SimplCase.lhs
+++ b/ghc/compiler/simplCore/SimplCase.lhs
@@ -36,7 +36,7 @@ import SimplUtils ( mkValLamTryingEta )
import Type ( isPrimType, maybeAppDataTyCon, mkFunTys, eqTy )
import Unique ( Unique{-instance Eq-} )
import Usage ( GenUsage{-instance Eq-} )
-import Util ( isIn, isSingleton, panic, assertPanic )
+import Util ( isIn, isSingleton, zipEqual, panic, assertPanic )
\end{code}
Float let out of case.
@@ -681,7 +681,7 @@ completeAlgCaseWithKnownCon env con con_args (AlgAlts alts deflt) rhs_c
| alt_con == con
= -- Matching alternative!
let
- new_env = extendIdEnvWithAtomList env (zip alt_args con_args)
+ new_env = extendIdEnvWithAtomList env (zipEqual alt_args (filter isValArg con_args))
in
rhs_c new_env rhs
diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs
index ed4d11dd00d381bd5c9b466d8f0ac479cfbdf424..ba098eab38f6ec900302a95855d6a36d3e4ee723 100644
--- a/ghc/compiler/simplCore/SimplEnv.lhs
+++ b/ghc/compiler/simplCore/SimplEnv.lhs
@@ -55,7 +55,7 @@ import CoreUnfold ( UnfoldingDetails(..), mkGenForm, modifyUnfoldingDetails,
calcUnfoldingGuidance, UnfoldingGuidance(..),
mkFormSummary, FormSummary
)
-import CoreUtils ( manifestlyWHNF )
+import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup )
import FiniteMap -- lots of things
import Id ( idType, getIdUnfolding, getIdStrictness,
applyTypeEnvToId,
@@ -71,7 +71,7 @@ import PprCore -- various instances
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar )
import Pretty
-import Type ( getAppDataTyCon, applyTypeEnvToTy )
+import Type ( eqTy, getAppDataTyCon, applyTypeEnvToTy )
import TyVar ( nullTyVarEnv, addOneToIdEnv, addOneToTyVarEnv,
growTyVarEnvList,
TyVarEnv(..), GenTyVar{-instance Eq-}
@@ -80,11 +80,10 @@ import Unique ( Unique{-instance Outputable-} )
import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList )
import UniqSet -- lots of things
import Usage ( UVar(..), GenUsage{-instances-} )
-import Util ( zipEqual, panic, assertPanic )
+import Util ( zipEqual, panic, panic#, assertPanic )
type TypeEnv = TyVarEnv Type
cmpType = panic "cmpType (SimplEnv)"
-exprSmallEnoughToDup = panic "exprSmallEnoughToDup (SimplEnv)"
oneSafeOcc = panic "oneSafeOcc (SimplEnv)"
oneTextualOcc = panic "oneTextualOcc (SimplEnv)"
simplIdWantsToBeINLINEd = panic "simplIdWantsToBeINLINEd (SimplEnv)"
@@ -253,7 +252,7 @@ data UnfoldItem -- a glorified triple...
-- we can "wrap" it in the CC
-- that was in force.
-data UnfoldConApp -- yet another glorified triple
+data UnfoldConApp -- yet another glorified pair
= UCA OutId -- same fields as ConForm
[OutArg]
@@ -309,12 +308,12 @@ grow_unfold_env (UFE u_env interesting_ids con_apps) id uf_details encl_cc
where
new_con_apps
= case uf_details of
- ConForm con vargs
+ ConForm con args
-> case (lookupFM con_apps entry) of
Just _ -> con_apps -- unchanged; we hang onto what we have
Nothing -> addToFM con_apps entry id
where
- entry = UCA con vargs
+ entry = UCA con args
not_a_constructor -> con_apps -- unchanged
@@ -378,7 +377,7 @@ cmp_app (UCA c1 as1) (UCA c2 as2)
= case (c1 `cmp` c2) of
LT_ -> LT_
GT_ -> GT_
- _ -> cmp_lists cmp_atom as1 as2
+ _ -> cmp_lists cmp_arg as1 as2
where
cmp_lists cmp_item [] [] = EQ_
cmp_lists cmp_item (x:xs) [] = GT_
@@ -386,11 +385,20 @@ cmp_app (UCA c1 as1) (UCA c2 as2)
cmp_lists cmp_item (x:xs) (y:ys)
= case cmp_item x y of { EQ_ -> cmp_lists cmp_item xs ys; other -> other }
- cmp_atom (VarArg x) (VarArg y) = x `cmp` y
- cmp_atom (VarArg _) _ = LT_
- cmp_atom (LitArg x) (LitArg y)
- = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
- cmp_atom (LitArg _) _ = GT_
+ -- ToDo: make an "instance Ord3 CoreArg"???
+
+ cmp_arg (VarArg x) (VarArg y) = x `cmp` y
+ cmp_arg (LitArg x) (LitArg y) = case _tagCmp x y of { _LT -> LT_; _EQ -> EQ_; GT__ -> GT_ }
+ cmp_arg (TyArg x) (TyArg y) = if x `eqTy` y then EQ_ else panic# "SimplEnv.cmp_app:TyArgs"
+ cmp_arg (UsageArg x) (UsageArg y) = panic# "SimplEnv.cmp_app:UsageArgs"
+ cmp_arg x y
+ | tag x _LT_ tag y = LT_
+ | otherwise = GT_
+ where
+ tag (VarArg _) = ILIT(1)
+ tag (LitArg _) = ILIT(2)
+ tag (TyArg _) = ILIT(3)
+ tag (UsageArg _) = ILIT(4)
\end{code}
%************************************************************************
@@ -518,7 +526,7 @@ replaceInEnvs (SimplEnv chkr encl_cc ty_env id_env unfold_env)
\begin{code}
extendIdEnvWithAtom
:: SimplEnv
- -> InBinder -> OutArg
+ -> InBinder -> OutArg{-Val args only, please-}
-> SimplEnv
extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env) (in_id,occ_info) atom@(LitArg lit)
@@ -542,6 +550,10 @@ extendIdEnvWithAtom (SimplEnv chkr encl_cc ty_env id_env unfold_env)
ok_to_dup = switchIsOn chkr SimplOkToDupCode
+#ifdef DEBUG
+extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
+#endif
+
extendIdEnvWithAtomList
:: SimplEnv
-> [(InBinder, OutArg)]
diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs
index 3e9c6aab64f490f57555500430b0ae6ff2f48029..f046fa845a38b47c89b4d5a9bfb664ef8234bc9e 100644
--- a/ghc/compiler/simplCore/SimplUtils.lhs
+++ b/ghc/compiler/simplCore/SimplUtils.lhs
@@ -246,12 +246,13 @@ which aren't WHNF but are ``cheap'' are:
\begin{code}
manifestlyCheap :: GenCoreExpr bndr Id tv uv -> Bool
-manifestlyCheap (Var _) = True
-manifestlyCheap (Lit _) = True
-manifestlyCheap (Con _ _) = True
-manifestlyCheap (SCC _ e) = manifestlyCheap e
-manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
-manifestlyCheap (Prim op _) = primOpIsCheap op
+manifestlyCheap (Var _) = True
+manifestlyCheap (Lit _) = True
+manifestlyCheap (Con _ _) = True
+manifestlyCheap (SCC _ e) = manifestlyCheap e
+manifestlyCheap (Coerce _ _ e) = manifestlyCheap e
+manifestlyCheap (Lam x e) = if isValBinder x then True else manifestlyCheap e
+manifestlyCheap (Prim op _) = primOpIsCheap op
manifestlyCheap (Let bind body)
= manifestlyCheap body && all manifestlyCheap (rhssOfBind bind)
diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs
index 76b17d945b50184520b50bedbbbbbb2413d3778f..b9aa02978f19a9313b6c4b6e111a8940b9d56a69 100644
--- a/ghc/compiler/simplCore/Simplify.lhs
+++ b/ghc/compiler/simplCore/Simplify.lhs
@@ -444,14 +444,21 @@ Let expressions
\begin{code}
simplExpr env (Let bind body) args
- | not (switchIsSet env SimplNoLetFromApp) -- The common case
- = simplBind env bind (\env -> simplExpr env body args)
- (computeResultType env body args)
- | otherwise -- No float from application
+{- OMIT this; it's a pain to do at the other sites wehre simplBind is called,
+ and it doesn't seem worth retaining the ability to not float applications
+ into let/case
+
+ | switchIsSet env SimplNoLetFromApp
= simplBind env bind (\env -> simplExpr env body [])
(computeResultType env body []) `thenSmpl` \ let_expr' ->
returnSmpl (mkGenApp let_expr' args)
+
+ | otherwise -- No float from application
+-}
+
+ = simplBind env bind (\env -> simplExpr env body args)
+ (computeResultType env body args)
\end{code}
Case expressions
@@ -464,6 +471,14 @@ simplExpr env expr@(Case scrut alts) args
\end{code}
+Coercions
+~~~~~~~~~
+\begin{code}
+simplExpr env (Coerce coercion ty body) args
+ = simplCoerce env coercion ty body args
+\end{code}
+
+
Set-cost-centre
~~~~~~~~~~~~~~~
@@ -657,6 +672,39 @@ simplLam env binders body min_no_of_args
\end{code}
+
+%************************************************************************
+%* *
+\subsection[Simplify-coerce]{Coerce expressions}
+%* *
+%************************************************************************
+
+\begin{code}
+-- (coerce (case s of p -> r)) args ==> case s of p -> (coerce r) args
+simplCoerce env coercion ty expr@(Case scrut alts) args
+ = simplCase env scrut alts (\env rhs -> simplCoerce env coercion ty rhs args)
+ (computeResultType env expr args)
+
+-- (coerce (let defns in b)) args ==> let defns' in (coerce b) args
+simplCoerce env coercion ty (Let bind body) args
+ = simplBind env bind (\env -> simplCoerce env coercion ty body args)
+ (computeResultType env body args)
+
+-- Cancellation
+simplCoerce env (CoerceIn con1) ty (Coerce (CoerceOut con2) ty2 expr) args
+ | con1 == con2
+ = simplExpr env expr args
+simplCoerce env (CoerceOut con1) ty (Coerce (CoerceIn con2) ty2 expr) args
+ | con1 == con2
+ = simplExpr env expr args
+
+-- Default case
+simplCoerce env coercion ty expr args
+ = simplExpr env expr [] `thenSmpl` \ expr' ->
+ returnSmpl (mkGenApp (Coerce coercion (simplTy env ty) expr') args)
+\end{code}
+
+
%************************************************************************
%* *
\subsection[Simplify-let]{Let-expressions}
@@ -1095,8 +1143,7 @@ completeLet
-> OutType -- Type of body
-> SmplM OutExpr
-completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
-
+completeLet env binder old_rhs new_rhs body_c body_ty
-- See if RHS is an atom, or a reusable constructor
| maybeToBool maybe_atomic_rhs
= let
@@ -1104,15 +1151,50 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
in
tick atom_tick_type `thenSmpl_`
body_c new_env
+ where
+ maybe_atomic_rhs :: Maybe (OutArg, TickType)
+ maybe_atomic_rhs = exprToAtom env new_rhs
+ -- If the RHS is atomic, we return Just (atom, tick type)
+ -- otherwise Nothing
+ Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
+completeLet env binder@(id,_) old_rhs new_rhs body_c body_ty
-- Maybe the rhs is an application of error, and sure to be demanded
| will_be_demanded &&
maybeToBool maybe_error_app
= tick CaseOfError `thenSmpl_`
returnSmpl retyped_error_app
+ where
+ will_be_demanded = willBeDemanded (getIdDemandInfo id)
+ maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
+ Just retyped_error_app = maybe_error_app
+{-
+completeLet env binder old_rhs (Coerce coercion ty rhs) body_c body_ty
+ -- Rhs is a coercion
+ | maybeToBool maybe_atomic_coerce_rhs
+ = tick tick_type `thenSmpl_`
+ complete_coerce env rhs_atom rhs
+ where
+ maybe_atomic_coerce_rhs = exprToAtom env rhs
+ Just (rhs_atom, tick_type) = maybe_atomic_coerce_rhs
+
+ returnSmpl (CoerceForm coercion rhs_atom, env)
+ Nothing
+ newId (coreExprType rhs) `thenSmpl` \ inner_id ->
+
+ complete_coerce env atom rhs
+ = cloneId env binder `thenSmpl` \ id' ->
+ let
+ env1 = extendIdEnvWithClone env binder id'
+ new_env = extendUnfoldEnvGivenFormDetails env1 id' (CoerceForm coercion rhs_atom)
+ in
+ body_c new_env `thenSmpl` \ body' ->
+ returnSmpl (Let (NonRec id' (Coerce coercion ty rhs) body')
+-}
+
+completeLet env binder old_rhs new_rhs body_c body_ty
-- The general case
- | otherwise
= cloneId env binder `thenSmpl` \ id' ->
let
env1 = extendIdEnvWithClone env binder id'
@@ -1120,40 +1202,6 @@ completeLet env binder@(id,binder_info) old_rhs new_rhs body_c body_ty
in
body_c new_env `thenSmpl` \ body' ->
returnSmpl (Let (NonRec id' new_rhs) body')
-
- where
- will_be_demanded = willBeDemanded (getIdDemandInfo id)
- try_to_reuse_constr = switchIsSet env SimplReuseCon
-
- Just (rhs_atom, atom_tick_type) = maybe_atomic_rhs
-
- maybe_atomic_rhs :: Maybe (OutArg, TickType)
- -- If the RHS is atomic, we return Just (atom, tick type)
- -- otherwise Nothing
-
- maybe_atomic_rhs
- = case new_rhs of
- Var var -> Just (VarArg var, AtomicRhs)
-
- Lit lit | not (isNoRepLit lit)
- -> Just (LitArg lit, AtomicRhs)
-
- Con con con_args
- | try_to_reuse_constr
- -- Look out for
- -- let v = C args
- -- in
- --- ...(let w = C same-args in ...)...
- -- Then use v instead of w. This may save
- -- re-constructing an existing constructor.
- -> case (lookForConstructor env con con_args) of
- Nothing -> Nothing
- Just var -> Just (VarArg var, ConReused)
-
- other -> Nothing
-
- maybe_error_app = maybeErrorApp new_rhs (Just body_ty)
- Just retyped_error_app = maybe_error_app
\end{code}
%************************************************************************
@@ -1181,6 +1229,30 @@ simplArg env (VarArg id)
\end{code}
+\begin{code}
+exprToAtom env (Var var)
+ = Just (VarArg var, AtomicRhs)
+
+exprToAtom env (Lit lit)
+ | not (isNoRepLit lit)
+ = Just (LitArg lit, AtomicRhs)
+
+exprToAtom env (Con con con_args)
+ | switchIsSet env SimplReuseCon
+ -- Look out for
+ -- let v = C args
+ -- in
+ --- ...(let w = C same-args in ...)...
+ -- Then use v instead of w. This may save
+ -- re-constructing an existing constructor.
+ = case (lookForConstructor env con con_args) of
+ Nothing -> Nothing
+ Just var -> Just (VarArg var, ConReused)
+
+exprToAtom env other
+ = Nothing
+\end{code}
+
%************************************************************************
%* *
\subsection[Simplify-quickies]{Some local help functions}
diff --git a/ghc/compiler/simplStg/SatStgRhs.lhs b/ghc/compiler/simplStg/SatStgRhs.lhs
index 5290a5434853303385ee5961d83af7dc675749e3..c8d2144c83c0b7fee38c8bbf35a5a3b7ff0e25ed 100644
--- a/ghc/compiler/simplStg/SatStgRhs.lhs
+++ b/ghc/compiler/simplStg/SatStgRhs.lhs
@@ -71,7 +71,7 @@ import Id ( idType, getIdArity, addIdArity, mkSysLocal,
)
import IdInfo ( arityMaybe )
import SrcLoc ( mkUnknownSrcLoc )
-import Type ( splitSigmaTy, splitFunTy )
+import Type ( splitSigmaTy, splitForAllTy, splitFunTyWithDictsAsArgs )
import UniqSupply ( returnUs, thenUs, mapUs, getUnique, UniqSM(..) )
import Util ( panic, assertPanic )
@@ -166,9 +166,8 @@ satRhs top env (b, StgRhsClosure cc bi fv u args body)
new_arity = num_args + needed_args
-- get type info for this function:
- (_,rho_arg_tys,tau_ty) = splitSigmaTy (idType b)
- (tau_arg_tys, _) = splitFunTy tau_ty
- all_arg_tys = ASSERT(null rho_arg_tys) {-rho_arg_tys ++-} tau_arg_tys
+ (_, rho_ty) = splitForAllTy (idType b)
+ (all_arg_tys, _) = splitFunTyWithDictsAsArgs rho_ty
-- now, we already have "args"; we drop that many types
args_we_dont_have_tys = drop num_args all_arg_tys
diff --git a/ghc/compiler/simplStg/UpdAnal.lhs b/ghc/compiler/simplStg/UpdAnal.lhs
index 553acacee3796f2e9cc9eef25a9534b45272e757..5f6092c0318e75949ee105c1d64c83135b58dcf8 100644
--- a/ghc/compiler/simplStg/UpdAnal.lhs
+++ b/ghc/compiler/simplStg/UpdAnal.lhs
@@ -31,7 +31,7 @@
> --import SrcLoc ( mkUnknownSrcLoc )
> --import StgSyn
> --import UniqSet
-> --import UniqSupply ( getBuiltinUniques )
+> --import Unique ( getBuiltinUniques )
> --import Util
%-----------------------------------------------------------------------------
diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs
index 7bac0935f0fbcbf60632c4aa5b980f7fcd882a41..990e8b2035aa3325dfaf8051468d8d863b64d860 100644
--- a/ghc/compiler/specialise/SpecUtils.lhs
+++ b/ghc/compiler/specialise/SpecUtils.lhs
@@ -33,7 +33,7 @@ import Id ( idType, isDictFunId, isConstMethodId_maybe,
GenId {-instance NamedThing -}
)
import Maybes ( maybeToBool, catMaybes, firstJust )
-import Name ( isLexVarSym, pprNonSym, moduleNamePair )
+import Name ( isLexVarSym, isLexSpecialSym, pprNonSym, moduleNamePair )
import PprStyle ( PprStyle(..) )
import PprType ( pprGenType, pprParendGenType, pprMaybeTy,
TyCon{-ditto-}, GenType{-ditto-}, GenTyVar
@@ -354,8 +354,8 @@ pp_idspec sty pp_mod (_, id, tys, is_err)
default_method_maybe = isDefaultMethodId_maybe id
is_default_method_id = maybeToBool default_method_maybe
- pp_clsop str | isLexVarSym str
- = ppBesides [ppLparen, ppPStr str, ppRparen]
+ pp_clsop str | isLexVarSym str && not (isLexSpecialSym str)
+ = ppParens (ppPStr str)
| otherwise
= ppPStr str
diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs
index 15230b43e0f6a4d8f353f14b5f6e42cd263d6dd2..d65eb8745f00636ebe1f55d4433d8aba029c62f9 100644
--- a/ghc/compiler/specialise/Specialise.lhs
+++ b/ghc/compiler/specialise/Specialise.lhs
@@ -1423,6 +1423,8 @@ specExpr (SCC cc expr) args
returnSM (applyBindUnlifts unlifts (mkGenApp scc_expr args),
unionUDList args_uds_s `unionUDs` expr_uds)
+specExpr (Coerce _ _ _) args = panic "Specialise.specExpr:Coerce"
+
-- ToDo: This may leave some unspec'd dictionaries!!
\end{code}
diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs
index e9dacd3f808159c67a21599ecbdba3ec27e5f748..233cca7020478a75a2becc1e9148de6281db2536 100644
--- a/ghc/compiler/stgSyn/CoreToStg.lhs
+++ b/ghc/compiler/stgSyn/CoreToStg.lhs
@@ -617,6 +617,12 @@ coreExprToStg env (SCC cc expr)
returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
\end{code}
+\begin{code}
+coreExprToStg env (Coerce c ty expr)
+ = coreExprToStg env expr -- `thenUs` \ (stg_expr, binds) ->
+-- returnUs (StgSCC (coreExprType expr) cc stg_expr, binds)
+\end{code}
+
%************************************************************************
%* *
diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs
index 8e08d328f8e9743534755abc1e9672ca3a67a700..ca50b0cc3a477f6e8cd7e69676fa90cd0f909002 100644
--- a/ghc/compiler/stgSyn/StgSyn.lhs
+++ b/ghc/compiler/stgSyn/StgSyn.lhs
@@ -72,6 +72,7 @@ with respect to binder and occurrence information (just as in
data GenStgBinding bndr occ
= StgNonRec bndr (GenStgRhs bndr occ)
| StgRec [(bndr, GenStgRhs bndr occ)]
+ | StgCoerceBinding bndr occ
\end{code}
%************************************************************************
@@ -516,6 +517,10 @@ pprStgBinding sty (StgNonRec bndr rhs)
= ppHang (ppCat [ppr sty bndr, ppEquals])
4 (ppBeside (ppr sty rhs) ppSemi)
+pprStgBinding sty (StgCoerceBinding bndr occ)
+ = ppHang (ppCat [ppr sty bndr, ppEquals, ppStr "{-Coerce-}"])
+ 4 (ppBeside (ppr sty occ) ppSemi)
+
pprStgBinding sty (StgRec pairs)
= ppAboves ((ifPprDebug sty (ppStr "{- StgRec -}")) :
(map (ppr_bind sty) pairs))
diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs
index 11c621fb3342ac10c11b3063954c547252c82ccb..60c943ecb593ec12f1857a87a5bc5055aea7202e 100644
--- a/ghc/compiler/stranal/SaAbsInt.lhs
+++ b/ghc/compiler/stranal/SaAbsInt.lhs
@@ -609,7 +609,8 @@ absEval anal (Let (Rec pairs) body) env
in
absEval anal body new_env
-absEval anal (SCC cc expr) env = absEval anal expr env
+absEval anal (SCC cc expr) env = absEval anal expr env
+absEval anal (Coerce c ty expr) env = absEval anal expr env
\end{code}
\begin{code}
diff --git a/ghc/compiler/stranal/StrictAnal.lhs b/ghc/compiler/stranal/StrictAnal.lhs
index dc9926d8f0f5632b9e43ae296498a2dc1d1ff9d1..3eb079baf2ec97e378706de3b893342cb3b5aab2 100644
--- a/ghc/compiler/stranal/StrictAnal.lhs
+++ b/ghc/compiler/stranal/StrictAnal.lhs
@@ -271,6 +271,10 @@ saExpr str_env abs_env (SCC cc expr)
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
returnSa (SCC cc new_expr)
+saExpr str_env abs_env (Coerce c ty expr)
+ = saExpr str_env abs_env expr `thenSa` \ new_expr ->
+ returnSa (Coerce c ty new_expr)
+
saExpr str_env abs_env (Case expr (AlgAlts alts deflt))
= saExpr str_env abs_env expr `thenSa` \ new_expr ->
saDefault str_env abs_env deflt `thenSa` \ new_deflt ->
diff --git a/ghc/compiler/stranal/WorkWrap.lhs b/ghc/compiler/stranal/WorkWrap.lhs
index 4a7b076a46d36b2f822b17dfc7d46d3e51a9e1a3..d9ef03af1b22b547b7a1212b7c3605a8305acd5e 100644
--- a/ghc/compiler/stranal/WorkWrap.lhs
+++ b/ghc/compiler/stranal/WorkWrap.lhs
@@ -114,6 +114,10 @@ wwExpr (SCC cc expr)
= wwExpr expr `thenUs` \ new_expr ->
returnUs (SCC cc new_expr)
+wwExpr (Coerce c ty expr)
+ = wwExpr expr `thenUs` \ new_expr ->
+ returnUs (Coerce c ty new_expr)
+
wwExpr (Let bind expr)
= wwBind False{-not top-level-} bind `thenUs` \ intermediate_bind ->
wwExpr expr `thenUs` \ new_expr ->
diff --git a/ghc/compiler/typecheck/GenSpecEtc.lhs b/ghc/compiler/typecheck/GenSpecEtc.lhs
index 087206a612f4908c9b15d31d40ae0975e351d34e..35554f358a8fe4eed3f87907408921c48e607a26 100644
--- a/ghc/compiler/typecheck/GenSpecEtc.lhs
+++ b/ghc/compiler/typecheck/GenSpecEtc.lhs
@@ -20,16 +20,20 @@ import Inst ( Inst, InstOrigin(..), LIE(..), plusLIE,
import TcEnv ( tcGetGlobalTyVars )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyWithExtraGlobals )
import TcType ( TcType(..), TcThetaType(..), TcTauType(..),
- TcTyVarSet(..), TcTyVar(..), tcInstType, zonkTcType )
+ TcTyVarSet(..), TcTyVar(..), tcInstType,
+ newTyVarTy, zonkTcType
+ )
+import Unify ( unifyTauTy )
import HsSyn ( HsBinds(..), Bind(..), MonoBinds(..), HsExpr, OutPat(..),
Sig, HsLit, ArithSeqInfo, InPat, GRHSsAndBinds, Match, Fake
)
-import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..), tcIdType )
+import TcHsSyn ( TcIdOcc(..), TcIdBndr(..), TcHsBinds(..), TcBind(..), TcExpr(..), tcIdType )
import Bag ( Bag, foldBag, bagToList, listToBag, isEmptyBag )
import Class ( GenClass )
import Id ( GenId, Id(..), mkUserId, idType )
+import Kind ( isUnboxedKind, isTypeKind, mkBoxedTypeKind )
import ListSetOps ( minusList, unionLists, intersectLists )
import Maybes ( Maybe(..), allMaybes )
import Outputable ( interppSP, interpp'SP )
@@ -37,7 +41,7 @@ import Pretty
import PprType ( GenClass, GenType, GenTyVar )
import Type ( mkTyVarTy, splitSigmaTy, mkForAllTys, mkFunTys,
getTyVar_maybe, tyVarsOfTypes, eqSimpleTheta )
-import TyVar ( GenTyVar, TyVar(..), minusTyVarSet, emptyTyVarSet,
+import TyVar ( GenTyVar, TyVar(..), tyVarKind, minusTyVarSet, emptyTyVarSet,
elementOfTyVarSet, unionTyVarSets, tyVarSetToList )
import Usage ( UVar(..) )
import Unique ( Unique )
@@ -151,9 +155,27 @@ genBinds binder_names mono_ids bind lie sig_infos prag_info_fn
resolveOverloading tyvars_to_gen lie bind sig_infos
`thenTc` \ (lie', reduced_tyvars_to_gen, dict_binds, dicts_bound) ->
+ -- Check for generaliseation over unboxed types, and
+ -- default any TypeKind TyVars to BoxedTypeKind
+ let
+ tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order
+
+ unboxed_kind_tyvars = filter (isUnboxedKind . tyVarKind) tyvars
+ unresolved_kind_tyvars = filter (isTypeKind . tyVarKind) tyvars
+
+ box_it tyvar = newTyVarTy mkBoxedTypeKind `thenNF_Tc` \ boxed_ty ->
+ unifyTauTy (mkTyVarTy tyvar) boxed_ty
+
+ in
+ ASSERT( null unboxed_kind_tyvars ) -- The instCantBeGeneralised stuff in tcSimplify
+ -- should have dealt with unboxed type variables;
+ -- and it's better done there because we have more
+ -- precise origin information
+
+ mapTc box_it unresolved_kind_tyvars `thenTc_`
+
-- BUILD THE NEW LOCALS
let
- tyvars = tyVarSetToList reduced_tyvars_to_gen -- Commit to a particular order
dict_tys = map tcIdType dicts_bound
poly_tys = map (mkForAllTys tyvars . mkFunTys dict_tys) mono_id_types
poly_ids = zipWithEqual mk_poly binder_names poly_tys
diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs
index d0615f6bf6f3bf6590ba177f6f6e1304fe123c72..be598f202cb12146473a9a302e24778f9f598d67 100644
--- a/ghc/compiler/typecheck/Inst.lhs
+++ b/ghc/compiler/typecheck/Inst.lhs
@@ -341,35 +341,31 @@ relevant in error messages.
\begin{code}
instance Outputable (Inst s) where
ppr sty (LitInst uniq lit ty orig loc)
- = ppHang (ppSep [case lit of
+ = ppSep [case lit of
OverloadedIntegral i -> ppInteger i
OverloadedFractional f -> ppRational f,
- ppStr "at",
- ppr sty ty,
- show_uniq sty uniq
- ])
- 4 (show_origin sty orig)
+ ppStr "at",
+ ppr sty ty,
+ show_uniq sty uniq
+ ]
ppr sty (Dict uniq clas ty orig loc)
- = ppHang (ppSep [ppr sty clas,
- ppStr "at",
- ppr sty ty,
- show_uniq sty uniq
- ])
- 4 (show_origin sty orig)
+ = ppSep [ppr sty clas,
+ ppStr "at",
+ ppr sty ty,
+ show_uniq sty uniq
+ ]
ppr sty (Method uniq id tys rho orig loc)
- = ppHang (ppSep [ppr sty id,
- ppStr "at",
- ppr sty tys,
- show_uniq sty uniq
- ])
- 4 (show_origin sty orig)
+ = ppSep [ppr sty id,
+ ppStr "at",
+ ppr sty tys,
+ show_uniq sty uniq
+ ]
show_uniq PprDebug uniq = ppr PprDebug uniq
show_uniq sty uniq = ppNil
-show_origin sty orig = ppBesides [ppLparen, pprOrigin sty orig, ppRparen]
\end{code}
Printing in error messages
@@ -412,7 +408,9 @@ lookupInst :: Inst s
lookupInst dict@(Dict _ clas ty orig loc)
= case lookupMEnv matchTy (get_inst_env clas orig) ty of
- Nothing -> failTc (noInstanceErr dict)
+ Nothing -> tcAddSrcLoc loc $
+ tcAddErrCtxt (pprOrigin orig) $
+ failTc (noInstanceErr dict)
Just (dfun_id, tenv)
-> let
@@ -603,49 +601,49 @@ get_inst_env clas (InstanceSpecOrigin inst_mapper _ _)
get_inst_env clas other_orig = classInstEnv clas
-pprOrigin :: PprStyle -> InstOrigin s -> Pretty
+pprOrigin :: InstOrigin s -> PprStyle -> Pretty
-pprOrigin sty (OccurrenceOf id)
+pprOrigin (OccurrenceOf id) sty
= ppBesides [ppPStr SLIT("at a use of an overloaded identifier: `"),
ppr sty id, ppChar '\'']
-pprOrigin sty (OccurrenceOfCon id)
+pprOrigin (OccurrenceOfCon id) sty
= ppBesides [ppPStr SLIT("at a use of an overloaded constructor: `"),
ppr sty id, ppChar '\'']
-pprOrigin sty (InstanceDeclOrigin)
+pprOrigin (InstanceDeclOrigin) sty
= ppStr "in an instance declaration"
-pprOrigin sty (LiteralOrigin lit)
+pprOrigin (LiteralOrigin lit) sty
= ppCat [ppStr "at an overloaded literal:", ppr sty lit]
-pprOrigin sty (ArithSeqOrigin seq)
+pprOrigin (ArithSeqOrigin seq) sty
= ppCat [ppStr "at an arithmetic sequence:", ppr sty seq]
-pprOrigin sty (SignatureOrigin)
+pprOrigin (SignatureOrigin) sty
= ppStr "in a type signature"
-pprOrigin sty (DoOrigin)
+pprOrigin (DoOrigin) sty
= ppStr "in a do statement"
-pprOrigin sty (ClassDeclOrigin)
+pprOrigin (ClassDeclOrigin) sty
= ppStr "in a class declaration"
-pprOrigin sty (DerivingOrigin _ clas tycon)
+pprOrigin (DerivingOrigin _ clas tycon) sty
= ppBesides [ppStr "in a `deriving' clause; class `",
ppr sty clas,
ppStr "'; offending type `",
ppr sty tycon,
ppStr "'"]
-pprOrigin sty (InstanceSpecOrigin _ clas ty)
+pprOrigin (InstanceSpecOrigin _ clas ty) sty
= ppBesides [ppStr "in a SPECIALIZE instance pragma; class \"",
ppr sty clas, ppStr "\" type: ", ppr sty ty]
-pprOrigin sty (DefaultDeclOrigin)
+pprOrigin (DefaultDeclOrigin) sty
= ppStr "in a `default' declaration"
-pprOrigin sty (ValSpecOrigin name)
+pprOrigin (ValSpecOrigin name) sty
= ppBesides [ppStr "in a SPECIALIZE user-pragma for `",
ppr sty name, ppStr "'"]
-pprOrigin sty (CCallOrigin clabel Nothing{-ccall result-})
+pprOrigin (CCallOrigin clabel Nothing{-ccall result-}) sty
= ppBesides [ppStr "in the result of the _ccall_ to `",
ppStr clabel, ppStr "'"]
-pprOrigin sty (CCallOrigin clabel (Just arg_expr))
+pprOrigin (CCallOrigin clabel (Just arg_expr)) sty
= ppBesides [ppStr "in an argument in the _ccall_ to `",
ppStr clabel, ppStr "', namely: ", ppr sty arg_expr]
-pprOrigin sty (LitLitOrigin s)
+pprOrigin (LitLitOrigin s) sty
= ppBesides [ppStr "in this ``literal-literal'': ", ppStr s]
-pprOrigin sty UnknownOrigin
+pprOrigin UnknownOrigin sty
= ppStr "in... oops -- I don't know where the overloading came from!"
\end{code}
diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs
index 88667f095142751d522bc5a58dfe3acdba642deb..4d4a1ad24893c254d1e3f9e5ffc6584ee8e972fa 100644
--- a/ghc/compiler/typecheck/TcBinds.lhs
+++ b/ghc/compiler/typecheck/TcBinds.lhs
@@ -249,6 +249,10 @@ data SigInfo
`thenTc` \ (tyvars_not_to_gen, tyvars_to_gen, lie_to_gen) ->
+ *** CHECK FOR UNBOXED TYVARS HERE! ***
+
+
+
-- Make poly_ids for all the binders that don't have type signatures
let
tys_to_gen = mkTyVarTys tyvars_to_gen
diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs
index 6b2bec7a860b4a93e7221ef31c65926b9b2ed006..6454e1a530474d732069d7ac45ab03d027927d7c 100644
--- a/ghc/compiler/typecheck/TcExpr.lhs
+++ b/ghc/compiler/typecheck/TcExpr.lhs
@@ -361,7 +361,7 @@ tcExpr (ExplicitTuple exprs)
tcExpr (RecordCon (HsVar con) rbinds)
= tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) ->
let
- (_, record_ty) = splitFunTy con_tau
+ (_, record_ty) = splitFunTy con_tau
in
-- Con is syntactically constrained to be a data constructor
ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) )
@@ -708,6 +708,12 @@ tcListComp expr (qual@(GeneratorQual pat rhs) : quals)
tcAddErrCtxt (qualCtxt qual) (
tcPat pat `thenTc` \ (pat', lie_pat, pat_ty) ->
tcExpr rhs `thenTc` \ (rhs', lie_rhs, rhs_ty) ->
+ -- NB: the environment has been extended with the new binders
+ -- which the rhs can't "see", but the renamer should have made
+ -- sure that everything is distinct by now, so there's no problem.
+ -- Putting the tcExpr before the newMonoIds messes up the nesting
+ -- of error contexts, so I didn't bother
+
unifyTauTy (mkListTy pat_ty) rhs_ty `thenTc_`
returnTc (GeneratorQual pat' rhs',
lie_pat `plusLIE` lie_rhs)
diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs
index 051d6cd27c5c7c1d5fe6705d1816b8a54dc4efd4..d70b25c95d3613297a0ee29c5bfcbff5eaa87e72 100644
--- a/ghc/compiler/typecheck/TcHsSyn.lhs
+++ b/ghc/compiler/typecheck/TcHsSyn.lhs
@@ -124,6 +124,7 @@ tcIdType other = panic "tcIdType"
instance Eq (TcIdOcc s) where
(TcId id1) == (TcId id2) = id1 == id2
(RealId id1) == (RealId id2) = id1 == id2
+ _ == _ = False
instance Outputable (TcIdOcc s) where
ppr sty (TcId id) = ppr sty id
diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs
index c45d8099dc1d82f17517ea1f7bf8195128232c6b..3ea432f2a073a558ffe437d9e1e9b67895f509bb 100644
--- a/ghc/compiler/typecheck/TcInstDcls.lhs
+++ b/ghc/compiler/typecheck/TcInstDcls.lhs
@@ -73,10 +73,11 @@ import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon,
import PprStyle
import Pretty
import RnUtils ( RnEnv(..) )
-import TyCon ( derivedFor )
+import TyCon ( isSynTyCon, derivedFor )
import Type ( GenType(..), ThetaType(..), mkTyVarTys,
splitSigmaTy, splitAppTy, isTyVarTy, matchTy, mkSigmaTy,
- getTyCon_maybe, maybeBoxedPrimType )
+ getTyCon_maybe, maybeBoxedPrimType
+ )
import TyVar ( GenTyVar, mkTyVarSet )
import TysWiredIn ( stringTy )
import Unique ( Unique )
@@ -889,7 +890,7 @@ We can also have instances for functions: @instance Foo (a -> b) ...@.
\begin{code}
scrutiniseInstanceType from_here clas inst_tau
-- TYCON CHECK
- | not (maybeToBool inst_tycon_maybe)
+ | not (maybeToBool inst_tycon_maybe) || isSynTyCon inst_tycon
= failTc (instTypeErr inst_tau)
-- IMPORTED INSTANCES ARE OK (but see tcInstDecl1)
diff --git a/ghc/compiler/typecheck/TcKind.lhs b/ghc/compiler/typecheck/TcKind.lhs
index 05b4a03a41b8328c7efffd8b4a13e6eb80fc5f3c..71cba23e9fbac4ab711b69dc4cddae8dcce1aeaf 100644
--- a/ghc/compiler/typecheck/TcKind.lhs
+++ b/ghc/compiler/typecheck/TcKind.lhs
@@ -2,8 +2,8 @@
module TcKind (
Kind, mkTypeKind, mkBoxedTypeKind, mkUnboxedTypeKind, mkArrowKind,
- isSubKindOf, -- Kind -> Kind -> Bool
- resultKind, -- Kind -> Kind
+ hasMoreBoxityInfo, -- Kind -> Kind -> Bool
+ resultKind, -- Kind -> Kind
TcKind, mkTcTypeKind, mkTcArrowKind, mkTcVarKind,
newKindVar, -- NF_TcM s (TcKind s)
diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs
index 70c05648eae477766a95a7a647b06b3037aeed49..78d56f485f48e6241dc787e7e707ae6a71237c22 100644
--- a/ghc/compiler/typecheck/TcTyClsDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs
@@ -39,7 +39,7 @@ import UniqSet ( UniqSet(..), emptyUniqSet,
unitUniqSet, unionUniqSets,
unionManyUniqSets, uniqSetToList )
import SrcLoc ( SrcLoc )
-import TyCon ( TyCon, tyConDataCons, isDataTyCon )
+import TyCon ( TyCon, tyConDataCons, isDataTyCon, isSynTyCon )
import Unique ( Unique )
import Util ( panic, pprTrace )
@@ -121,7 +121,8 @@ tcGroup inst_mapper decls
-- Create any necessary record selector Ids and their bindings
- mapAndUnzipTc mkDataBinds (filter isDataTyCon tycons) `thenTc` \ (data_ids_s, binds) ->
+ -- "Necessary" includes data and newtype declarations
+ mapAndUnzipTc mkDataBinds (filter (not.isSynTyCon) tycons) `thenTc` \ (data_ids_s, binds) ->
-- Extend the global value environment with
-- a) constructors
diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs
index 71f0228e824213115abb289a2fcef9b5c175c8f4..cd62d7cb3bf65acd44fe2eac2934a1947d2f32cc 100644
--- a/ghc/compiler/typecheck/TcTyDecls.lhs
+++ b/ghc/compiler/typecheck/TcTyDecls.lhs
@@ -49,7 +49,8 @@ import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc,
)
import Pretty
import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon,
- tyConDataCons )
+ isNewTyCon, tyConDataCons
+ )
import Type ( typeKind, getTyVar, tyVarsOfTypes, eqTy,
applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy,
splitFunTy, mkTyVarTy, getTyVar_maybe
@@ -163,7 +164,7 @@ Generating constructor/selector bindings for data declarations
\begin{code}
mkDataBinds :: TyCon -> TcM s ([Id], TcHsBinds s)
mkDataBinds tycon
- = ASSERT( isDataTyCon tycon )
+ = ASSERT( isDataTyCon tycon || isNewTyCon tycon )
mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) ->
mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) ->
returnTc (con_ids ++ sel_ids,
diff --git a/ghc/compiler/typecheck/Unify.lhs b/ghc/compiler/typecheck/Unify.lhs
index 4eb7b3f8e9c694265d752ff8820afa5cbd0ffceb..ad979b77349cd0f4c68326c7aeffbf99cf75fde5 100644
--- a/ghc/compiler/typecheck/Unify.lhs
+++ b/ghc/compiler/typecheck/Unify.lhs
@@ -22,7 +22,7 @@ import TcType ( TcType(..), TcMaybe(..), TcTauType(..), TcTyVar(..),
newTyVarTy, tcReadTyVar, tcWriteTyVar, zonkTcType
)
-- others:
-import Kind ( Kind, isSubKindOf, mkTypeKind )
+import Kind ( Kind, hasMoreBoxityInfo, mkTypeKind )
import Usage ( duffUsage )
import PprType ( GenTyVar, GenType ) -- instances
import Pretty
@@ -232,10 +232,10 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1)
(DontBind,DontBind)
-> failTc (unifyDontBindErr tv1 ps_ty2)
- (UnBound, _) | kind2 `isSubKindOf` kind1
+ (UnBound, _) | kind2 `hasMoreBoxityInfo` kind1
-> tcWriteTyVar tv1 ty2 `thenNF_Tc_` returnTc ()
- (_, UnBound) | kind1 `isSubKindOf` kind2
+ (_, UnBound) | kind1 `hasMoreBoxityInfo` kind2
-> tcWriteTyVar tv2 (TyVarTy tv1) `thenNF_Tc_` returnTc ()
other -> failTc (unifyKindErr tv1 ps_ty2)
@@ -245,7 +245,7 @@ uUnboundVar tv1@(TyVar uniq1 kind1 name1 box1) maybe_ty1 ps_ty2 non_var_ty2
= case maybe_ty1 of
DontBind -> failTc (unifyDontBindErr tv1 ps_ty2)
- UnBound | typeKind non_var_ty2 `isSubKindOf` kind1
+ UnBound | typeKind non_var_ty2 `hasMoreBoxityInfo` kind1
-> occur_check non_var_ty2 `thenTc_`
tcWriteTyVar tv1 ps_ty2 `thenNF_Tc_`
returnTc ()
diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs
index 9fe3df3dfcd7f11a754fcfc56239fa2dd91d6e01..ad6875d494a9ced34aab92e061022ebf07fde90f 100644
--- a/ghc/compiler/types/Kind.lhs
+++ b/ghc/compiler/types/Kind.lhs
@@ -4,6 +4,8 @@
\section[Kind]{The @Kind@ datatype}
\begin{code}
+#include "HsVersions.h"
+
module Kind (
Kind(..), -- Only visible to friends: TcKind
@@ -12,13 +14,15 @@ module Kind (
mkUnboxedTypeKind,
mkBoxedTypeKind,
- isSubKindOf,
- resultKind, argKind
+ hasMoreBoxityInfo,
+ resultKind, argKind,
+
+ isUnboxedKind, isTypeKind
) where
import Ubiq{-uitous-}
-import Util ( panic )
+import Util ( panic, assertPanic )
--import Outputable ( Outputable(..) )
import Pretty
\end{code}
@@ -36,11 +40,31 @@ mkTypeKind = TypeKind
mkUnboxedTypeKind = UnboxedTypeKind
mkBoxedTypeKind = BoxedTypeKind
-isSubKindOf :: Kind -> Kind -> Bool
+isTypeKind :: Kind -> Bool
+isTypeKind TypeKind = True
+isTypeKind other = False
+
+isUnboxedKind :: Kind -> Bool
+isUnboxedKind UnboxedTypeKind = True
+isUnboxedKind other = False
+
+hasMoreBoxityInfo :: Kind -> Kind -> Bool
+
+BoxedTypeKind `hasMoreBoxityInfo` TypeKind = True
+BoxedTypeKind `hasMoreBoxityInfo` BoxedTypeKind = True
+
+UnboxedTypeKind `hasMoreBoxityInfo` TypeKind = True
+UnboxedTypeKind `hasMoreBoxityInfo` UnboxedTypeKind = True
+
+TypeKind `hasMoreBoxityInfo` TypeKind = True
+
+kind1 `hasMoreBoxityInfo` kind2 = ASSERT( notArrowKind kind1 &&
+ notArrowKind kind2 )
+ False
-BoxedTypeKind `isSubKindOf` TypeKind = True
-UnboxedTypeKind `isSubKindOf` TypeKind = True
-kind1 `isSubKindOf` kind2 = kind1 == kind2
+-- Not exported
+notArrowKind (ArrowKind _ _) = False
+notArrowKind other_kind = True
resultKind :: Kind -> Kind -- Get result from arrow kind
resultKind (ArrowKind _ res_kind) = res_kind
diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs
index fa790ac7141a76bc445143e9d9126d593811b1a0..c066295e093af062e82cd57eb423994da26c9bf7 100644
--- a/ghc/compiler/types/PprType.lhs
+++ b/ghc/compiler/types/PprType.lhs
@@ -17,7 +17,11 @@ module PprType(
typeMaybeString,
specMaybeTysSuffix,
GenClass,
- GenClassOp, pprGenClassOp
+ GenClassOp, pprGenClassOp,
+
+ addTyVar, nmbrTyVar,
+ addUVar, nmbrUsage,
+ nmbrType, nmbrTyCon, nmbrClass
) where
import Ubiq
@@ -33,19 +37,22 @@ import TyCon ( TyCon(..), NewOrData )
import Class ( Class(..), GenClass(..),
ClassOp(..), GenClassOp(..) )
import Kind ( Kind(..) )
+import Usage ( GenUsage(..) )
-- others:
import CStrings ( identToC )
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( maybeToBool )
-import Name ( isLexVarSym, isPreludeDefined, origName, moduleOf,
+import Name ( isLexVarSym, isLexSpecialSym, isPreludeDefined, origName, moduleOf,
Name{-instance Outputable-}
)
import Outputable ( ifPprShowAll, interpp'SP )
+import PprEnv
import PprStyle ( PprStyle(..), codeStyle, showUserishTypes )
import Pretty
import TysWiredIn ( listTyCon )
-import Unique ( pprUnique10, pprUnique )
+import UniqFM ( addToUFM_Directly, lookupUFM_Directly, ufmToList{-ToDo:rm-} )
+import Unique ( pprUnique10, pprUnique, incrUnique )
import Usage ( UVar(..), pprUVar )
import Util
\end{code}
@@ -91,11 +98,11 @@ works just by setting the initial context precedence very high.
pprGenType, pprParendGenType :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> PprStyle -> GenType tyvar uvar -> Pretty
-pprGenType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC ty
-pprParendGenType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC ty
+pprGenType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC ty
+pprParendGenType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC ty
-pprType sty ty = ppr_ty sty (initial_ve sty) tOP_PREC (ty :: Type)
-pprParendType sty ty = ppr_ty sty (initial_ve sty) tYCON_PREC (ty :: Type)
+pprType sty ty = ppr_ty sty (init_ppr_env sty) tOP_PREC (ty :: Type)
+pprParendType sty ty = ppr_ty sty (init_ppr_env sty) tYCON_PREC (ty :: Type)
pprMaybeTy :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
=> PprStyle -> Maybe (GenType tyvar uvar) -> Pretty
@@ -105,7 +112,7 @@ pprMaybeTy sty (Just ty) = pprParendGenType sty ty
\begin{code}
ppr_ty :: (Eq tyvar, Outputable tyvar, Eq uvar, Outputable uvar)
- => PprStyle -> VarEnv tyvar uvar -> Int
+ => PprStyle -> PprEnv tyvar uvar bndr occ -> Int
-> GenType tyvar uvar
-> Pretty
@@ -134,15 +141,15 @@ ppr_ty sty env ctxt_prec (ForAllUsageTy uv uvs ty)
ppr_ty sty env ctxt_prec ty@(FunTy (DictTy _ _ _) _ _)
| showUserishTypes sty
-- Print a nice looking context (Eq a, Text b) => ...
- = ppSep [ppBesides [ppLparen,
- ppIntersperse pp'SP (map (ppr_dict sty env tOP_PREC) theta),
- ppRparen],
- ppPStr SLIT("=>"),
+ = ppSep [ppBeside (ppr_theta theta) (ppPStr SLIT(" =>")),
ppr_ty sty env ctxt_prec body_ty
]
where
(theta, body_ty) = splitRhoTy ty
+ ppr_theta [ct] = ppr_dict sty env tOP_PREC ct
+ ppr_theta cts = ppParens (ppInterleave ppComma (map (ppr_dict sty env tOP_PREC) cts))
+
ppr_ty sty env ctxt_prec (FunTy ty1 ty2 usage)
-- We fiddle the precedences passed to left/right branches,
-- so that right associativity comes out nicely...
@@ -214,52 +221,19 @@ ppr_dict sty env ctxt_prec (clas, ty)
(ppCat [ppr sty clas, ppr_ty sty env tYCON_PREC ty])
\end{code}
-Nota Bene: we must assign print-names to the forall'd type variables
-alphabetically, with the first forall'd variable having the alphabetically
-first name. Reason: so anyone reading the type signature printed without
-explicit forall's will be able to reconstruct them in the right order.
-
+This stuff is effectively stubbed out for the time being
+(WDP 960425):
\begin{code}
--- Entirely local to this module
-data VarEnv tyvar uvar
- = VE [Pretty] -- Tyvar pretty names
- (tyvar -> Pretty) -- Tyvar lookup function
- [Pretty] -- Uvar pretty names
- (uvar -> Pretty) -- Uvar lookup function
-
-initial_ve PprForC = VE [] (\tv -> ppChar '*')
- [] (\tv -> ppChar '#')
-
-initial_ve sty = VE tv_pretties (ppr sty)
- uv_pretties (ppr sty)
- where
- tv_pretties = map (\ c -> ppChar c ) ['a' .. 'h']
- ++
- map (\ n -> ppBeside (ppChar 'a') (ppInt n))
- ([0 .. ] :: [Int]) -- a0 ... aN
-
- uv_pretties = map (\ c -> ppChar c ) ['u' .. 'y']
- ++
- map (\ n -> ppBeside (ppChar 'u') (ppInt n))
- ([0 .. ] :: [Int]) -- u0 ... uN
-
-
-ppr_tyvar (VE _ ppr _ _) tyvar = ppr tyvar
-ppr_uvar (VE _ _ _ ppr) uvar = ppr uvar
-
-add_tyvar ve@(VE [] _ _ _) tyvar = ve
-add_tyvar (VE (tv_pp:tv_supply') tv_ppr uv_supply uv_ppr) tyvar
- = VE tv_supply' tv_ppr' uv_supply uv_ppr
+init_ppr_env sty
+ = initPprEnv sty b b b b b b b b b b b
where
- tv_ppr' tv | tv==tyvar = tv_pp
- | otherwise = tv_ppr tv
+ b = panic "PprType:init_ppr_env"
-add_uvar ve@(VE _ _ [] _) uvar = ve
-add_uvar (VE tv_supply tv_ppr (uv_pp:uv_supply') uv_ppr) uvar
- = VE tv_supply tv_ppr uv_supply' uv_ppr'
- where
- uv_ppr' uv | uv==uvar = uv_pp
- | otherwise = uv_ppr uv
+ppr_tyvar env tyvar = ppr (pStyle env) tyvar
+ppr_uvar env uvar = ppr (pStyle env) uvar
+
+add_tyvar env tyvar = env
+add_uvar env uvar = env
\end{code}
@ppr_ty@ takes an @Int@ that is the precedence of the context.
@@ -289,8 +263,11 @@ maybeParen ctxt_prec inner_prec pretty
\begin{code}
pprGenTyVar sty (TyVar uniq kind name usage)
- = ppBesides [pp_name, pprUnique10 uniq]
+ = case sty of
+ PprInterface -> pp_u
+ _ -> ppBeside pp_name pp_u
where
+ pp_u = pprUnique10 uniq
pp_name = case name of
Just n -> ppr sty n
Nothing -> case kind of
@@ -360,15 +337,15 @@ ppr_class_op sty tyvars (ClassOp op_name i ty)
_ -> pp_user
where
pp_C = ppPStr op_name
- pp_user = if isLexVarSym op_name
- then ppBesides [ppLparen, pp_C, ppRparen]
+ pp_user = if isLexVarSym op_name && not (isLexSpecialSym op_name)
+ then ppParens pp_C
else pp_C
\end{code}
%************************************************************************
%* *
-\subsection[]{Mumbo jumbo}
+\subsection{Mumbo jumbo}
%* *
%************************************************************************
@@ -426,164 +403,161 @@ specMaybeTysSuffix ty_maybes
_CONCAT_ dotted_tys
\end{code}
-========================================================
- INTERFACE STUFF; move it out
-
+ToDo: possibly move:
+\begin{code}
+nmbrType :: Type -> NmbrM Type
+
+nmbrType (TyVarTy tv)
+ = nmbrTyVar tv `thenNmbr` \ new_tv ->
+ returnNmbr (TyVarTy new_tv)
+
+nmbrType (AppTy t1 t2)
+ = nmbrType t1 `thenNmbr` \ new_t1 ->
+ nmbrType t2 `thenNmbr` \ new_t2 ->
+ returnNmbr (AppTy new_t1 new_t2)
+
+nmbrType (TyConTy tc use)
+ = --nmbrTyCon tc `thenNmbr` \ new_tc ->
+ nmbrUsage use `thenNmbr` \ new_use ->
+ returnNmbr (TyConTy tc new_use)
+
+nmbrType (SynTy tc args expand)
+ = --nmbrTyCon tc `thenNmbr` \ new_tc ->
+ mapNmbr nmbrType args `thenNmbr` \ new_args ->
+ nmbrType expand `thenNmbr` \ new_expand ->
+ returnNmbr (SynTy tc new_args new_expand)
+
+nmbrType (ForAllTy tv ty)
+ = addTyVar tv `thenNmbr` \ new_tv ->
+ nmbrType ty `thenNmbr` \ new_ty ->
+ returnNmbr (ForAllTy new_tv new_ty)
+
+nmbrType (ForAllUsageTy u us ty)
+ = addUVar u `thenNmbr` \ new_u ->
+ mapNmbr nmbrUVar us `thenNmbr` \ new_us ->
+ nmbrType ty `thenNmbr` \ new_ty ->
+ returnNmbr (ForAllUsageTy new_u new_us new_ty)
+
+nmbrType (FunTy t1 t2 use)
+ = nmbrType t1 `thenNmbr` \ new_t1 ->
+ nmbrType t2 `thenNmbr` \ new_t2 ->
+ nmbrUsage use `thenNmbr` \ new_use ->
+ returnNmbr (FunTy new_t1 new_t2 new_use)
+
+nmbrType (DictTy c ty use)
+ = --nmbrClass c `thenNmbr` \ new_c ->
+ nmbrType ty `thenNmbr` \ new_ty ->
+ nmbrUsage use `thenNmbr` \ new_use ->
+ returnNmbr (DictTy c new_ty new_use)
+\end{code}
-\begin{pseudocode}
-pprTyCon sty@PprInterface (SynonymTyCon k n a vs exp unabstract) specs
- = ASSERT (null specs)
- let
- lookup_fn = mk_lookup_tyvar_fn sty vs
- pp_tyvars = map lookup_fn vs
- in
- ppCat [ppPStr SLIT("type"), ppr sty n, ppIntersperse ppSP pp_tyvars,
- ppEquals, ppr_ty sty lookup_fn tOP_PREC exp]
-
-pprTyCon sty@PprInterface this_tycon@(DataTyCon u n k vs ctxt cons derivings data_or_new) specs
- = ppHang (ppCat [pp_data_or_new,
- pprContext sty ctxt,
- ppr sty n,
- ppIntersperse ppSP (map lookup_fn vs)])
- 4
- (ppCat [pp_unabstract_condecls,
- pp_pragma])
- -- NB: we do not print deriving info in interfaces
- where
- lookup_fn = mk_lookup_tyvar_fn sty vs
-
- pp_data_or_new = case data_or_new of
- DataType -> ppPStr SLIT("data")
- NewType -> ppPStr SLIT("newtype")
-
- yes_we_print_condecls
- = unabstract
- && not (null cons) -- we know what they are
- && (case (getExportFlag n) of
- ExportAbs -> False
- other -> True)
-
- yes_we_print_pragma_condecls
- = not yes_we_print_condecls
- && not opt_OmitInterfacePragmas
- && not (null cons)
- && not (maybeToBool (maybePurelyLocalTyCon this_tycon))
- {- && not (any (dataConMentionsNonPreludeTyCon this_tycon) cons) -}
-
- yes_we_print_pragma_specs
- = not (null specs)
-
- pp_unabstract_condecls
- = if yes_we_print_condecls
- then ppCat [ppSP, ppEquals, pp_condecls]
- else ppNil
-
- pp_pragma_condecls
- = if yes_we_print_pragma_condecls
- then pp_condecls
- else ppNil
-
- pp_pragma_specs
- = if yes_we_print_pragma_specs
- then pp_specs
- else ppNil
-
- pp_pragma
- = if (yes_we_print_pragma_condecls || yes_we_print_pragma_specs)
- then ppCat [ppStr "\t{-# GHC_PRAGMA", pp_pragma_condecls, pp_pragma_specs, ppStr "#-}"]
- else ppNil
-
- pp_condecls
- = let
- (c:cs) = cons
+\begin{code}
+addTyVar, nmbrTyVar :: TyVar -> NmbrM TyVar
+
+addTyVar tv@(TyVar u k maybe_name use) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = --pprTrace "addTyVar:" (ppCat [pprUnique u, pprUnique ut]) $
+ case (lookupUFM_Directly tvenv u) of
+ Just xx -> pprTrace "addTyVar: already in map!" (ppr PprDebug tv) $
+ (nenv, xx)
+ Nothing ->
+ let
+ nenv_plus_tv = NmbrEnv ui (incrUnique ut) uu
+ idenv
+ (addToUFM_Directly tvenv u new_tv)
+ uvenv
+
+ (nenv2, new_use) = nmbrUsage use nenv_plus_tv
+
+ new_tv = TyVar ut k maybe_name new_use
in
- ppCat ((ppr_con c) : (map ppr_next_con cs))
- where
- ppr_con con
- = let
- (_, _, con_arg_tys, _) = dataConSig con
- in
- ppCat [pprNonSym PprForUser con, -- the data con's name...
- ppIntersperse ppSP (map (ppr_ty sty lookup_fn tYCON_PREC) con_arg_tys)]
-
- ppr_next_con con = ppCat [ppChar '|', ppr_con con]
-
- pp_specs
- = ppBesides [ppPStr SLIT("_SPECIALIZE_ "), pp_the_list [
- ppCat [ppLbrack, ppInterleave ppComma (map pp_maybe ty_maybes), ppRbrack]
- | ty_maybes <- specs ]]
-
- pp_the_list [p] = p
- pp_the_list (p:ps) = ppAbove (ppBeside p ppComma) (pp_the_list ps)
-
- pp_maybe Nothing = pp_NONE
- pp_maybe (Just ty) = pprParendGenType sty ty
-
- pp_NONE = ppPStr SLIT("_N_")
-
-pprTyCon PprInterface (TupleTyCon _ name _) specs
- = ASSERT (null specs)
- ppCat [ ppStr "{- ", ppr PprForUser name, ppStr "-}" ]
-
-pprTyCon PprInterface (PrimTyCon k n a kind_fn) specs
- = ASSERT (null specs)
- ppCat [ ppStr "{- data", ppr PprForUser n, ppStr " *built-in* -}" ]
-
-
+ (nenv2, new_tv)
+
+nmbrTyVar tv@(TyVar u _ _ _) nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = case (lookupUFM_Directly tvenv u) of
+ Just xx -> (nenv, xx)
+ Nothing ->
+ pprTrace "nmbrTyVar: lookup failed:" (ppCat (ppr PprDebug u : [ppCat [ppr PprDebug x, ppStr "=>", ppr PprDebug tv] | (x,tv) <- ufmToList tvenv])) $
+ (nenv, tv)
+\end{code}
+nmbrTyCon : only called from ``top-level'', if you know what I mean.
+\begin{code}
+nmbrTyCon tc@FunTyCon = returnNmbr tc
+nmbrTyCon tc@(TupleTyCon _ _ _) = returnNmbr tc
+nmbrTyCon tc@(PrimTyCon _ _ _) = returnNmbr tc
+
+nmbrTyCon (DataTyCon u n k tvs theta cons clss nod)
+ = --pprTrace "nmbrDataTyCon:" (ppCat (map (ppr PprDebug) tvs)) $
+ mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
+ mapNmbr nmbr_theta theta `thenNmbr` \ new_theta ->
+ mapNmbr nmbrId cons `thenNmbr` \ new_cons ->
+ returnNmbr (DataTyCon u n k new_tvs new_theta new_cons clss nod)
+ where
+ nmbr_theta (c,t)
+ = --nmbrClass c `thenNmbr` \ new_c ->
+ nmbrType t `thenNmbr` \ new_t ->
+ returnNmbr (c, new_t)
+
+nmbrTyCon (SynTyCon u n k a tvs expand)
+ = mapNmbr addTyVar tvs `thenNmbr` \ new_tvs ->
+ nmbrType expand `thenNmbr` \ new_expand ->
+ returnNmbr (SynTyCon u n k a new_tvs new_expand)
+
+nmbrTyCon (SpecTyCon tc specs)
+ = mapNmbr nmbrMaybeTy specs `thenNmbr` \ new_specs ->
+ returnNmbr (SpecTyCon tc new_specs)
+
+-----------
+nmbrMaybeTy Nothing = returnNmbr Nothing
+nmbrMaybeTy (Just t) = nmbrType t `thenNmbr` \ new_t ->
+ returnNmbr (Just new_t)
+\end{code}
+\begin{code}
+nmbrClass (Class u n tv supers ssels ops osels odefms instenv isupers)
+ = addTyVar tv `thenNmbr` \ new_tv ->
+ mapNmbr nmbr_op ops `thenNmbr` \ new_ops ->
+ returnNmbr (Class u n new_tv supers ssels new_ops osels odefms instenv isupers)
+ where
+ nmbr_op (ClassOp n tag ty)
+ = nmbrType ty `thenNmbr` \ new_ty ->
+ returnNmbr (ClassOp n tag new_ty)
+\end{code}
-pprIfaceClass :: (Id -> Id) -> IdEnv UnfoldingDetails -> Class -> Pretty
+\begin{code}
+nmbrUsage :: Usage -> NmbrM Usage
+
+nmbrUsage u = returnNmbr u
+{- LATER:
+nmbrUsage u@UsageOne = returnNmbr u
+nmbrUsage u@UsageOmega = returnNmbr u
+nmbrUsage (UsageVar u)
+ = nmbrUVar u `thenNmbr` \ new_u ->
+ returnNmbr (UsageVar new_u)
+-}
+\end{code}
-pprIfaceClass better_id_fn inline_env
- (Class k n tyvar super_classes sdsels ops sels defms insts links)
- = let
- sdsel_infos = map (getIdInfo . better_id_fn) sdsels
- in
- ppAboves [ ppCat [ppPStr SLIT("class"), ppr_theta tyvar super_classes,
- ppr sty n, lookup_fn tyvar,
- if null sdsel_infos
- || opt_OmitInterfacePragmas
- || (any boringIdInfo sdsel_infos)
- -- ToDo: really should be "all bor..."
- -- but then parsing is more tedious,
- -- and this is really as good in practice.
- then ppNil
- else pp_sdsel_pragmas (sdsels `zip` sdsel_infos),
- if (null ops)
- then ppNil
- else ppPStr SLIT("where")],
- ppNest 8 (ppAboves
- [ ppr_op op (better_id_fn sel) (better_id_fn defm)
- | (op,sel,defm) <- zip3 ops sels defms]) ]
- where
- lookup_fn = mk_lookup_tyvar_fn sty [tyvar]
-
- ppr_theta :: TyVar -> [Class] -> Pretty
- ppr_theta tv [] = ppNil
- ppr_theta tv super_classes
- = ppBesides [ppLparen,
- ppIntersperse pp'SP{-'-} (map ppr_assert super_classes),
- ppStr ") =>"]
- where
- ppr_assert (Class _ n _ _ _ _ _ _ _ _) = ppCat [ppr sty n, lookup_fn tv]
-
- pp_sdsel_pragmas sdsels_and_infos
- = ppCat [ppStr "{-# GHC_PRAGMA {-superdicts-}",
- ppIntersperse pp'SP{-'-}
- [ppIdInfo sty sdsel False{-NO specs-} better_id_fn inline_env info
- | (sdsel, info) <- sdsels_and_infos ],
- ppStr "#-}"]
-
- ppr_op op opsel_id defm_id
- = let
- stuff = ppBeside (ppChar '\t') (ppr_class_op sty [tyvar] op)
+\begin{code}
+addUVar, nmbrUVar :: UVar -> NmbrM UVar
+
+addUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = case (lookupUFM_Directly uvenv u) of
+ Just xx -> _trace "addUVar: already in map!" $
+ (nenv, xx)
+ Nothing ->
+ let
+ nenv_plus_uv = NmbrEnv ui ut (incrUnique uu)
+ idenv
+ tvenv
+ (addToUFM_Directly uvenv u new_uv)
+ new_uv = uu
in
- if opt_OmitInterfacePragmas
- then stuff
- else ppAbove stuff
- (ppCat [ppStr "\t {-# GHC_PRAGMA", ppAbove pp_opsel pp_defm, ppStr "#-}"])
- where
- pp_opsel = ppCat [ppPStr SLIT("{-meth-}"), ppIdInfo sty opsel_id False{-no specs-} better_id_fn inline_env (getIdInfo opsel_id)]
- pp_defm = ppCat [ppPStr SLIT("\t\t{-defm-}"), ppIdInfo sty defm_id False{-no specs-} better_id_fn inline_env (getIdInfo defm_id)]
-\end{pseudocode}
+ (nenv_plus_uv, new_uv)
+
+nmbrUVar u nenv@(NmbrEnv ui ut uu idenv tvenv uvenv)
+ = case (lookupUFM_Directly uvenv u) of
+ Just xx -> (nenv, xx)
+ Nothing ->
+ _trace "nmbrUVar: lookup failed" $
+ (nenv, u)
+\end{code}
diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs
index 0bcd209ae0fa8d63fe92c6b2b0cc4698eb2df44d..c975f35aeda65013729a6fb29f8137f114eabe58 100644
--- a/ghc/compiler/types/TyCon.lhs
+++ b/ghc/compiler/types/TyCon.lhs
@@ -12,7 +12,7 @@ module TyCon(
Arity(..), NewOrData(..),
isFunTyCon, isPrimTyCon, isBoxedTyCon,
- isDataTyCon, isSynTyCon,
+ isDataTyCon, isSynTyCon, isNewTyCon,
mkDataTyCon,
mkFunTyCon,
@@ -148,6 +148,9 @@ isDataTyCon (DataTyCon _ _ _ _ _ _ _ DataType) = True
isDataTyCon (TupleTyCon _ _ _) = True
isDataTyCon other = False
+isNewTyCon (DataTyCon _ _ _ _ _ _ _ NewType) = True
+isNewTyCon other = False
+
isSynTyCon (SynTyCon _ _ _ _ _ _) = True
isSynTyCon _ = False
\end{code}
diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs
index c094e1efa9a9db3dccb291f217e5a16f2057bfea..5c06b0f615a2101c32f6399ea7a3d9e99053421f 100644
--- a/ghc/compiler/types/Type.lhs
+++ b/ghc/compiler/types/Type.lhs
@@ -6,7 +6,8 @@ module Type (
mkTyVarTy, mkTyVarTys,
getTyVar, getTyVar_maybe, isTyVarTy,
mkAppTy, mkAppTys, splitAppTy,
- mkFunTy, mkFunTys, splitFunTy, getFunTy_maybe,
+ mkFunTy, mkFunTys, splitFunTy, splitFunTyWithDictsAsArgs,
+ getFunTy_maybe,
mkTyConTy, getTyCon_maybe, applyTyCon,
mkSynTy,
mkForAllTy, mkForAllTys, getForAllTy_maybe, splitForAllTy,
@@ -210,17 +211,36 @@ getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t
getFunTy_maybe other = Nothing
-splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
+splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
+splitFunTyWithDictsAsArgs :: Type -> ([Type], Type)
+ -- splitFunTy *must* have the general type given, which
+ -- means it *can't* do the DictTy jiggery-pokery that
+ -- *is* sometimes required. The relationship between these
+ -- two functions is like that between eqTy and eqSimpleTy.
+
splitFunTy t = go t []
where
go (FunTy arg res _) ts = go res (arg:ts)
go (AppTy (AppTy (TyConTy tycon _) arg) res) ts
- | isFunTyCon tycon
- = go res (arg:ts)
- go (SynTy _ _ t) ts
- = go t ts
- go t ts
- = (reverse ts, t)
+ | isFunTyCon tycon = go res (arg:ts)
+ go (SynTy _ _ t) ts = go t ts
+ go t ts = (reverse ts, t)
+
+splitFunTyWithDictsAsArgs t = go t []
+ where
+ go (FunTy arg res _) ts = go res (arg:ts)
+ go (AppTy (AppTy (TyConTy tycon _) arg) res) ts
+ | isFunTyCon tycon = go res (arg:ts)
+ go (SynTy _ _ t) ts = go t ts
+
+ -- For a dictionary type we try expanding it to see if we get a simple
+ -- function; if so we thunder on; if not we throw away the expansion.
+ go t@(DictTy _ _ _) ts | null ts' = (reverse ts, t)
+ | otherwise = (reverse ts ++ ts', t')
+ where
+ (ts', t') = go (expandTy t) []
+
+ go t ts = (reverse ts, t)
\end{code}
\begin{code}
@@ -691,8 +711,16 @@ eqTy t1 t2 =
-- Expand t2 just in case t1 matches that version
eq tve uve t1 (AppTy (AppTy (TyConTy mkFunTyCon u2) f2) a2)
- eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2) =
- c1 == c2 && eq tve uve t1 t2 && eqUsage uve u1 u2
+ eq tve uve (DictTy c1 t1 u1) (DictTy c2 t2 u2)
+ | c1 == c2
+ = eq tve uve t1 t2 && eqUsage uve u1 u2
+ -- NB we use a guard for c1==c2 so that if they aren't equal we
+ -- fall through into expanding the type. Why? Because brain-dead
+ -- people might write
+ -- class Foo a => Baz a where {}
+ -- and that means that a Foo dictionary and a Baz dictionary are identical
+ -- Sigh. Let's hope we don't spend too much time in here!
+
eq tve uve t1@(DictTy _ _ _) t2 =
eq tve uve (expandTy t1) t2 -- Expand the dictionary and try again
eq tve uve t1 t2@(DictTy _ _ _) =
diff --git a/ghc/compiler/types/Usage.lhs b/ghc/compiler/types/Usage.lhs
index ff1fbd4c2fb3f5205922eff0a45345c20a901979..7d6c448f1f3926f5c563c634462899ddbc2046a6 100644
--- a/ghc/compiler/types/Usage.lhs
+++ b/ghc/compiler/types/Usage.lhs
@@ -7,7 +7,7 @@
#include "HsVersions.h"
module Usage (
- GenUsage, Usage(..), UVar(..), UVarEnv(..),
+ GenUsage(..), Usage(..), UVar(..), UVarEnv(..),
usageOmega, pprUVar, duffUsage,
nullUVarEnv, mkUVarEnv, addOneToUVarEnv,
growUVarEnvList, isNullUVarEnv, lookupUVarEnv,
diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi
index 922c0c67bc0faaa65c1510f50f5a8134f45b31da..b2f07e4d302db73af52aa1baaf198371b0a6da7a 100644
--- a/ghc/compiler/utils/Ubiq.lhi
+++ b/ghc/compiler/utils/Ubiq.lhi
@@ -14,7 +14,7 @@ import Class ( GenClass, GenClassOp, Class(..), ClassOp )
import ClosureInfo ( ClosureInfo, LambdaFormInfo )
import CmdLineOpts ( SimplifierSwitch, SwitchResult )
import CoreSyn ( GenCoreArg, GenCoreBinder, GenCoreBinding, GenCoreExpr,
- GenCoreCaseAlts, GenCoreCaseDefault
+ GenCoreCaseAlts, GenCoreCaseDefault, Coercion
)
import CoreUnfold ( UnfoldingDetails, UnfoldingGuidance )
import CostCentre ( CostCentre )
@@ -79,6 +79,7 @@ data CLabel
data ClassOpPragmas a
data ClassPragmas a
data ClosureInfo
+data Coercion
data CostCentre
data CSeq
data DataPragmas a
diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs
index eb3cffbc9a5626caa73aeb378959c5b06629e93c..166688c07c9fb2f9b718db739cc833392fa56b8a 100644
--- a/ghc/compiler/utils/UniqFM.lhs
+++ b/ghc/compiler/utils/UniqFM.lhs
@@ -50,8 +50,6 @@ module UniqFM (
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM,
ufmToList
-
- -- to make the interface self-sufficient
) where
#if defined(COMPILING_GHC)
diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs
index 2aaec61a283785a9e929f1f32f36892af7a37005..0ce1f4992188c87fab686ce366fbd019d35bc9be 100644
--- a/ghc/compiler/utils/Util.lhs
+++ b/ghc/compiler/utils/Util.lhs
@@ -39,6 +39,7 @@ module Util (
IF_NOT_GHC(forall COMMA exists COMMA)
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy,
+ mapAndUnzip,
nOfThem, lengthExceeds, isSingleton,
startsWith, endsWith,
#if defined(COMPILING_GHC)
@@ -184,6 +185,18 @@ zipLazy [] ys = []
zipLazy (x:xs) ~(y:ys) = (x,y) : zipLazy xs ys
\end{code}
+\begin{code}
+mapAndUnzip :: (a -> (b, c)) -> [a] -> ([b], [c])
+
+mapAndUnzip f [] = ([],[])
+mapAndUnzip f (x:xs)
+ = let
+ (r1, r2) = f x
+ (rs1, rs2) = mapAndUnzip f xs
+ in
+ (r1:rs1, r2:rs2)
+\end{code}
+
\begin{code}
nOfThem :: Int -> a -> [a]
nOfThem n thing = take n (repeat thing)