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,)
showId,
pprIdInUnfolding,
+ nmbrId,
+
-- "Environments" keyed off of Ids, and sets of Ids
IdEnv(..),
lookupIdEnv, lookupNoFailIdEnv, nullIdEnv, unitIdEnv, mkIdEnv,
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
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,
(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
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}
import CoreUnfold ( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
import CoreUtils ( unTagBinders )
import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
- unfoldingUnfriendlyId, getIdInfo,
+ unfoldingUnfriendlyId, getIdInfo, nmbrId,
nullIdEnv, lookupIdEnv, IdEnv(..),
Id(..), GenId
)
import Literal ( Literal )
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import Outputable ( Outputable(..) )
+import PprEnv ( NmbrEnv )
import PprStyle ( PprStyle )
import PprType ( pprParendGenType )
import Pretty ( PrettyRep )
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
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
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 ->
getLocalName, ltLexical,
isSymLexeme, pprSym, pprNonSym,
- isLexCon, isLexVar, isLexId, isLexSym,
+ isLexCon, isLexVar, isLexId, isLexSym, isLexSpecialSym,
isLexConId, isLexConSym, isLexVarId, isLexVarSym
) 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]
(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
isLexConSym cs
| _NULL_ cs = False
- | otherwise = c == ':'
- || c == '(' -- (), (,), (,,), ...
+ | otherwise = c == ':'
+-- || c == '(' -- (), (,), (,,), ...
|| cs == SLIT("->")
- || cs == SLIT("[]")
+-- || cs == SLIT("[]")
where
c = _HEAD_ 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
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
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}
= 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)
initPprEnv
:: PprStyle
-> Maybe (Literal -> Pretty)
- -> Maybe (DataCon -> Pretty)
+ -> Maybe (Id -> Pretty)
-> Maybe (PrimOp -> Pretty)
-> Maybe (CostCentre -> Pretty)
-> Maybe (tyvar -> Pretty)
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}
thenMaybeUs, mapAccumLUs,
mkSplitUniqSupply,
- splitUniqSupply,
-
- -- and the access functions for the `builtin' UniqueSupply
- getBuiltinUniques, mkBuiltinUnique,
- mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3
+ splitUniqSupply
) where
import Ubiq{-uitous-}
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}
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,
mkTupleDataConUnique,
mkTupleTyConUnique,
+ getBuiltinUniques, mkBuiltinUnique,
+ mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3,
+
absentErrorIdKey, -- alphabetical...
addrDataConKey,
addrPrimTyConKey,
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)
%************************************************************************
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
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}
%************************************************************************
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)"
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
| 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}
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)
= 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 ->
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-}
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 ->
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}
%************************************************************************
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]) $
\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
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
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)
GenCoreBinding(..), GenCoreExpr(..),
GenCoreArg(..), GenCoreBinder(..), GenCoreCaseAlts(..),
GenCoreCaseDefault(..),
+ Coercion(..),
bindersOf, pairsFromCoreBinds, rhssOfBind,
(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}
+
%************************************************************************
%* *
[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}
%************************************************************************
| 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
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
)
`thenUf_` ment_expr expr
+ment_expr (Coerce _ _ _) = panic "ment_expr:Coerce"
+
-------------
ment_ty ty
= let
= 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}
, maybeErrorApp
, nonErrorRHSs
, squashableDictishCcExpr
-{- exprSmallEnoughToDup,
+ , exprSmallEnoughToDup
+{-
coreExprArity,
isWrapperFor,
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,
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
\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}
%************************************************************************
\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
\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
\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
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)
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}
= (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}
= (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}
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}
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 )
(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 ->
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}
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}
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-} )
-> 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
(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] )
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
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,
> where recBind2def ((v,_),e) = (v, c2d p e)
>
> SCC l e -> SCC l (c2d p e)
+> Coerce _ _ _ -> panic "Core2Def:Coerce"
> coreCaseAlts2def
> SCC l e ->
> d2c e `thenUs` \e' ->
> returnUs (SCC l e')
+> Coerce _ _ _ ->
+> panic "Def2Core:Coerce"
> defCaseAlts2Core :: DefCaseAlternatives
> -> UniqSM CoreCaseAlts
> 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
>
> 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
> 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)
> 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)
> 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
> 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
> 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
> 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 ->
> 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
-- 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
\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
[(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)
| 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
(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
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 '}']
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 '}']
isConPat (ConOpPat _ _ _ _) = True
isConPat (ListPat _ _) = True
isConPat (TuplePat _) = True
+isConPat (RecPat _ _ _) = True
isConPat (DictPat ds ms) = (length ds + length ms) > 1
isConPat other = False
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
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)
-- 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
\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
:: Maybe Handle
-> TcIfaceInfo -- as above
-> IO ()
---ifacePragmas
+ifacePragmas
+ :: Maybe Handle
+ -> IO ()
+ifacePragmas = panic "ifacePragmas" -- stub
\end{code}
\begin{code}
--------------
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
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}
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}
-------
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}
flattenOrdList, OrdList
)
import Stix ( StixTree )
-import UniqSupply ( mkBuiltinUnique )
+import Unique ( mkBuiltinUnique )
import Util ( mapAccumB, panic )
\end{code}
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}
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
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
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!
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}
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)
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)
Type
| Compare FAST_STRING -- string :: T -> T -> Bool
Type
- | Coerce FAST_STRING -- string :: T1 -> T2
+ | Coercing FAST_STRING -- string :: T1 -> T2
Type
Type
%************************************************************************
\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}
%************************************************************************
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}
%************************************************************************
%************************************************************************
\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}
%************************************************************************
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
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
Dyadic str _ -> str
Monadic str _ -> str
Compare str _ -> str
- Coerce str _ _ -> str
+ Coercing str _ _ -> str
PrimResult str _ _ _ _ _ -> str
AlgResult str _ _ _ _ -> str
\end{code}
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))
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
= 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)
import HsSyn
-import Id ( GenId, Id(..) )
+import Id ( isDataCon, GenId, Id(..) )
import Name ( isLocalName, nameUnique, Name, RdrName(..){-ToDo: rm ..-},
mkLocalName{-ToDo:rm-}
)
isRnTyConOrClass _ = False
isRnConstr (RnConstr _ _) = True
+isRnConstr (WiredInId id) = isDataCon id
isRnConstr _ = False
isRnField (RnField _ _) = True
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)
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
do_entry env e
= case (acceptable_hi (reverse e)) of
Nothing -> --trace ("Deemed uncool:"++e) $
+ hPutStr stderr "." >>
return env
Just mod ->
let
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*
-> 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}
nameImportFlag, RdrName, pprNonSym )
import Outputable -- ToDo:rm
import PprStyle -- ToDo:rm
+import PrelInfo ( consDataCon )
import Pretty
import SrcLoc ( SrcLoc )
import Unique ( Unique )
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 $
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)
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')
= 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@.
-- 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') ->
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' ->
-> 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)
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
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}
= 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')
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.
| 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
calcUnfoldingGuidance, UnfoldingGuidance(..),
mkFormSummary, FormSummary
)
-import CoreUtils ( manifestlyWHNF )
+import CoreUtils ( manifestlyWHNF, exprSmallEnoughToDup )
import FiniteMap -- lots of things
import Id ( idType, getIdUnfolding, getIdStrictness,
applyTypeEnvToId,
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-}
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)"
-- 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]
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
= 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_
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}
%************************************************************************
\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)
ok_to_dup = switchIsOn chkr SimplOkToDupCode
+#ifdef DEBUG
+extendIdEnvWithAtom _ _ _ = panic "extendIdEnvWithAtom: non-Val arg!"
+#endif
+
extendIdEnvWithAtomList
:: SimplEnv
-> [(InBinder, OutArg)]
\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)
\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
\end{code}
+Coercions
+~~~~~~~~~
+\begin{code}
+simplExpr env (Coerce coercion ty body) args
+ = simplCoerce env coercion ty body args
+\end{code}
+
+
Set-cost-centre
~~~~~~~~~~~~~~~
\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}
-> 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
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'
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}
%************************************************************************
\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}
)
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 )
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
> --import SrcLoc ( mkUnknownSrcLoc )
> --import StgSyn
> --import UniqSet
-> --import UniqSupply ( getBuiltinUniques )
+> --import Unique ( getBuiltinUniques )
> --import Util
%-----------------------------------------------------------------------------
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
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
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}
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}
+
%************************************************************************
%* *
data GenStgBinding bndr occ
= StgNonRec bndr (GenStgRhs bndr occ)
| StgRec [(bndr, GenStgRhs bndr occ)]
+ | StgCoerceBinding bndr occ
\end{code}
%************************************************************************
= 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))
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}
= 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 ->
= 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 ->
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 )
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 )
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
\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
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
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}
`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
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 ) )
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)
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
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 )
\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)
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)
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 )
-- 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
)
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
\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,
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
(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)
= 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 ()
\section[Kind]{The @Kind@ datatype}
\begin{code}
+#include "HsVersions.h"
+
module Kind (
Kind(..), -- Only visible to friends: TcKind
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}
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
typeMaybeString,
specMaybeTysSuffix,
GenClass,
- GenClassOp, pprGenClassOp
+ GenClassOp, pprGenClassOp,
+
+ addTyVar, nmbrTyVar,
+ addUVar, nmbrUsage,
+ nmbrType, nmbrTyCon, nmbrClass
) where
import Ubiq
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}
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
\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
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...
(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.
\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
_ -> 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}
%* *
%************************************************************************
_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}
Arity(..), NewOrData(..),
isFunTyCon, isPrimTyCon, isBoxedTyCon,
- isDataTyCon, isSynTyCon,
+ isDataTyCon, isSynTyCon, isNewTyCon,
mkDataTyCon,
mkFunTyCon,
isDataTyCon (TupleTyCon _ _ _) = True
isDataTyCon other = False
+isNewTyCon (DataTyCon _ _ _ _ _ _ _ NewType) = True
+isNewTyCon other = False
+
isSynTyCon (SynTyCon _ _ _ _ _ _) = True
isSynTyCon _ = False
\end{code}
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,
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}
-- 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 _ _ _) =
#include "HsVersions.h"
module Usage (
- GenUsage, Usage(..), UVar(..), UVarEnv(..),
+ GenUsage(..), Usage(..), UVar(..), UVarEnv(..),
usageOmega, pprUVar, duffUsage,
nullUVarEnv, mkUVarEnv, addOneToUVarEnv,
growUVarEnvList, isNullUVarEnv, lookupUVarEnv,
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 )
data ClassOpPragmas a
data ClassPragmas a
data ClosureInfo
+data Coercion
data CostCentre
data CSeq
data DataPragmas a
lookupWithDefaultUFM, lookupWithDefaultUFM_Directly,
eltsUFM,
ufmToList
-
- -- to make the interface self-sufficient
) where
#if defined(COMPILING_GHC)
IF_NOT_GHC(forall COMMA exists COMMA)
zipEqual, zipWithEqual, zipWith3Equal, zipWith4Equal,
zipLazy,
+ mapAndUnzip,
nOfThem, lengthExceeds, isSingleton,
startsWith, endsWith,
#if defined(COMPILING_GHC)
\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)
projects / ghc-hetmet.git / commitdiff