projects
/
ghc-hetmet.git
/ commitdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
| commitdiff |
tree
raw
|
patch
|
inline
| side by side (parent:
67e502c
)
[project @ 1997-05-18 19:56:49 by sof]
author
sof
<unknown>
Sun, 18 May 1997 19:57:29 +0000
(19:57 +0000)
committer
sof
<unknown>
Sun, 18 May 1997 19:57:29 +0000
(19:57 +0000)
Made 2.0x bootable
ghc/compiler/types/TyVar.lhs
patch
|
blob
|
history
ghc/compiler/types/Type.lhs
patch
|
blob
|
history
diff --git
a/ghc/compiler/types/TyVar.lhs
b/ghc/compiler/types/TyVar.lhs
index
fd59f96
..
dee87a6
100644
(file)
--- a/
ghc/compiler/types/TyVar.lhs
+++ b/
ghc/compiler/types/TyVar.lhs
@@
-35,12
+35,13
@@
import UniqSet -- nearly all of it
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
plusUFM, sizeUFM, delFromUFM, UniqFM
)
import UniqFM ( emptyUFM, listToUFM, addToUFM, lookupUFM,
plusUFM, sizeUFM, delFromUFM, UniqFM
)
-import Name ( mkSysLocalName, changeUnique, Name )
-import Pretty ( SYN_IE(Pretty), PrettyRep, ppBeside, ppPStr )
+import Name --( mkSysLocalName, changeUnique, Name )
+import Pretty ( Doc, (<>), ptext )
import PprStyle ( PprStyle )
--import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) )
import SrcLoc ( noSrcLoc, SrcLoc )
import Unique ( showUnique, mkAlphaTyVarUnique, Unique )
import PprStyle ( PprStyle )
--import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) )
import SrcLoc ( noSrcLoc, SrcLoc )
import Unique ( showUnique, mkAlphaTyVarUnique, Unique )
+import UniqFM ( Uniquable(..) )
import Util ( panic, Ord3(..) )
\end{code}
import Util ( panic, Ord3(..) )
\end{code}
diff --git
a/ghc/compiler/types/Type.lhs
b/ghc/compiler/types/Type.lhs
index
229b5ae
..
0ae9b6d
100644
(file)
--- a/
ghc/compiler/types/Type.lhs
+++ b/
ghc/compiler/types/Type.lhs
@@
-42,12
+42,12
@@
module Type (
) where
IMP_Ubiq()
) where
IMP_Ubiq()
---IMPORT_DELOOPER(IdLoop) -- for paranoia checking
+IMPORT_DELOOPER(IdLoop) -- for paranoia checking
IMPORT_DELOOPER(TyLoop)
--IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
-- friends:
IMPORT_DELOOPER(TyLoop)
--IMPORT_DELOOPER(PrelLoop) -- for paranoia checking
-- friends:
-import Class ( classSig, classOpLocalType, GenClass{-instances-} )
+import Class --( classSig, classOpLocalType, GenClass{-instances-} )
import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
import Kind ( mkBoxedTypeKind, resultKind, notArrowKind, Kind )
import TyCon ( mkFunTyCon, isFunTyCon, isEnumerationTyCon, isTupleTyCon, maybeTyConSingleCon,
isPrimTyCon, isDataTyCon, isSynTyCon, maybeNewTyCon, isNewTyCon,
@@
-68,6
+68,7
@@
import Name ( NamedThing(..),
import Maybes ( maybeToBool, assocMaybe )
import PrimRep ( PrimRep(..) )
import Unique -- quite a few *Keys
import Maybes ( maybeToBool, assocMaybe )
import PrimRep ( PrimRep(..) )
import Unique -- quite a few *Keys
+import UniqFM ( Uniquable(..) )
import Util ( thenCmp, zipEqual, assoc,
panic, panic#, assertPanic, pprPanic,
Ord3(..){-instances-}
import Util ( thenCmp, zipEqual, assoc,
panic, panic#, assertPanic, pprPanic,
Ord3(..){-instances-}
@@
-79,10
+80,6
@@
import Util ( thenCmp, zipEqual, assoc,
-- PprStyle
--import {-mumble-}
-- PprType --(pprType )
-- PprStyle
--import {-mumble-}
-- PprType --(pprType )
---import {-mumble-}
--- UniqFM (ufmToList )
---import {-mumble-}
--- Outputable
--import PprEnv
\end{code}
--import PprEnv
\end{code}
@@
-142,6
+139,21
@@
type SigmaType = Type
\end{code}
\end{code}
+Notes on type synonyms
+~~~~~~~~~~~~~~~~~~~~~~
+The various "split" functions (splitFunTy, splitRhoTy, splitForAllTy) try
+to return type synonyms whereever possible. Thus
+
+ type Foo a = a -> a
+
+we want
+ splitFunTys (a -> Foo a) = ([a], Foo a)
+not ([a], a -> a)
+
+The reason is that we then get better (shorter) type signatures in
+interfaces. Notably this plays a role in tcTySigs in TcBinds.lhs.
+
+
Expand abbreviations
~~~~~~~~~~~~~~~~~~~~
Removes just the top level of any abbreviations.
Expand abbreviations
~~~~~~~~~~~~~~~~~~~~
Removes just the top level of any abbreviations.
@@
-240,11
+252,15
@@
mkFunTys ts t = foldr (\ f a -> FunTy f a usageOmega) t ts
-- ToDo: NUKE when we do dicts via newtype
getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
-- ToDo: NUKE when we do dicts via newtype
getFunTy_maybe :: GenType t u -> Maybe (GenType t u, GenType t u)
-getFunTy_maybe (FunTy arg result _) = Just (arg,result)
-getFunTy_maybe (AppTy (AppTy (TyConTy tycon _) arg) res)
+getFunTy_maybe t
+ = go t t
+ where
+ -- See notes on type synonyms above
+ go syn_t (FunTy arg result _) = Just (arg,result)
+ go syn_t (AppTy (AppTy (TyConTy tycon _) arg) res)
| isFunTyCon tycon = Just (arg, res)
| isFunTyCon tycon = Just (arg, res)
-getFunTy_maybe (SynTy _ _ t) = getFunTy_maybe t
-getFunTy_maybe other = Nothing
+ go syn_t (SynTy _ _ t) = go syn_t t
+ go syn_t other = Nothing
getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons
-> Type
getFunTyExpandingDicts_maybe :: Bool -- True <=> peek inside newtype applicatons
-> Type
@@
-259,19
+275,28
@@
getFunTyExpandingDicts_maybe peek ty@(DictTy _ _ _) = getFunTyExpandingDicts_may
getFunTyExpandingDicts_maybe True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty
-- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking
getFunTyExpandingDicts_maybe True (ForAllTy _ ty) = getFunTyExpandingDicts_maybe True ty
-- Ignore for-alls when peeking. See note with defn of getFunTyExpandingDictsAndPeeking
+
+{- This is a truly disgusting bit of code.
+ It's used by the code generator to look at the rep of a newtype.
+ The code gen will have thrown away coercions involving that newtype, so
+ this is the other side of the coin.
+ Gruesome in the extreme.
+-}
+
getFunTyExpandingDicts_maybe peek other
| not peek = Nothing -- that was easy
| otherwise
= case (maybeAppTyCon other) of
getFunTyExpandingDicts_maybe peek other
| not peek = Nothing -- that was easy
| otherwise
= case (maybeAppTyCon other) of
- Nothing -> Nothing
Just (tc, arg_tys)
Just (tc, arg_tys)
- | not (isNewTyCon tc) -> Nothing
- | otherwise ->
- let
- [newtype_con] = tyConDataCons tc -- there must be exactly one...
- [inside_ty] = dataConArgTys newtype_con arg_tys
- in
- getFunTyExpandingDicts_maybe peek inside_ty
+ | isNewTyCon tc && not (null data_cons)
+ -> getFunTyExpandingDicts_maybe peek inside_ty
+ where
+ data_cons = tyConDataCons tc
+ [the_con] = data_cons
+ [inside_ty] = dataConArgTys the_con arg_tys
+
+ other -> Nothing
+
splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
splitFunTyExpandingDicts :: Type -> ([Type], Type)
splitFunTy :: GenType t u -> ([GenType t u], GenType t u)
splitFunTyExpandingDicts :: Type -> ([Type], Type)
@@
-282,7
+307,8
@@
splitFunTyExpandingDicts t = split_fun_ty (getFunTyExpandingDicts_mayb
splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t
-- This "peeking" stuff is used only by the code generator.
-- It's interested in the representation type of things, ignoring:
splitFunTyExpandingDictsAndPeeking t = split_fun_ty (getFunTyExpandingDicts_maybe True) t
-- This "peeking" stuff is used only by the code generator.
-- It's interested in the representation type of things, ignoring:
- -- newtype
+ -- newtype Why??? Nuked SLPJ May 97. We may not know the
+ -- rep of an abstractly imported newtype
-- foralls
-- expanding dictionary reps
-- synonyms, of course
-- foralls
-- expanding dictionary reps
-- synonyms, of course
@@
-353,14
+379,15
@@
mkRhoTy theta ty =
splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
splitRhoTy t =
splitRhoTy :: GenType t u -> ([(Class,GenType t u)], GenType t u)
splitRhoTy t =
- go t []
+ go t t []
where
where
- go (FunTy (DictTy c t _) r _) ts = go r ((c,t):ts)
- go (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
+ -- See notes on type synonyms above
+ go syn_t (FunTy (DictTy c t _) r _) ts = go r r ((c,t):ts)
+ go syn_t (AppTy (AppTy (TyConTy tycon _) (DictTy c t _)) r) ts
| isFunTyCon tycon
| isFunTyCon tycon
- = go r ((c,t):ts)
- go (SynTy _ _ t) ts = go t ts
- go t ts = (reverse ts, t)
+ = go r r ((c,t):ts)
+ go syn_t (SynTy _ _ t) ts = go syn_t t ts
+ go syn_t t ts = (reverse ts, syn_t)
mkTheta :: [Type] -> ThetaType
mkTheta :: [Type] -> ThetaType
@@
-397,11
+424,12
@@
getForAllTyExpandingDicts_maybe ty@(DictTy _ _ _) = getForAllTyExpandingDicts_m
getForAllTyExpandingDicts_maybe _ = Nothing
splitForAllTy :: GenType t u-> ([t], GenType t u)
getForAllTyExpandingDicts_maybe _ = Nothing
splitForAllTy :: GenType t u-> ([t], GenType t u)
-splitForAllTy t = go t []
+splitForAllTy t = go t t []
where
where
- go (ForAllTy tv t) tvs = go t (tv:tvs)
- go (SynTy _ _ t) tvs = go t tvs
- go t tvs = (reverse tvs, t)
+ -- See notes on type synonyms above
+ go syn_t (ForAllTy tv t) tvs = go t t (tv:tvs)
+ go syn_t (SynTy _ _ t) tvs = go syn_t t tvs
+ go syn_t t tvs = (reverse tvs, syn_t)
\end{code}
\begin{code}
\end{code}
\begin{code}
@@
-465,7
+493,7
@@
maybe_app_data_tycon expand ty
(app_ty, arg_tys) = splitAppTys expanded_ty
in
case (getTyCon_maybe app_ty) of
(app_ty, arg_tys) = splitAppTys expanded_ty
in
case (getTyCon_maybe app_ty) of
- Just tycon | --pprTrace "maybe_app:" (ppCat [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
+ Just tycon | --pprTrace "maybe_app:" (hsep [ppr PprDebug (isDataTyCon tycon), ppr PprDebug (notArrowKind (typeKind expanded_ty))]) $
isDataTyCon tycon &&
notArrowKind (typeKind expanded_ty)
-- Must be saturated for ty to be a data type
isDataTyCon tycon &&
notArrowKind (typeKind expanded_ty)
-- Must be saturated for ty to be a data type
@@
-621,6
+649,8
@@
instant_help ty lookup_tv deflt_tv choose_tycon
else
\x->x) ForAllTy (deflt_forall_tv tv) (go ty)
else
\x->x) ForAllTy (deflt_forall_tv tv) (go ty)
+instantiateTy [] ty = ty
+
instantiateTy tenv ty
= instant_help ty lookup_tv deflt_tv choose_tycon
if_usage if_forall bound_forall_tv_BAD deflt_forall_tv
instantiateTy tenv ty
= instant_help ty lookup_tv deflt_tv choose_tycon
if_usage if_forall bound_forall_tv_BAD deflt_forall_tv