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