From fda89b29c748c6cd2fe1fdb477d5c0e8f7d32b90 Mon Sep 17 00:00:00 2001 From: sof Date: Sat, 5 Jul 1997 03:03:34 +0000 Subject: [PATCH] [project @ 1997-07-05 03:02:04 by sof] Changes through ID4 --- ghc/compiler/absCSyn/CLabel.lhs | 3 +- ghc/compiler/absCSyn/HeapOffs.lhs | 2 +- ghc/compiler/basicTypes/BasicTypes.lhs | 34 ++- ghc/compiler/basicTypes/FieldLabel.lhs | 2 +- ghc/compiler/basicTypes/Id.hi-boot | 18 +- ghc/compiler/basicTypes/Id.lhs | 408 ++++++++------------------------ ghc/compiler/basicTypes/IdInfo.lhs | 114 ++------- ghc/compiler/basicTypes/IdLoop.lhi | 7 +- ghc/compiler/basicTypes/Name.lhs | 231 ++++++++++-------- ghc/compiler/basicTypes/PprEnv.lhs | 83 +------ ghc/compiler/basicTypes/Unique.lhs | 43 ++-- ghc/compiler/codeGen/CgClosure.lhs | 8 +- ghc/compiler/codeGen/ClosureInfo.lhs | 24 +- ghc/compiler/coreSyn/CoreLift.lhs | 12 +- ghc/compiler/coreSyn/CoreUnfold.lhs | 15 +- ghc/compiler/coreSyn/CoreUtils.lhs | 3 +- ghc/compiler/coreSyn/PprCore.lhs | 2 +- ghc/compiler/deSugar/Desugar.lhs | 60 +---- ghc/compiler/deSugar/DsBinds.lhs | 52 ++-- ghc/compiler/hsSyn/HsBinds.lhs | 2 +- ghc/compiler/hsSyn/HsDecls.lhs | 10 +- ghc/compiler/hsSyn/HsImpExp.lhs | 7 +- ghc/compiler/hsSyn/HsSyn.lhs | 4 +- ghc/compiler/main/Main.lhs | 11 +- ghc/compiler/main/MkIface.lhs | 91 ++++--- ghc/compiler/nativeGen/MachRegs.lhs | 2 - ghc/compiler/parser/UgenUtil.lhs | 1 + 27 files changed, 466 insertions(+), 783 deletions(-) diff --git a/ghc/compiler/absCSyn/CLabel.lhs b/ghc/compiler/absCSyn/CLabel.lhs index 8b067aa..7a7c548 100644 --- a/ghc/compiler/absCSyn/CLabel.lhs +++ b/ghc/compiler/absCSyn/CLabel.lhs @@ -68,7 +68,6 @@ import {-# SOURCE #-} MachMisc ( underscorePrefix, fmtAsmLbl ) import CStrings ( pp_cSEP ) import Id ( externallyVisibleId, cmpId_withSpecDataCon, isDataCon, isDictFunId, - isConstMethodId_maybe, isDefaultMethodId_maybe, isSuperDictSelId_maybe, fIRST_TAG, SYN_IE(ConTag), GenId{-instance Outputable-}, @@ -329,7 +328,7 @@ pprCLabel_asm = pprCLabel (PprForAsm underscorePrefix fmtAsmLbl) pprCLabel :: PprStyle -> CLabel -> Doc pprCLabel (PprForAsm _ fmtAsmLbl) (AsmTempLabel u) - = text (fmtAsmLbl (_UNPK_ (showUnique u))) + = text (fmtAsmLbl (showUnique u)) pprCLabel (PprForAsm prepend_cSEP _) lbl = if prepend_cSEP diff --git a/ghc/compiler/absCSyn/HeapOffs.lhs b/ghc/compiler/absCSyn/HeapOffs.lhs index 7d55046..10a5f65 100644 --- a/ghc/compiler/absCSyn/HeapOffs.lhs +++ b/ghc/compiler/absCSyn/HeapOffs.lhs @@ -319,7 +319,7 @@ pprHeapOffsetPieces sty int_offs fxdhdr_offs varhdr_offs tothdr_offs case (catMaybes [pp_tothdr_offs, pp_varhdr_offs, pp_fxdhdr_offs, pp_int_offs]) of [] -> char '0' [pp] -> pp -- Each blob is parenthesised if necessary - pps -> parens (cat (punctuate (char '+') pps)) + pps -> parens (hcat (punctuate (char '+') pps)) where pp_hdrs hdr_pp [] = Nothing pp_hdrs hdr_pp [SMRI(rep, n)] | n _EQ_ ILIT(1) = Just ((<>) (text (show rep)) hdr_pp) diff --git a/ghc/compiler/basicTypes/BasicTypes.lhs b/ghc/compiler/basicTypes/BasicTypes.lhs index d19f0bd..82a446b 100644 --- a/ghc/compiler/basicTypes/BasicTypes.lhs +++ b/ghc/compiler/basicTypes/BasicTypes.lhs @@ -19,7 +19,7 @@ module BasicTypes( SYN_IE(Version), SYN_IE(Arity), SYN_IE(Module), moduleString, pprModule, Fixity(..), FixityDirection(..), - NewOrData(..) + NewOrData(..), IfaceFlavour(..) ) where IMP_Ubiq() @@ -67,6 +67,38 @@ pprModule :: PprStyle -> Module -> Doc pprModule sty m = ptext m \end{code} +%************************************************************************ +%* * +\subsection[IfaceFlavour]{IfaceFlavour} +%* * +%************************************************************************ + +The IfaceFlavour type is used mainly in an imported Name's Provenance +to say whether the name comes from a regular .hi file, or whether it comes +from a hand-written .hi-boot file. This is important, because it has to be +propagated. Suppose + + C.hs imports B + B.hs imports A + A.hs imports C {-# SOURCE -#} ( f ) + +Then in A.hi we may mention C.f, in an inlining. When compiling B we *must not* +read C.f's details from C.hi, even if the latter happens to exist from an earlier +compilation run. So we use the name "C!f" in A.hi, and when looking for an interface +file with details of C!f we look in C.hi-boot. The "!" stuff is recorded in the +IfaceFlavour in the Name of C.f in A. + +Not particularly beautiful, but it works. + +\begin{code} +data IfaceFlavour = HiFile -- The interface was read from a standard interface file + | HiBootFile -- ... or from a handwritten "hi-boot" interface file + +instance Text IfaceFlavour where -- Just used in debug prints of lex tokens + showsPrec n HiFile s = s + showsPrec n HiBootFile s = "!" ++ s +\end{code} + %************************************************************************ %* * diff --git a/ghc/compiler/basicTypes/FieldLabel.lhs b/ghc/compiler/basicTypes/FieldLabel.lhs index 7e03b31..ccaf094 100644 --- a/ghc/compiler/basicTypes/FieldLabel.lhs +++ b/ghc/compiler/basicTypes/FieldLabel.lhs @@ -10,7 +10,7 @@ module FieldLabel where IMP_Ubiq(){-uitous-} -import Name --( Name{-instance Eq/Outputable-}, nameUnique ) +import Name ( Name{-instance Eq/Outputable-}, NamedThing(..), nameUnique ) import Type ( SYN_IE(Type) ) import Outputable diff --git a/ghc/compiler/basicTypes/Id.hi-boot b/ghc/compiler/basicTypes/Id.hi-boot index 2d7ce7e..c9591e8 100644 --- a/ghc/compiler/basicTypes/Id.hi-boot +++ b/ghc/compiler/basicTypes/Id.hi-boot @@ -1,14 +1,14 @@ _interface_ Id 1 _exports_ -Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) dataConArgTys idType isNullaryDataCon mkDataCon mkTupleCon nmbrId pprId; +Id Id GenId StrictnessMark(MarkedStrict NotMarkedStrict) dataConArgTys idType isNullaryDataCon mkDataCon mkTupleCon pprId idName; _declarations_ -1 type Id = Id.GenId Type.Type ; +1 type Id = Id.GenId Type!Type ; 1 data GenId ty ; 1 data StrictnessMark = MarkedStrict | NotMarkedStrict ; -1 dataConArgTys _:_ Id.Id -> [Type.Type] -> [Type.Type] ;; -1 idType _:_ Id.Id -> Type.Type ;; -1 isNullaryDataCon _:_ Id.Id -> PrelBase.Bool ;; -1 mkDataCon _:_ Name.Name -> [Id.StrictnessMark] -> [FieldLabel.FieldLabel] -> [TyVar.TyVar] -> [(Class.Class,Type.Type)] -> [TyVar.TyVar] -> [(Class.Class,Type.Type)] -> [Type.Type] -> TyCon.TyCon -> Id.Id ;; -1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type.Type -> Id.Id ;; -1 nmbrId _:_ Id.Id -> PprEnv.NmbrEnv -> (PprEnv.NmbrEnv, Id.Id) ;; -1 pprId _:_ _forall_ [ty] {Outputable.Outputable ty} => Outputable.PprStyle -> Id.GenId ty -> Pretty.Doc ;; +1 dataConArgTys _:_ Id -> [Type!Type] -> [Type!Type] ;; +1 idType _:_ Id.Id -> Type!Type ;; +1 isNullaryDataCon _:_ Id -> PrelBase.Bool ;; +1 mkDataCon _:_ Name.Name -> [Id.StrictnessMark] -> [FieldLabel.FieldLabel] -> [TyVar.TyVar] -> Type.ThetaType -> [TyVar.TyVar] -> Type!ThetaType -> [Type!TauType] -> TyCon!TyCon -> Id ;; +1 mkTupleCon _:_ PrelBase.Int -> Name.Name -> Type!Type -> Id ;; +1 pprId _:_ _forall_ [ty] {Outputable.Outputable ty} => Outputable.PprStyle -> GenId ty -> Pretty.Doc ;; +1 idName _:_ _forall_ [ty] => GenId ty -> Name.Name ;; diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index a39e830..6b22f12 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -15,29 +15,30 @@ module Id ( SYN_IE(DataCon), SYN_IE(DictFun), SYN_IE(DictVar), -- CONSTRUCTION - mkConstMethodId, mkDataCon, mkDefaultMethodId, mkDictFunId, - mkIdWithNewUniq, mkIdWithNewName, + mkIdWithNewUniq, mkIdWithNewName, mkIdWithNewType, mkImported, mkInstId, mkMethodSelId, mkRecordSelId, + mkSameSpecCon, mkSuperDictSelId, mkSysLocal, mkTemplateLocals, mkTupleCon, mkUserId, mkUserLocal, - mkWorkerId, mkPrimitiveId, + mkWorkerId, setIdVisibility, -- DESTRUCTION (excluding pragmatic info) idPrimRep, idType, idUnique, + idName, dataConRepType, dataConArgTys, @@ -61,8 +62,6 @@ module Id ( idWantsToBeINLINEd, getInlinePragma, idMustBeINLINEd, idMustNotBeINLINEd, isBottomingId, - isConstMethodId, - isConstMethodId_maybe, isDataCon, isAlgCon, isNewCon, isDefaultMethodId, isDefaultMethodId_maybe, @@ -76,7 +75,6 @@ module Id ( isPrimitiveId_maybe, isSysLocalId, isTupleCon, - isWorkerId, isWrapperId, toplevelishId, unfoldingUnfriendlyId, @@ -86,9 +84,6 @@ module Id ( apply_to_Id, -- PRINTING and RENUMBERING - addId, - nmbrDataCon, - nmbrId, pprId, showId, @@ -154,16 +149,12 @@ import {-# SOURCE #-} SpecEnv ( SpecEnv ) import {-# SOURCE #-} CoreUnfold ( Unfolding ) import {-# SOURCE #-} StdIdInfo ( addStandardIdInfo ) -- Let's see how much we can leave out.. ---import {-# SOURCE #-} TyCon ---import {-# SOURCE #-} Type ---import {-# SOURCE #-} Class ---import {-# SOURCE #-} TysWiredIn --import {-# SOURCE #-} TysPrim ---import {-# SOURCE #-} TyVar #endif import Bag -import Class ( classOpString, SYN_IE(Class), GenClass, SYN_IE(ClassOp), GenClassOp ) +import Class ( SYN_IE(Class), GenClass ) +import BasicTypes ( SYN_IE(Arity) ) import IdInfo import Maybes ( maybeToBool ) import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, @@ -171,7 +162,7 @@ import Name ( nameUnique, mkLocalName, mkSysLocalName, isLocalName, isLocallyDefinedName, occNameString, modAndOcc, isLocallyDefined, changeUnique, isWiredInName, nameString, getOccString, setNameVisibility, - isExported, ExportFlag(..), DefnInfo, Provenance, + isExported, ExportFlag(..), Provenance, OccName(..), Name, SYN_IE(Module), NamedThing(..) ) @@ -182,34 +173,34 @@ import PragmaInfo ( PragmaInfo(..) ) #if __GLASGOW_HASKELL__ >= 202 import PrimOp ( PrimOp ) #endif -import PprEnv -- ( SYN_IE(NmbrM), NmbrEnv(..) ) import PprType ( getTypeString, specMaybeTysSuffix, - nmbrType, nmbrTyVar, GenType, GenTyVar ) import Pretty import MatchEnv ( MatchEnv ) -import SrcLoc --( mkBuiltinSrcLoc ) +import SrcLoc ( mkBuiltinSrcLoc ) import TysWiredIn ( tupleTyCon ) -import TyCon --( TyCon, tyConDataCons ) -import Type {- ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, +import TyCon ( TyCon, tyConDataCons, isDataTyCon, isNewTyCon, mkSpecTyCon ) +import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy, splitSigmaTy, applyTyCon, instantiateTy, mkForAllTys, tyVarsOfType, applyTypeEnvToTy, typePrimRep, + specialiseTy, instantiateTauTy, GenType, SYN_IE(ThetaType), SYN_IE(TauType), SYN_IE(Type) - ) -} -import TyVar --( alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) ) + ) +import TyVar ( SYN_IE(TyVar), GenTyVar, alphaTyVars, isEmptyTyVarSet, SYN_IE(TyVarEnv) ) import Usage ( SYN_IE(UVar) ) import UniqFM import UniqSet -- practically all of it -import Unique ( getBuiltinUniques, pprUnique, showUnique, +import Unique ( getBuiltinUniques, pprUnique, incrUnique, Unique{-instance Ord3-}, Uniquable(..) ) import Outputable ( ifPprDebug, Outputable(..), PprStyle(..) ) -import Util {- ( mapAccumL, nOfThem, zipEqual, assoc, +import SrcLoc ( SrcLoc ) +import Util ( Ord3(..), mapAccumL, nOfThem, zipEqual, assoc, panic, panic#, pprPanic, assertPanic - ) -} + ) \end{code} Here are the @Id@ and @IdDetails@ datatypes; also see the notes that @@ -286,8 +277,7 @@ data IdDetails | MethodSelId Class -- An overloaded class operation, with -- a fully polymorphic type. Its code -- just selects a method from the - -- dictionary. The class. - ClassOp -- The operation + -- dictionary. -- NB: The IdInfo for a MethodSelId has all the info about its -- related "constant method Ids", which are just @@ -295,10 +285,6 @@ data IdDetails | DefaultMethodId -- Default method for a particular class op Class -- same class, info as MethodSelId - ClassOp -- (surprise, surprise) - Bool -- True <=> I *know* this default method Id - -- is a generated one that just says - -- `error "No default method for "'. -- see below | DictFunId Class -- A DictFun is uniquely identified @@ -309,14 +295,6 @@ data IdDetails -- actually do comparisons that way, we kindly supply -- a Unique for that purpose. - -- see below - | ConstMethodId -- A method which depends only on the type of the - -- instance, and not on any further dictionaries etc. - Class -- Uniquely identified by: - Type -- (class, type, classop) triple - ClassOp - Module -- module where instance came from - | InstId -- An instance of a dictionary, class operation, -- or overloaded value (Local name) Bool -- as for LocalId @@ -330,11 +308,6 @@ data IdDetails -- we may specialise to a type w/ free tyvars -- (i.e., in one of the "Maybe Type" dudes). --- Scheduled for deletion: SLPJ Nov 96 --- Nobody seems to depend on knowing this. - | WorkerId -- A "worker" for some other Id - Id -- Id for which this is a worker - type ConTag = Int type DictVar = Id type DictFun = Id @@ -456,9 +429,6 @@ include dictionaries for the immediate superclasses of C at the type \item[@SpecId@:] %---------------------------------------------------------------------- -\item[@WorkerId@:] - -%---------------------------------------------------------------------- \item[@LocalId@:] A purely-local value, e.g., a function argument, something defined in a @where@ clauses, ... --- but which appears in the original program text. @@ -540,13 +510,11 @@ toplevelishId (Id _ _ _ details _ _) chk (RecordSelId _) = True chk ImportedId = True chk (SuperDictSelId _ _) = True - chk (MethodSelId _ _) = True - chk (DefaultMethodId _ _ _) = True + chk (MethodSelId _) = True + chk (DefaultMethodId _) = True chk (DictFunId _ _) = True - chk (ConstMethodId _ _ _ _) = True chk (SpecId unspec _ _) = toplevelishId unspec -- depends what the unspecialised thing is - chk (WorkerId unwrkr) = toplevelishId unwrkr chk (InstId _) = False -- these are local chk (LocalId _) = False chk (SysLocalId _) = False @@ -561,11 +529,9 @@ idHasNoFreeTyVars (Id _ _ _ details _ info) chk (RecordSelId _) = True chk ImportedId = True chk (SuperDictSelId _ _) = True - chk (MethodSelId _ _) = True - chk (DefaultMethodId _ _ _) = True + chk (MethodSelId _) = True + chk (DefaultMethodId _) = True chk (DictFunId _ _) = True - chk (ConstMethodId _ _ _ _) = True - chk (WorkerId unwrkr) = idHasNoFreeTyVars unwrkr chk (SpecId _ _ no_free_tvs) = no_free_tvs chk (InstId no_free_tvs) = no_free_tvs chk (LocalId no_free_tvs) = no_free_tvs @@ -598,7 +564,7 @@ omitIfaceSigForId (Id _ name _ details _ _) (TupleConId _) -> True (RecordSelId _) -> True (SuperDictSelId _ _) -> True - (MethodSelId _ _) -> True + (MethodSelId _) -> True other -> False -- Don't omit! -- NB DefaultMethodIds are not omitted @@ -616,48 +582,34 @@ isSysLocalId other = False isSpecPragmaId (Id _ _ _ (SpecPragmaId _ _) _ _) = True isSpecPragmaId other = False -isMethodSelId_maybe (Id _ _ _ (MethodSelId cls op) _ _) = Just (cls,op) -isMethodSelId_maybe _ = Nothing +isSpecId_maybe (Id _ _ _ (SpecId unspec ty_maybes _) _ _) + = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) + Just (unspec, ty_maybes) +isSpecId_maybe other_id + = Nothing + +isMethodSelId_maybe (Id _ _ _ (MethodSelId cls) _ _) = Just cls +isMethodSelId_maybe _ = Nothing -isDefaultMethodId (Id _ _ _ (DefaultMethodId _ _ _) _ _) = True -isDefaultMethodId other = False +isDefaultMethodId (Id _ _ _ (DefaultMethodId _) _ _) = True +isDefaultMethodId other = False -isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls clsop err) _ _) - = Just (cls, clsop, err) +isDefaultMethodId_maybe (Id _ _ _ (DefaultMethodId cls) _ _) + = Just cls isDefaultMethodId_maybe other = Nothing isDictFunId (Id _ _ _ (DictFunId _ _) _ _) = True isDictFunId other = False -isConstMethodId (Id _ _ _ (ConstMethodId _ _ _ _) _ _) = True -isConstMethodId other = False - -isConstMethodId_maybe (Id _ _ _ (ConstMethodId cls ty clsop _) _ _) - = Just (cls, ty, clsop) -isConstMethodId_maybe other = Nothing - isSuperDictSelId_maybe (Id _ _ _ (SuperDictSelId c sc) _ _) = Just (c, sc) isSuperDictSelId_maybe other_id = Nothing -isWorkerId (Id _ _ _ (WorkerId _) _ _) = True -isWorkerId other = False - isWrapperId id = workerExists (getIdStrictness id) isPrimitiveId_maybe (Id _ _ _ (PrimitiveId primop) _ _) = Just primop isPrimitiveId_maybe other = Nothing \end{code} -Tell them who my wrapper function is. -\begin{code} -{-LATER: -myWrapperMaybe :: Id -> Maybe Id - -myWrapperMaybe (Id _ _ _ (WorkerId my_wrapper) _ _) = Just my_wrapper -myWrapperMaybe other_id = Nothing --} -\end{code} - \begin{code} unfoldingUnfriendlyId -- return True iff it is definitely a bad :: Id -- idea to export an unfolding that @@ -684,18 +636,11 @@ CLAIM (not ASSERTed) for @applyTypeEnvToId@ and @applySubstToId@: `Top-levelish Ids'' cannot have any free type variables, so applying the type-env cannot have any effect. (NB: checked in CoreLint?) -The special casing is in @applyTypeEnvToId@, not @apply_to_Id@, as the -former ``should be'' the usual crunch point. - \begin{code} type TypeEnv = TyVarEnv Type applyTypeEnvToId :: TypeEnv -> Id -> Id - applyTypeEnvToId type_env id@(Id _ _ ty _ _ _) - | idHasNoFreeTyVars id - = id - | otherwise = apply_to_Id ( \ ty -> applyTypeEnvToTy type_env ty ) id @@ -704,11 +649,11 @@ applyTypeEnvToId type_env id@(Id _ _ ty _ _ _) \begin{code} apply_to_Id :: (Type -> Type) -> Id -> Id -apply_to_Id ty_fn (Id u n ty details prag info) - = let - new_ty = ty_fn ty - in - Id u n new_ty (apply_to_details details) prag (apply_to_IdInfo ty_fn info) +apply_to_Id ty_fn id@(Id u n ty details prag info) + | idHasNoFreeTyVars id + = id + | otherwise + = Id u n (ty_fn ty) (apply_to_details details) prag (apply_to_IdInfo ty_fn info) where apply_to_details (SpecId unspec ty_maybes no_ftvs) = let @@ -721,56 +666,9 @@ apply_to_Id ty_fn (Id u n ty details prag info) apply_to_maybe Nothing = Nothing apply_to_maybe (Just ty) = Just (ty_fn ty) - apply_to_details (WorkerId unwrkr) - = let - new_unwrkr = apply_to_Id ty_fn unwrkr - in - WorkerId new_unwrkr - apply_to_details other = other \end{code} -Sadly, I don't think the one using the magic typechecker substitution -can be done with @apply_to_Id@. Here we go.... - -Strictness is very important here. We can't leave behind thunks -with pointers to the substitution: it {\em must} be single-threaded. - -\begin{code} -{-LATER: -applySubstToId :: Subst -> Id -> (Subst, Id) - -applySubstToId subst id@(Id u n ty info details) - -- *cannot* have a "idHasNoFreeTyVars" get-out clause - -- because, in the typechecker, we are still - -- *concocting* the types. - = case (applySubstToTy subst ty) of { (s2, new_ty) -> - case (applySubstToIdInfo s2 info) of { (s3, new_info) -> - case (apply_to_details s3 new_ty details) of { (s4, new_details) -> - (s4, Id u n new_ty new_info new_details) }}} - where - apply_to_details subst _ (InstId inst no_ftvs) - = case (applySubstToInst subst inst) of { (s2, new_inst) -> - (s2, InstId new_inst no_ftvs{-ToDo:right???-}) } - - apply_to_details subst new_ty (SpecId unspec ty_maybes _) - = case (applySubstToId subst unspec) of { (s2, new_unspec) -> - case (mapAccumL apply_to_maybe s2 ty_maybes) of { (s3, new_maybes) -> - (s3, SpecId new_unspec new_maybes (no_free_tvs new_ty)) }} - -- NB: recalc no_ftvs (I think it's necessary (?) WDP 95/04) - where - apply_to_maybe subst Nothing = (subst, Nothing) - apply_to_maybe subst (Just ty) - = case (applySubstToTy subst ty) of { (s2, new_ty) -> - (s2, Just new_ty) } - - apply_to_details subst _ (WorkerId unwrkr) - = case (applySubstToId subst unwrkr) of { (s2, new_unwrkr) -> - (s2, WorkerId new_unwrkr) } - - apply_to_details subst _ other = (subst, other) --} -\end{code} %************************************************************************ %* * @@ -779,21 +677,12 @@ applySubstToId subst id@(Id u n ty info details) %************************************************************************ \begin{code} -idType :: GenId ty -> ty +idName :: GenId ty -> Name +idName (Id _ n _ _ _ _) = n +idType :: GenId ty -> ty idType (Id _ _ ty _ _ _) = ty -\end{code} - -\begin{code} -{-LATER: -getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class) - -getMentionedTyConsAndClassesFromId id - = getMentionedTyConsAndClassesFromType (idType id) --} -\end{code} -\begin{code} idPrimRep i = typePrimRep (idType i) \end{code} @@ -815,61 +704,27 @@ mkSuperDictSelId u clas sc ty -- For method selectors the clean thing to do is -- to give the method selector the same name as the class op itself. -mkMethodSelId op_name rec_c op ty +mkMethodSelId op_name rec_c ty = addStandardIdInfo $ - Id (uniqueOf op_name) op_name ty (MethodSelId rec_c op) NoPragmaInfo noIdInfo + Id (uniqueOf op_name) op_name ty (MethodSelId rec_c) NoPragmaInfo noIdInfo -mkDefaultMethodId dm_name rec_c op gen ty - = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c op gen) NoPragmaInfo noIdInfo +mkDefaultMethodId dm_name rec_c ty + = Id (uniqueOf dm_name) dm_name ty (DefaultMethodId rec_c) NoPragmaInfo noIdInfo mkDictFunId dfun_name full_ty clas ity = Id (nameUnique dfun_name) dfun_name full_ty details NoPragmaInfo noIdInfo where details = DictFunId clas ity -mkConstMethodId uniq clas op ity full_ty from_here locn mod info - = Id uniq name full_ty details NoPragmaInfo info - where - name = mkInstDeclName uniq mod (VarOcc occ_name) locn from_here - details = ConstMethodId clas ity op mod - occ_name = classOpString op _APPEND_ - SLIT("_cm_") _APPEND_ renum_type_string full_ty ity - mkWorkerId u unwrkr ty info = Id u name ty details NoPragmaInfo info where + details = LocalId (no_free_tvs ty) name = mkCompoundName name_fn u (getName unwrkr) - details = WorkerId unwrkr name_fn wkr_str = SLIT("$w") _APPEND_ wkr_str mkInstId u ty name = Id u name ty (InstId (no_free_tvs ty)) NoPragmaInfo noIdInfo - -{-LATER: -getConstMethodId clas op ty - = -- constant-method info is hidden in the IdInfo of - -- the class-op id (as mentioned up above). - let - sel_id = getMethodSelId clas op - in - case (lookupConstMethodId (getIdSpecialisation sel_id) ty) of - Just xx -> xx - Nothing -> pprError "ERROR: getConstMethodId:" (vcat [ - hsep [ppr PprDebug ty, ppr PprDebug ops, ppr PprDebug op_ids, - ppr PprDebug sel_id], - text "(This can arise if an interface pragma refers to an instance", - text "but there is no imported interface which *defines* that instance.", - text "The info above, however ugly, should indicate what else you need to import." - ]) --} - - -renum_type_string full_ty ity - = initNmbr ( - nmbrType full_ty `thenNmbr` \ _ -> -- so all the tyvars get added to renumbering... - nmbrType ity `thenNmbr` \ rn_ity -> - returnNmbr (getTypeString rn_ity) - ) \end{code} %************************************************************************ @@ -886,6 +741,7 @@ mkPrimitiveId n ty primop Id (nameUnique n) n ty (PrimitiveId primop) IMustBeINLINEd noIdInfo -- The pragma @IMustBeINLINEd@ says that this Id absolutely must be inlined. -- It's only true for primitives, because we don't want to make a closure for each of them. + \end{code} \begin{code} @@ -911,50 +767,36 @@ mkUserId name ty pragma_info = Id (nameUnique name) name ty (LocalId (no_free_tvs ty)) pragma_info noIdInfo \end{code} - \begin{code} -{-LATER: +-- See notes with setNameVisibility (Name.lhs) +setIdVisibility :: Maybe Module -> Unique -> Id -> Id +setIdVisibility maybe_mod u (Id uniq name ty details prag info) + = Id uniq (setNameVisibility maybe_mod u name) ty details prag info --- for a SpecPragmaId being created by the compiler out of thin air... -mkSpecPragmaId :: OccName -> Unique -> Type -> Maybe Id -> SrcLoc -> Id -mkSpecPragmaId str uniq ty specid loc - = Id uniq (mkShortName str loc) ty noIdInfo (SpecPragmaId specid (no_free_tvs ty)) +mkIdWithNewUniq :: Id -> Unique -> Id +mkIdWithNewUniq (Id _ n ty details prag info) u + = Id u (changeUnique n u) ty details prag info --- for new SpecId -mkSpecId u unspec ty_maybes ty info - = ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Id u n ty info (SpecId unspec ty_maybes (no_free_tvs ty)) +mkIdWithNewName :: Id -> Name -> Id +mkIdWithNewName (Id _ _ ty details prag info) new_name + = Id (uniqueOf new_name) new_name ty details prag info + +mkIdWithNewType :: Id -> Type -> Id +mkIdWithNewType (Id u name _ details pragma info) ty + = Id u name ty details pragma info -- Specialised version of constructor: only used in STG and code generation -- Note: The specialsied Id has the same unique as the unspeced Id -mkSameSpecCon ty_maybes unspec@(Id u n ty info details) +mkSameSpecCon ty_maybes unspec@(Id u name ty details pragma info) = ASSERT(isDataCon unspec) ASSERT(not (maybeToBool (isSpecId_maybe unspec))) - Id u n new_ty info (SpecId unspec ty_maybes (no_free_tvs new_ty)) + Id u name new_ty (SpecId unspec ty_maybes (no_free_tvs new_ty)) pragma info where new_ty = specialiseTy ty ty_maybes 0 -localiseId :: Id -> Id -localiseId id@(Id u n ty info details) - = Id u (mkShortName name loc) ty info (LocalId (no_free_tvs ty)) - where - name = getOccName id - loc = getSrcLoc id --} - --- See notes with setNameVisibility (Name.lhs) -setIdVisibility :: Module -> Id -> Id -setIdVisibility mod (Id uniq name ty details prag info) - = Id uniq (setNameVisibility mod name) ty details prag info - -mkIdWithNewUniq :: Id -> Unique -> Id -mkIdWithNewUniq (Id _ n ty details prag info) u - = Id u (changeUnique n u) ty details prag info - -mkIdWithNewName :: Id -> Name -> Id -mkIdWithNewName (Id _ _ ty details prag info) new_name - = Id (uniqueOf new_name) new_name ty details prag info + -- pprTrace "SameSpecCon:Unique:" + -- (ppSep (ppr PprDebug unspec: [pprMaybeTy PprDebug ty | ty <- ty_maybes])) \end{code} Make some local @Ids@ for a template @CoreExpr@. These have bogus @@ -1076,6 +918,7 @@ dataConNumFields id length con_theta + length arg_tys } isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience + \end{code} @@ -1100,6 +943,29 @@ dataConSig (Id _ _ _ (TupleConId arity) _ _) where tyvars = take arity alphaTyVars tyvar_tys = mkTyVarTys tyvars +dataConSig (Id _ _ _ (SpecId unspec ty_maybes _) _ _) + = (spec_tyvars, spec_theta_ty, spec_con_tyvars, spec_con_theta, spec_arg_tys, spec_tycon) + where + (tyvars, theta_ty, con_tyvars, con_theta, arg_tys, tycon) = dataConSig unspec + + ty_env = tyvars `zip` ty_maybes + + spec_tyvars = foldr nothing_tyvars [] ty_env + spec_con_tyvars = foldr nothing_tyvars [] (con_tyvars `zip` ty_maybes) -- Hmm.. + + nothing_tyvars (tyvar, Nothing) l = tyvar : l + nothing_tyvars (tyvar, Just ty) l = l + + spec_env = foldr just_env [] ty_env + just_env (tyvar, Nothing) l = l + just_env (tyvar, Just ty) l = (tyvar, ty) : l + spec_arg_tys = map (instantiateTauTy spec_env) arg_tys + + spec_theta_ty = if null theta_ty then [] + else panic "dataConSig:ThetaTy:SpecDataCon1" + spec_con_theta = if null con_theta then [] + else panic "dataConSig:ThetaTy:SpecDataCon2" + spec_tycon = mkSpecTyCon tycon ty_maybes -- dataConRepType returns the type of the representation of a contructor @@ -1283,11 +1149,11 @@ addIdSpecialisation (Id u n ty details prags info) spec_info Strictness: we snaffle the info out of the IdInfo. \begin{code} -getIdStrictness :: Id -> StrictnessInfo Id +getIdStrictness :: Id -> StrictnessInfo getIdStrictness (Id _ _ _ _ _ info) = strictnessInfo info -addIdStrictness :: Id -> StrictnessInfo Id -> Id +addIdStrictness :: Id -> StrictnessInfo -> Id addIdStrictness (Id u n ty details prags info) strict_info = Id u n ty details prags (info `addStrictnessInfo` strict_info) \end{code} @@ -1482,91 +1348,3 @@ minusIdSet = minusUniqSet isEmptyIdSet = isEmptyUniqSet mkIdSet = mkUniqSet \end{code} - -\begin{code} -addId, nmbrId, nmbrDataCon :: Id -> NmbrM Id - -addId id@(Id u n 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 n new_ty new_det prag info - in - (nenv3, new_id) - -nmbrId id@(Id u n 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 n new_ty new_det prag info - in - (nenv3, new_id) - - -- used when renumbering TyCons to produce data decls... -nmbrDataCon id@(Id _ _ _ (TupleConId _) _ _) nenv - = (nenv, id) -- nothing to do for tuples - -nmbrDataCon id@(Id u n ty (AlgConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) prag info) - nenv@(NmbrEnv ui ut uu idenv tvenv uvenv) - = case (lookupUFM_Directly idenv u) of - Just xx -> trace "nmbrDataCon: in env???\n" (nenv, xx) - Nothing -> - let - (nenv2, new_fields) = (mapNmbr nmbrField fields) nenv - (nenv3, new_arg_tys) = (mapNmbr nmbrType arg_tys) nenv2 - - new_det = AlgConId tag marks new_fields (bottom "tvs") (bottom "theta") (bottom "tvs") (bottom "theta") new_arg_tys tc - new_id = Id u n (bottom "ty") new_det prag info - in - (nenv3, new_id) - where - bottom msg = panic ("nmbrDataCon"++msg) - ------------- -nmbr_details :: IdDetails -> NmbrM IdDetails - -nmbr_details (AlgConId tag marks fields tvs theta con_tvs con_theta arg_tys tc) - = mapNmbr nmbrTyVar tvs `thenNmbr` \ new_tvs -> - mapNmbr nmbrTyVar con_tvs `thenNmbr` \ new_con_tvs -> - mapNmbr nmbrField fields `thenNmbr` \ new_fields -> - mapNmbr nmbr_theta theta `thenNmbr` \ new_theta -> - mapNmbr nmbr_theta con_theta `thenNmbr` \ new_con_theta -> - mapNmbr nmbrType arg_tys `thenNmbr` \ new_arg_tys -> - returnNmbr (AlgConId tag marks new_fields new_tvs new_theta new_con_tvs new_con_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/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 0a9ef0e..2843e29 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -26,7 +26,6 @@ module IdInfo ( StrictnessInfo(..), -- Non-abstract Demand(..), NewOrData, -- Non-abstract - getWorkerId_maybe, workerExists, mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed, strictnessInfo, ppStrictnessInfo, addStrictnessInfo, @@ -63,7 +62,6 @@ import {-# SOURCE #-} CoreUnfold import {-# SOURCE #-} StdIdInfo #endif -import Type ( eqSimpleTy, splitFunTyExpandingDicts ) import BasicTypes ( NewOrData ) import CmdLineOpts ( opt_OmitInterfacePragmas ) @@ -79,7 +77,6 @@ import Util ( mapAccumL, panic, assertPanic, pprPanic ) ord = fromEnum :: Char -> Int #endif -applySubstToTy = panic "IdInfo.applySubstToTy" showTypeCategory = panic "IdInfo.showTypeCategory" \end{code} @@ -103,15 +100,11 @@ data IdInfo DemandInfo -- Whether or not it is definitely -- demanded - SpecEnv - -- Specialisations of this function which exist + SpecEnv -- Specialisations of this function which exist - (StrictnessInfo Id) - -- Strictness properties, notably - -- how to conjure up "worker" functions + StrictnessInfo -- Strictness properties - Unfolding - -- Its unfolding; for locally-defined + Unfolding -- Its unfolding; for locally-defined -- things, this can *only* be NoUnfolding UpdateInfo -- Which args should be updated @@ -139,39 +132,6 @@ apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold = idinfo | otherwise = panic "IdInfo:apply_to_IdInfo" -{- LATER: - let - new_spec = apply_spec spec - - -- NOT a good idea: - -- apply_strict strictness `thenLft` \ new_strict -> - -- apply_wrap wrap `thenLft` \ new_wrap -> - in - IdInfo arity demand new_spec strictness unfold - update deforest arg_usage fb_ww - where - apply_spec (SpecEnv is) - = SpecEnv (map do_one is) - where - do_one (SpecInfo ty_maybes ds spec_id) - = --apply_to_Id ty_fn spec_id `thenLft` \ new_spec_id -> - SpecInfo (map apply_to_maybe ty_maybes) ds spec_id - where - apply_to_maybe Nothing = Nothing - apply_to_maybe (Just ty) = Just (ty_fn ty) --} - -{- NOT a good idea; - apply_strict info@NoStrictnessInfo = returnLft info - apply_strict BottomGuaranteed = ??? - apply_strict (StrictnessInfo wrap_arg_info id_maybe) - = (case id_maybe of - Nothing -> returnLft Nothing - Just xx -> applySubstToId subst xx `thenLft` \ new_xx -> - returnLft (Just new_xx) - ) `thenLft` \ new_id_maybe -> - returnLft (StrictnessInfo wrap_arg_info new_id_maybe) --} \end{code} Variant of the same thing for the typechecker. @@ -179,23 +139,6 @@ Variant of the same thing for the typechecker. applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold update deforest arg_usage fb_ww) = panic "IdInfo:applySubstToIdInfo" -{- LATER: - case (apply_spec s0 spec) of { (s1, new_spec) -> - (s1, IdInfo arity demand new_spec strictness unfold update deforest arg_usage fb_ww) } - where - apply_spec s0 (SpecEnv is) - = case (mapAccumL do_one s0 is) of { (s1, new_is) -> - (s1, SpecEnv new_is) } - where - do_one s0 (SpecInfo ty_maybes ds spec_id) - = case (mapAccumL apply_to_maybe s0 ty_maybes) of { (s1, new_maybes) -> - (s1, SpecInfo new_maybes ds spec_id) } - where - apply_to_maybe s0 Nothing = (s0, Nothing) - apply_to_maybe s0 (Just ty) - = case (applySubstToTy s0 ty) of { (s1, new_ty) -> - (s1, Just new_ty) } --} \end{code} \begin{code} @@ -324,7 +267,7 @@ version of the function; and (c)~the type signature of that worker (if it exists); i.e. its calling convention. \begin{code} -data StrictnessInfo bdee +data StrictnessInfo = NoStrictnessInfo | BottomGuaranteed -- This Id guarantees never to return; @@ -332,25 +275,28 @@ data StrictnessInfo bdee -- Useful for "error" and other disguised -- variants thereof. - | StrictnessInfo [Demand] -- The main stuff; see below. - (Maybe (bdee,[bdee])) -- Worker's Id, if applicable, and a list of the constructors - -- mentioned by the wrapper. This is necessary so that the - -- renamer can slurp them in. Without this info, the renamer doesn't - -- know which data types to slurp in concretely. Remember, for - -- strict things we don't put the unfolding in the interface file, to save space. - -- This constructor list allows the renamer to behave much as if the - -- unfolding *was* in the interface file. - -- - -- This field might be Nothing even for a strict fn because the strictness info - -- might say just "SSS" or something; so there's no w/w split. + | StrictnessInfo [Demand] + Bool -- True <=> there is a worker. There might not be, even for a + -- strict function, because: + -- (a) the function might be small enough to inline, + -- so no need for w/w split + -- (b) the strictness info might be "SSS" or something, so no w/w split. + + -- Worker's Id, if applicable, and a list of the constructors + -- mentioned by the wrapper. This is necessary so that the + -- renamer can slurp them in. Without this info, the renamer doesn't + -- know which data types to slurp in concretely. Remember, for + -- strict things we don't put the unfolding in the interface file, to save space. + -- This constructor list allows the renamer to behave much as if the + -- unfolding *was* in the interface file. \end{code} \begin{code} -mkStrictnessInfo :: [Demand] -> Maybe (bdee,[bdee]) -> StrictnessInfo bdee +mkStrictnessInfo :: [Demand] -> Bool -> StrictnessInfo -mkStrictnessInfo xs wrkr +mkStrictnessInfo xs has_wrkr | all is_lazy xs = NoStrictnessInfo -- Uninteresting - | otherwise = StrictnessInfo xs wrkr + | otherwise = StrictnessInfo xs has_wrkr where is_lazy (WwLazy False) = True -- NB "Absent" args do *not* count! is_lazy _ = False -- (as they imply a worker) @@ -370,24 +316,14 @@ ppStrictnessInfo sty NoStrictnessInfo = empty ppStrictnessInfo sty BottomGuaranteed = ptext SLIT("_bot_") ppStrictnessInfo sty (StrictnessInfo wrapper_args wrkr_maybe) - = hsep [ptext SLIT("_S_"), text (showList wrapper_args ""), pp_wrkr] - where - pp_wrkr = case wrkr_maybe of - Nothing -> empty - Just (wrkr,cons) | ifaceStyle sty && - not (null cons) -> pprId sty wrkr <+> braces (hsep (map (pprId sty) cons)) - | otherwise -> pprId sty wrkr + = hsep [ptext SLIT("_S_"), text (showList wrapper_args "")] \end{code} \begin{code} -workerExists :: StrictnessInfo bdee -> Bool -workerExists (StrictnessInfo _ (Just worker_id)) = True -workerExists other = False - -getWorkerId_maybe :: StrictnessInfo bdee -> Maybe bdee -getWorkerId_maybe (StrictnessInfo _ (Just (wrkr,_))) = Just wrkr -getWorkerId_maybe other = Nothing +workerExists :: StrictnessInfo -> Bool +workerExists (StrictnessInfo _ worker_exists) = worker_exists +workerExists other = False \end{code} diff --git a/ghc/compiler/basicTypes/IdLoop.lhi b/ghc/compiler/basicTypes/IdLoop.lhi index e22065b..48ea6b1 100644 --- a/ghc/compiler/basicTypes/IdLoop.lhi +++ b/ghc/compiler/basicTypes/IdLoop.lhi @@ -13,10 +13,11 @@ import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..), mkUnfolding, SimpleUnfolding(..), FormSummary(..), noUnfolding ) import CoreUtils ( unTagBinders ) import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId, - unfoldingUnfriendlyId, getIdInfo, nmbrId, pprId, + unfoldingUnfriendlyId, getIdInfo, nmbrId, pprId, idName, nullIdEnv, lookupIdEnv, IdEnv(..), Id(..), GenId ) +import Name ( Name ) import CostCentre ( CostCentre, noCostCentre, subsumedCosts, cafifyCC, useCurrentCostCentre, dontCareCostCentre, @@ -30,7 +31,6 @@ import Literal ( Literal ) import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun ) import OccurAnal ( occurAnalyseGlobalExpr ) import Outputable ( Outputable(..), PprStyle ) -import PprEnv ( NmbrEnv ) import PprType ( pprParendGenType ) import PragmaInfo ( PragmaInfo ) import Pretty ( Doc ) @@ -54,9 +54,9 @@ isNullSpecEnv :: SpecEnv -> Bool externallyVisibleId :: Id -> Bool isDataCon :: GenId ty -> Bool isWorkerId :: GenId ty -> Bool -nmbrId :: Id -> NmbrEnv -> (NmbrEnv, Id) pprId :: Outputable ty => PprStyle -> GenId ty -> Doc mkMagicUnfoldingFun :: Unique -> MagicUnfoldingFun +idName :: Id -> Name type IdEnv a = UniqFM a @@ -75,7 +75,6 @@ instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b) data DemandInfo data SpecEnv -data NmbrEnv data MagicUnfoldingFun data FormSummary = VarForm | ValueForm | BottomForm | OtherForm diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index 1750dc7..1570bc5 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -15,7 +15,7 @@ module Name ( OccName(..), pprOccName, occNameString, occNameFlavour, isTvOcc, isTCOcc, isVarOcc, prefixOccName, - quoteInText, parenInCode, + uniqToOccName, -- The Name type Name, -- Abstract @@ -44,7 +44,6 @@ module Name ( minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, isEmptyNameSet, -- Misc - DefnInfo(..), Provenance(..), pprProvenance, ExportFlag(..), @@ -64,7 +63,7 @@ import {-# SOURCE #-} TyCon ( TyCon ) import CStrings ( identToC, modnameToC, cSEP ) import CmdLineOpts ( opt_OmitInterfacePragmas, opt_EnsureSplittableC ) -import BasicTypes ( SYN_IE(Module), moduleString, pprModule ) +import BasicTypes ( SYN_IE(Module), IfaceFlavour(..), moduleString, pprModule ) import Outputable ( Outputable(..), PprStyle(..), codeStyle, ifaceStyle ) import PrelMods ( gHC__ ) @@ -76,8 +75,7 @@ import Unique ( pprUnique, showUnique, Unique, Uniquable(..) ) import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, uniqSetToList, isEmptyUniqSet, unionManyUniqSets, minusUniqSet, mkUniqSet, elementOfUniqSet, addListToUniqSet, addOneToUniqSet ) import UniqFM ( UniqFM ) -import Util --( cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} ) - +import Util ( Ord3(..), cmpPString, panic, assertPanic {-, pprTrace ToDo:rm-} ) \end{code} @@ -126,7 +124,6 @@ isTvOcc other = False isTCOcc (TCOcc s) = True isTCOcc other = False - instance Eq OccName where a == b = case (a `cmp` b) of { EQ_ -> True; _ -> False } a /= b = case (a `cmp` b) of { EQ_ -> False; _ -> True } @@ -155,13 +152,6 @@ instance Outputable OccName where \end{code} -\begin{code} -parenInCode, quoteInText :: OccName -> Bool -parenInCode occ = isLexSym (occNameString occ) - -quoteInText occ = not (isLexSym (occNameString occ)) -\end{code} - %************************************************************************ %* * \subsection[Name-datatype]{The @Name@ datatype, and name construction} @@ -177,8 +167,7 @@ data Name | Global Unique Module -- The defining module OccName -- Its name in that module - DefnInfo -- How it is defined - Provenance -- How it was brought into scope + Provenance -- How it was defined \end{code} Things with a @Global@ name are given C static labels, so they finally @@ -187,14 +176,14 @@ in the form M.n. If originally-local things have this property they must be made @Global@ first. \begin{code} -data DefnInfo = VanillaDefn - | WiredInTyCon TyCon -- There's a wired-in version - | WiredInId Id -- ...ditto... - data Provenance - = LocalDef ExportFlag SrcLoc -- Locally defined - | Imported Module SrcLoc -- Directly imported from M; gives locn of import statement - | Implicit -- Implicitly imported + = LocalDef ExportFlag SrcLoc -- Locally defined + | Imported Module SrcLoc IfaceFlavour -- Directly imported from M; + -- gives name of module in import statement + -- and locn of import statement + | Implicit IfaceFlavour -- Implicitly imported + | WiredInTyCon TyCon -- There's a wired-in version + | WiredInId Id -- ...ditto... \end{code} Something is "Exported" if it may be mentioned by another module without @@ -219,7 +208,7 @@ data ExportFlag = Exported | NotExported mkLocalName :: Unique -> OccName -> SrcLoc -> Name mkLocalName = Local -mkGlobalName :: Unique -> Module -> OccName -> DefnInfo -> Provenance -> Name +mkGlobalName :: Unique -> Module -> OccName -> Provenance -> Name mkGlobalName = Global mkSysLocalName :: Unique -> FAST_STRING -> SrcLoc -> Name @@ -227,11 +216,11 @@ mkSysLocalName uniq str loc = Local uniq (VarOcc str) loc mkWiredInIdName :: Unique -> Module -> FAST_STRING -> Id -> Name mkWiredInIdName uniq mod occ id - = Global uniq mod (VarOcc occ) (WiredInId id) Implicit + = Global uniq mod (VarOcc occ) (WiredInId id) mkWiredInTyConName :: Unique -> Module -> FAST_STRING -> TyCon -> Name mkWiredInTyConName uniq mod occ tycon - = Global uniq mod (TCOcc occ) (WiredInTyCon tycon) Implicit + = Global uniq mod (TCOcc occ) (WiredInTyCon tycon) mkCompoundName :: (FAST_STRING -> FAST_STRING) -- Occurrence-name modifier @@ -239,8 +228,8 @@ mkCompoundName :: (FAST_STRING -> FAST_STRING) -- Occurrence-name modifier -> Name -- Base name (must be a Global) -> Name -- Result is always a value name -mkCompoundName str_fn uniq (Global _ mod occ defn prov) - = Global uniq mod new_occ defn prov +mkCompoundName str_fn uniq (Global _ mod occ prov) + = Global uniq mod new_occ prov where new_occ = VarOcc (str_fn (occNameString occ)) -- Always a VarOcc @@ -250,51 +239,95 @@ mkCompoundName str_fn uniq (Local _ occ loc) -- Rather a wierd one that's used for names generated for instance decls mkInstDeclName :: Unique -> Module -> OccName -> SrcLoc -> Bool -> Name mkInstDeclName uniq mod occ loc from_here - = Global uniq mod occ VanillaDefn prov + = Global uniq mod occ prov where prov | from_here = LocalDef Exported loc - | otherwise = Implicit + | otherwise = Implicit HiFile -- Odd setNameProvenance :: Name -> Provenance -> Name -- setNameProvenance used to only change the provenance of Implicit-provenance things, -- but that gives bad error messages for names defined twice in the same -- module, so I changed it to set the proveance of *any* global (SLPJ Jun 97) -setNameProvenance (Global uniq mod occ def _) prov = Global uniq mod occ def prov -setNameProvenance other_name prov = other_name +setNameProvenance (Global uniq mod occ _) prov = Global uniq mod occ prov +setNameProvenance other_name prov = other_name getNameProvenance :: Name -> Provenance -getNameProvenance (Global uniq mod occ def prov) = prov -getNameProvenance (Local uniq occ locn) = LocalDef NotExported locn +getNameProvenance (Global uniq mod occ prov) = prov +getNameProvenance (Local uniq occ locn) = LocalDef NotExported locn -- When we renumber/rename things, we need to be -- able to change a Name's Unique to match the cached -- one in the thing it's the name of. If you know what I mean. changeUnique (Local _ n l) u = Local u n l -changeUnique (Global _ mod occ def prov) u = Global u mod occ def prov +changeUnique (Global _ mod occ prov) u = Global u mod occ prov +\end{code} + +setNameVisibility is applied to names in the final program + +The Maybe Module argument is (Just mod) for top-level values, +and Nothing for all others (local values and type variables) + +For top-level things, it globalises Local names + (if all top-level things should be visible) + and localises non-exported Global names + (if only exported things should be visible) + +For nested things it localises Global names. -setNameVisibility :: Module -> Name -> Name --- setNameVisibility is applied to top-level names in the final program --- The "visibility" here concerns whether the .o file's symbol table --- mentions the thing; if so, it needs a module name in its symbol, --- otherwise we just use its unique. The Global things are "visible" --- and the local ones are not +In all cases except an exported global, it gives it a new occurrence name. -setNameVisibility _ (Global uniq mod occ def (LocalDef NotExported loc)) - | not all_toplev_ids_visible - = Local uniq occ loc +The "visibility" here concerns whether the .o file's symbol table +mentions the thing; if so, it needs a module name in its symbol. +The Global things are "visible" and the Local ones are not -setNameVisibility mod (Local uniq occ loc) +Why should things be "visible"? Certainly they must be if they +are exported. But also: + +(a) In certain (prelude only) modules we split up the .hc file into + lots of separate little files, which are separately compiled by the C + compiler. That gives lots of little .o files. The idea is that if + you happen to mention one of them you don't necessarily pull them all + in. (Pulling in a piece you don't need can be v bad, because it may + mention other pieces you don't need either, and so on.) + + Sadly, splitting up .hc files means that local names (like s234) are + now globally visible, which can lead to clashes between two .hc + files. So unlocaliseWhatnot goes through making all the local things + into global things, essentially by giving them full names so when they + are printed they'll have their module name too. Pretty revolting + really. + +(b) When optimisation is on we want to make all the internal + top-level defns externally visible + +\begin{code} +setNameVisibility :: Maybe Module -> Unique -> Name -> Name + +setNameVisibility maybe_mod occ_uniq name@(Global uniq mod occ (LocalDef NotExported loc)) + | not all_toplev_ids_visible || not_top_level maybe_mod + = Local uniq (uniqToOccName occ_uniq) loc -- Localise Global name + +setNameVisibility maybe_mod occ_uniq name@(Global _ _ _ _) + = name -- Otherwise don't fiddle with Global + +setNameVisibility (Just mod) occ_uniq (Local uniq occ loc) | all_toplev_ids_visible - = Global uniq mod - (VarOcc (showUnique uniq)) -- It's local name must be unique! - VanillaDefn (LocalDef NotExported loc) + = Global uniq mod -- Globalise Local name + (uniqToOccName occ_uniq) + (LocalDef NotExported loc) + +setNameVisibility maybe_mod occ_uniq (Local uniq occ loc) + = Local uniq (uniqToOccName occ_uniq) loc -- New OccName for Local + +uniqToOccName uniq = VarOcc (_PK_ ('$':showUnique uniq)) + -- The "$" is to make sure that this OccName is distinct from all user-defined ones -setNameVisibility mod name = name +not_top_level (Just m) = False +not_top_level Nothing = True all_toplev_ids_visible = not opt_OmitInterfacePragmas || -- Pragmas can make them visible opt_EnsureSplittableC -- Splitting requires visiblilty - \end{code} %************************************************************************ @@ -318,45 +351,45 @@ isLocalName :: Name -> Bool nameUnique (Local u _ _) = u -nameUnique (Global u _ _ _ _) = u +nameUnique (Global u _ _ _) = u -nameOccName (Local _ occ _) = occ -nameOccName (Global _ _ occ _ _) = occ +nameOccName (Local _ occ _) = occ +nameOccName (Global _ _ occ _) = occ -nameModule (Global _ mod occ _ _) = mod +nameModule (Global _ mod occ _) = mod -nameModAndOcc (Global _ mod occ _ _) = (mod,occ) +nameModAndOcc (Global _ mod occ _) = (mod,occ) -nameString (Local _ occ _) = occNameString occ -nameString (Global _ mod occ _ _) = mod _APPEND_ SLIT(".") _APPEND_ occNameString occ +nameString (Local _ occ _) = occNameString occ +nameString (Global _ mod occ _) = mod _APPEND_ SLIT(".") _APPEND_ occNameString occ -isExportedName (Global _ _ _ _ (LocalDef Exported _)) = True -isExportedName other = False +isExportedName (Global _ _ _ (LocalDef Exported _)) = True +isExportedName other = False nameSrcLoc (Local _ _ loc) = loc -nameSrcLoc (Global _ _ _ _ (LocalDef _ loc)) = loc -nameSrcLoc (Global _ _ _ _ (Imported _ loc)) = loc +nameSrcLoc (Global _ _ _ (LocalDef _ loc)) = loc +nameSrcLoc (Global _ _ _ (Imported _ loc _)) = loc nameSrcLoc other = noSrcLoc isLocallyDefinedName (Local _ _ _) = True -isLocallyDefinedName (Global _ _ _ _ (LocalDef _ _)) = True -isLocallyDefinedName other = False +isLocallyDefinedName (Global _ _ _ (LocalDef _ _)) = True +isLocallyDefinedName other = False -- Things the compiler "knows about" are in some sense -- "imported". When we are compiling the module where -- the entities are defined, we need to be able to pick -- them out, often in combination with isLocallyDefined. -isWiredInName (Global _ _ _ (WiredInTyCon _) _) = True -isWiredInName (Global _ _ _ (WiredInId _) _) = True +isWiredInName (Global _ _ _ (WiredInTyCon _)) = True +isWiredInName (Global _ _ _ (WiredInId _)) = True isWiredInName _ = False maybeWiredInIdName :: Name -> Maybe Id -maybeWiredInIdName (Global _ _ _ (WiredInId id) _) = Just id -maybeWiredInIdName other = Nothing +maybeWiredInIdName (Global _ _ _ (WiredInId id)) = Just id +maybeWiredInIdName other = Nothing maybeWiredInTyConName :: Name -> Maybe TyCon -maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc) _) = Just tc -maybeWiredInTyConName other = Nothing +maybeWiredInTyConName (Global _ _ _ (WiredInTyCon tc)) = Just tc +maybeWiredInTyConName other = Nothing isLocalName (Local _ _ _) = True @@ -373,10 +406,10 @@ isLocalName _ = False \begin{code} cmpName n1 n2 = c n1 n2 where - c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2 - c (Local _ _ _) _ = LT_ - c (Global u1 _ _ _ _) (Global u2 _ _ _ _) = cmp u1 u2 - c (Global _ _ _ _ _) _ = GT_ + c (Local u1 _ _) (Local u2 _ _) = cmp u1 u2 + c (Local _ _ _) _ = LT_ + c (Global u1 _ _ _) (Global u2 _ _ _) = cmp u1 u2 + c (Global _ _ _ _) _ = GT_ \end{code} \begin{code} @@ -410,49 +443,59 @@ instance NamedThing Name where \begin{code} instance Outputable Name where - ppr PprQuote name@(Local _ _ _) = quotes (ppr (PprForUser 1) name) - ppr (PprForUser _) (Local _ n _) = ptext (occNameString n) + ppr PprQuote name@(Local _ _ _) = quotes (ppr (PprForUser 1) name) + + -- When printing interfaces, all Locals have been given nice print-names + ppr (PprForUser _) (Local _ n _) = ptext (occNameString n) + ppr PprInterface (Local _ n _) = ptext (occNameString n) - ppr sty (Local u n _) | codeStyle sty || - ifaceStyle sty = pprUnique u + ppr sty (Local u n _) | codeStyle sty = pprUnique u - ppr sty (Local u n _) = hcat [ptext (occNameString n), ptext SLIT("_"), pprUnique u] + ppr sty (Local u n _) = hcat [ptext (occNameString n), ptext SLIT("_"), pprUnique u] - ppr PprQuote name@(Global _ _ _ _ _) = quotes (ppr (PprForUser 1) name) + ppr PprQuote name@(Global _ _ _ _) = quotes (ppr (PprForUser 1) name) - ppr sty name@(Global u m n _ _) + ppr sty name@(Global u m n _) | codeStyle sty = identToC (m _APPEND_ SLIT(".") _APPEND_ occNameString n) - ppr sty name@(Global u m n _ prov) - = hcat [pp_mod, ptext (occNameString n), pp_debug sty name] + ppr sty name@(Global u m n prov) + = hcat [pp_mod_dot, ptext (occNameString n), pp_debug sty name] where - pp_mod = case prov of --- Omit home module qualifier - LocalDef _ _ -> empty - other -> pprModule (PprForUser 1) m <> char '.' + pp_mod = pprModule (PprForUser 1) m + pp_mod_dot = case prov of --- Omit home module qualifier + LocalDef _ _ -> empty + Imported _ _ hif -> pp_mod <> pp_dot hif + Implicit hif -> pp_mod <> pp_dot hif + other -> pp_mod <> text "." + + pp_dot HiFile = text "." -- Vanilla case + pp_dot HiBootFile = text "!" -- M!t indicates a name imported from a .hi-boot interface -pp_debug PprDebug (Global uniq m n _ prov) = hcat [text "{-", pprUnique uniq, char ',', +pp_debug PprDebug (Global uniq m n prov) = hcat [text "{-", pprUnique uniq, char ',', pp_prov prov, text "-}"] where pp_prov (LocalDef Exported _) = char 'x' pp_prov (LocalDef NotExported _) = char 'l' - pp_prov (Imported _ _) = char 'i' - pp_prov Implicit = char 'p' + pp_prov (Imported _ _ _) = char 'i' + pp_prov (Implicit _) = char 'p' + pp_prov (WiredInTyCon _) = char 'W' + pp_prov (WiredInId _) = char 'w' pp_debug other name = empty -- pprNameProvenance is used in error messages to say where a name came from pprNameProvenance :: PprStyle -> Name -> Doc -pprNameProvenance sty (Local _ _ loc) = pprProvenance sty (LocalDef NotExported loc) -pprNameProvenance sty (Global _ _ _ _ prov) = pprProvenance sty prov +pprNameProvenance sty (Local _ _ loc) = pprProvenance sty (LocalDef NotExported loc) +pprNameProvenance sty (Global _ _ _ prov) = pprProvenance sty prov pprProvenance :: PprStyle -> Provenance -> Doc -pprProvenance sty (Imported mod loc) +pprProvenance sty (Imported mod loc _) = sep [ptext SLIT("Imported from"), pprModule sty mod, ptext SLIT("at"), ppr sty loc] -pprProvenance sty (LocalDef _ loc) - = sep [ptext SLIT("Defined at"), ppr sty loc] -pprProvenance sty Implicit - = panic "pprNameProvenance: Implicit" +pprProvenance sty (LocalDef _ loc) = sep [ptext SLIT("Defined at"), ppr sty loc] +pprProvenance sty (Implicit _) = panic "pprNameProvenance: Implicit" +pprProvenance sty (WiredInTyCon tc) = ptext SLIT("Wired-in tycon") +pprProvenance sty (WiredInId id) = ptext SLIT("Wired-in id") \end{code} diff --git a/ghc/compiler/basicTypes/PprEnv.lhs b/ghc/compiler/basicTypes/PprEnv.lhs index 63aa9c3..0962f9a 100644 --- a/ghc/compiler/basicTypes/PprEnv.lhs +++ b/ghc/compiler/basicTypes/PprEnv.lhs @@ -12,22 +12,15 @@ module PprEnv ( initPprEnv, pCon, pLit, pMajBndr, pMinBndr, pOcc, pPrim, pSCC, pStyle, - pTy, pTyVarB, pTyVarO, pUVar, pUse, + pTy, pTyVarB, pTyVarO, pUVar, pUse - NmbrEnv(..), - SYN_IE(NmbrM), initNmbr, - returnNmbr, thenNmbr, - mapNmbr, mapAndUnzipNmbr --- nmbr1, nmbr2, nmbr3 --- rnumValVar, rnumTyVar, rnumUVar, --- lookupValVar, lookupTyVar, lookupUVar ) where IMP_Ubiq(){-uitous-} import Pretty ( Doc ) import Outputable -import Unique ( initRenumberingUniques, Unique ) +import Unique ( Unique ) import UniqFM ( emptyUFM, UniqFM ) import Util ( panic ) #if __GLASGOW_HASKELL__ >= 202 @@ -145,75 +138,3 @@ 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/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index 5fa5ad7..9aa57b9 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -30,7 +30,8 @@ module Unique ( mkUniqueGrimily, -- Used in UniqSupply only! incrUnique, -- Used for renumbering - initRenumberingUniques, + initTyVarUnique, mkTyVarUnique, + initTidyUniques, -- now all the built-in Uniques (and functions to make them) -- [the Oh-So-Wonderful Haskell module system wins again...] @@ -229,9 +230,7 @@ import PreludeGlaST #else import GlaExts import ST -#if __GLASGOW_HASKELL__ == 202 -import PrelBase ( Char(..) ) -#endif +import PrelBase ( Char(..), chr, ord ) #endif IMP_Ubiq(){-uitous-} @@ -350,28 +349,20 @@ pprUnique10 uniq -- in base-10, dudes = case unpkUnique uniq of (tag, u) -> finish_ppr tag u (int u) -finish_ppr tag u pp_u - = if tag /= 't' -- this is just to make v common tyvars, t1, t2, ... - -- come out as a, b, ... (shorter, easier to read) - then pp_all - else case u of - 1 -> char 'a' - 2 -> char 'b' - 3 -> char 'c' - 4 -> char 'd' - 5 -> char 'e' - _ -> pp_all - where - pp_all = (<>) (char tag) pp_u +finish_ppr 't' u pp_u | u < 26 + = -- Special case to make v common tyvars, t1, t2, ... + -- come out as a, b, ... (shorter, easier to read) + char (chr (ord 'a' + u)) +finish_ppr tag u pp_u = char tag <> pp_u -showUnique :: Unique -> FAST_STRING -showUnique uniq = _PK_ (show (pprUnique uniq)) +showUnique :: Unique -> String +showUnique uniq = show (pprUnique uniq) instance Outputable Unique where ppr sty u = pprUnique u instance Text Unique where - showsPrec p uniq rest = _UNPK_ (showUnique uniq) + showsPrec p uniq rest = showUnique uniq \end{code} %************************************************************************ @@ -464,7 +455,17 @@ 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) +-- The "tyvar uniques" print specially nicely: a, b, c, etc. +-- See pprUnique for details + +initTyVarUnique :: Unique +initTyVarUnique = mkUnique 't' 0 + +mkTyVarUnique :: Int -> Unique +mkTyVarUnique n = mkUnique 't' n + +initTidyUniques :: (Unique, Unique) -- Global and local +initTidyUniques = (mkUnique 'g' 0, mkUnique 'x' 0) mkPseudoUnique1, mkPseudoUnique2, mkPseudoUnique3, mkBuiltinUnique :: Int -> Unique diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index 75a4d19..673dd7a 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -436,6 +436,10 @@ closureCodeBody binder_info closure_info cc all_args body = getEntryConvention id lf_info (map idPrimRep all_args) `thenFC` \ entry_conv -> let + -- Figure out what is needed and what isn't + slow_code_needed = slowFunEntryCodeRequired id binder_info entry_conv + info_table_needed = funInfoTableRequired id binder_info lf_info + -- Arg mapping for standard (slow) entry point; all args on stack (spA_all_args, spB_all_args, all_bxd_w_offsets, all_ubxd_w_offsets) = mkVirtStkOffsets @@ -552,10 +556,6 @@ closureCodeBody binder_info closure_info cc all_args body cl_descr mod_name = closureDescription mod_name id all_args body - -- Figure out what is needed and what isn't - slow_code_needed = slowFunEntryCodeRequired id binder_info - info_table_needed = funInfoTableRequired id binder_info lf_info - -- Manufacture labels id = closureId closure_info fast_label = mkFastEntryLabel id stg_arity diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index cd9f4a8..30b0462 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -54,8 +54,6 @@ module ClosureInfo ( IMP_Ubiq(){-uitous-} #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 IMPORT_DELOOPER(AbsCLoop) -- here for paranoia-checking -#else -import {-# SOURCE #-} CLabel ( CLabel ) #endif import AbsCSyn @@ -70,7 +68,7 @@ import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject, import CgRetConv ( assignRegs, dataReturnConvAlg, DataReturnConvention(..) ) -import CLabel ( mkStdEntryLabel, mkFastEntryLabel, +import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, mkPhantomInfoTableLabel, mkInfoTableLabel, mkConInfoTableLabel, mkStaticClosureLabel, mkBlackHoleInfoTableLabel, mkVapInfoTableLabel, @@ -736,7 +734,7 @@ nodeMustPointToIt lf_info -- having Node point to the result of an update. SLPJ -- 27/11/92. - LFThunk _ no_fvs updatable _ + LFThunk _ no_fvs updatable NonStandardThunk -> returnFC (updatable || not no_fvs || do_profiling) -- For the non-updatable (single-entry case): @@ -746,6 +744,15 @@ nodeMustPointToIt lf_info -- or profiling (in which case we need to recover the cost centre -- from inside it) + LFThunk _ no_fvs updatable some_standard_form_thunk + -> returnFC True + -- Node must point to any standard-form thunk. + -- For example, + -- x = f y + -- generates a Vap thunk for (f y), and even if y is a global + -- variable we must still make Node point to the thunk before entering it + -- because that's what the standard-form code expects. + LFArgument -> returnFC True LFImported -> returnFC True LFBlackHole -> returnFC True @@ -981,14 +988,17 @@ staticClosureRequired binder other_binder_info other_lf_info = True slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk. :: Id -> StgBinderInfo + -> EntryConvention -> Bool -slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) +slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) entry_conv = arg_occ -- There's an argument occurrence || unsat_occ -- There's an unsaturated call || externallyVisibleId binder - {- HAS FREE VARS AND IS PARALLEL WORLD -} + || (case entry_conv of { DirectEntry _ _ _ -> False; other -> True }) + {- The last case deals with the parallel world; a function usually + as a DirectEntry convention, but if it doesn't we must generate slow-entry code -} -slowFunEntryCodeRequired binder NoStgBinderInfo = True +slowFunEntryCodeRequired binder NoStgBinderInfo _ = True funInfoTableRequired :: Id diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index bb6a323..cf63b8b 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -21,8 +21,9 @@ IMP_Ubiq(){-uitous-} import CoreSyn import CoreUtils ( coreExprType ) import Id ( idType, mkSysLocal, - nullIdEnv, growIdEnvList, lookupIdEnv, SYN_IE(IdEnv), - GenId{-instances-}, SYN_IE(Id) + nullIdEnv, growIdEnvList, lookupIdEnv, + mkIdWithNewType, + SYN_IE(IdEnv), GenId{-instances-}, SYN_IE(Id) ) import Name ( isLocallyDefined, getSrcLoc, getOccString ) import TyCon ( isBoxedTyCon, TyCon{-instance-} ) @@ -35,7 +36,6 @@ import Util ( zipEqual, zipWithEqual, assertPanic, panic ) infixr 9 `thenL` -updateIdType = panic "CoreLift.updateIdType" \end{code} %************************************************************************ @@ -280,7 +280,7 @@ mkLiftedId id u (lifted_id, unlifted_id) where id_name = _PK_ (getOccString id) -- yuk! - lifted_id = updateIdType id lifted_ty + lifted_id = mkIdWithNewType id lifted_ty unlifted_id = mkSysLocal id_name u unlifted_ty (getSrcLoc id) unlifted_ty = idType id @@ -311,8 +311,8 @@ applyBindUnlifts :: [CoreExpr -> CoreExpr] -> CoreExpr -> CoreExpr applyBindUnlifts [] expr = expr applyBindUnlifts (f:fs) expr = f (applyBindUnlifts fs expr) -isUnboxedButNotState ty - = case (maybeAppDataTyConExpandingDicts ty) of +isUnboxedButNotState ty = + case (maybeAppDataTyConExpandingDicts ty) of Nothing -> False Just (tycon, _, _) -> not (isBoxedTyCon tycon) && not (tycon == statePrimTyCon) diff --git a/ghc/compiler/coreSyn/CoreUnfold.lhs b/ghc/compiler/coreSyn/CoreUnfold.lhs index 0111031..bf75aa0 100644 --- a/ghc/compiler/coreSyn/CoreUnfold.lhs +++ b/ghc/compiler/coreSyn/CoreUnfold.lhs @@ -39,7 +39,6 @@ IMPORT_DELOOPER(PrelLoop) -- for paranoia checking IMPORT_DELOOPER(SmplLoop) #else import {-# SOURCE #-} MagicUFs -import {-# SOURCE #-} Id ( Id ) #endif import Bag ( emptyBag, unitBag, unionBags, Bag ) @@ -61,7 +60,7 @@ import RdrHsSyn ( RdrName ) import OccurAnal ( occurAnalyseGlobalExpr ) import CoreUtils ( coreExprType ) --import CostCentre ( ccMentionsId ) -import Id ( idType, getIdArity, isBottomingId, isDataCon, isPrimitiveId_maybe, +import Id ( SYN_IE(Id), idType, getIdArity, isBottomingId, isDataCon, --rm: isPrimitiveId_maybe, SYN_IE(IdSet), GenId{-instances-} ) import PrimOp ( primOpCanTriggerGC, fragilePrimOp, PrimOp(..) ) import IdInfo ( ArityInfo(..), bottomIsGuaranteed ) @@ -434,7 +433,7 @@ data ExprSize = TooBig sizeZero = SizeIs 0# [] 0# sizeOne = SizeIs 1# [] 0# sizeN (I# n) = SizeIs n [] 0# -conSizeN (I# n) = SizeIs n [] n +conSizeN (I# n) = SizeIs n [] n scrutArg v = SizeIs 0# [v] 0# nukeScrutDiscount (SizeIs n vs d) = SizeIs n vs 0# @@ -488,15 +487,7 @@ smallEnoughToInline arg_is_evald_s result_is_scruted enough_args n [] | n > 0 = False -- A function with no value args => don't unfold enough_args _ _ = True -- Otherwise it's ok to try -{- OLD: require saturated args - enough_args 0 evals = True - enough_args n [] = False - enough_args n (e:es) = enough_args (n-1) es - -- NB: don't take the length of arg_is_evald_s because when - -- called from couldBeSmallEnoughToInline it is infinite! --} - - discounted_size = size - args_discount - result_discount + discounted_size = (size - args_discount) - result_discount args_discount = sum (zipWith arg_discount discount_vec arg_is_evald_s) result_discount | result_is_scruted = scrut_discount diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index 471e2b5..6ace516 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -37,7 +37,7 @@ import Maybes ( catMaybes, maybeToBool ) import PprCore import Outputable ( PprStyle(..), Outputable(..) ) import PprType ( GenType{-instances-}, GenTyVar ) -import Pretty ( vcat, text ) +import Pretty ( Doc, vcat ) import PrimOp ( primOpType, PrimOp(..) ) import SrcLoc ( noSrcLoc ) import TyVar ( cloneTyVar, @@ -57,7 +57,6 @@ import UniqSupply ( initUs, returnUs, thenUs, ) import Usage ( SYN_IE(UVar) ) import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic ) -import Pretty type TypeEnv = TyVarEnv Type applyUsage = panic "CoreUtils.applyUsage:ToDo" diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 87da5f4..29f26b0 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -33,7 +33,7 @@ import Id ( idType, getIdInfo, getIdStrictness, isTupleCon, ) import IdInfo ( ppIdInfo, ppStrictnessInfo ) import Literal ( Literal{-instances-} ) -import Name ( OccName, parenInCode ) +import Name ( OccName ) import Outputable -- quite a few things import PprEnv import PprType ( pprParendGenType, pprTyVarBndr, GenType{-instances-}, GenTyVar{-instance-} ) diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 8a4c46c..281d988 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -17,14 +17,14 @@ module Desugar ( deSugar, pprDsWarnings IMP_Ubiq(){-uitous-} import HsSyn ( HsBinds, HsExpr, MonoBinds, - SYN_IE(RecFlag), nonRecursive + SYN_IE(RecFlag), nonRecursive, recursive ) -import TcHsSyn ( SYN_IE(TypecheckedHsBinds), SYN_IE(TypecheckedHsExpr) +import TcHsSyn ( SYN_IE(TypecheckedMonoBinds), SYN_IE(TypecheckedHsExpr) ) import CoreSyn import Name ( isExported ) import DsMonad -import DsBinds ( dsBinds ) +import DsBinds ( dsMonoBinds ) import DsUtils import Bag ( unionBags ) @@ -45,69 +45,27 @@ start. \begin{code} deSugar :: UniqSupply -- name supply -> Module -- module name - - -> (TypecheckedHsBinds, -- input: recsel, class, instance, and value - TypecheckedHsBinds, -- bindings; see "tcModule" (which produces - TypecheckedHsBinds, -- them) - TypecheckedHsBinds, - TypecheckedHsBinds) --- ToDo: handling of const_inst thingies is certainly WRONG *************************** - + -> TypecheckedMonoBinds -> ([CoreBinding], -- output DsWarnings) -- Shadowing complaints -deSugar us mod_name (recsel_binds, clas_binds, inst_binds, val_binds, const_inst_binds) +deSugar us mod_name all_binds = let - (us0, us0a) = splitUniqSupply us - (us1, us1a) = splitUniqSupply us0a - (us2, us2a) = splitUniqSupply us1a - (us3, us3a) = splitUniqSupply us2a - (us4, us5) = splitUniqSupply us3a + (us1, us2) = splitUniqSupply us module_and_group = (mod_name, grp_name) - grp_name = case opt_SccGroup of Just xx -> _PK_ xx Nothing -> mod_name -- default: module name - (core_const_binds, shadows1) - = initDs us0 nullIdEnv module_and_group (dsBinds False const_inst_binds) - core_const_prs = pairsFromCoreBinds core_const_binds - - (core_clas_binds, shadows2) - = initDs us1 nullIdEnv module_and_group (dsBinds False clas_binds) - core_clas_prs = pairsFromCoreBinds core_clas_binds - - (core_inst_binds, shadows3) - = initDs us2 nullIdEnv module_and_group (dsBinds False inst_binds) - core_inst_prs = pairsFromCoreBinds core_inst_binds + (core_prs, shadows) = initDs us1 nullIdEnv module_and_group + (dsMonoBinds opt_SccProfilingOn recursive all_binds []) - (core_val_binds, shadows4) - = initDs us3 nullIdEnv module_and_group (dsBinds opt_SccProfilingOn val_binds) - core_val_pairs = pairsFromCoreBinds core_val_binds - - (core_recsel_binds, shadows5) - = initDs us4 nullIdEnv module_and_group (dsBinds False recsel_binds) - core_recsel_prs = pairsFromCoreBinds core_recsel_binds - - final_binds - = if (null core_clas_prs && null core_inst_prs - && null core_recsel_prs {-???dont know???-} && null core_const_prs) then - -- we don't have to make the whole thing recursive - core_clas_binds ++ core_val_binds - - else -- gotta make it recursive (sigh) - [Rec (core_clas_prs ++ core_inst_prs - ++ core_const_prs ++ core_val_pairs ++ core_recsel_prs)] - - lift_final_binds = liftCoreBindings us5 final_binds + lift_final_binds = liftCoreBindings us2 [Rec core_prs] really_final_binds = if opt_DoCoreLinting then lintCoreBindings PprDebug "Desugarer" False lift_final_binds else lift_final_binds - - shadows = shadows1 `unionBags` shadows2 `unionBags` - shadows3 `unionBags` shadows4 `unionBags` shadows5 in (really_final_binds, shadows) \end{code} diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index adc4e55..f340fba 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -10,7 +10,7 @@ lower levels it is preserved with @let@/@letrec@s). \begin{code} #include "HsVersions.h" -module DsBinds ( dsBinds ) where +module DsBinds ( dsBinds, dsMonoBinds ) where IMP_Ubiq() #if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201 @@ -68,7 +68,7 @@ dsBinds auto_scc (ThenBinds binds_1 binds_2) = andDs (++) (dsBinds auto_scc binds_1) (dsBinds auto_scc binds_2) dsBinds auto_scc (MonoBind binds sigs is_rec) - = dsMonoBinds auto_scc is_rec binds `thenDs` \ prs -> + = dsMonoBinds auto_scc is_rec binds [] `thenDs` \ prs -> returnDs (if is_rec then [Rec prs] else @@ -86,60 +86,62 @@ dsBinds auto_scc (MonoBind binds sigs is_rec) \begin{code} dsMonoBinds :: Bool -- False => don't (auto-)annotate scc on toplevs. -> RecFlag - -> TypecheckedMonoBinds - -> DsM [(Id,CoreExpr)] + -> TypecheckedMonoBinds + -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) + -> DsM [(Id,CoreExpr)] -- Result -dsMonoBinds _ is_rec EmptyMonoBinds = returnDs [] +dsMonoBinds _ is_rec EmptyMonoBinds rest = returnDs rest -dsMonoBinds auto_scc is_rec (AndMonoBinds binds_1 binds_2) - = andDs (++) (dsMonoBinds auto_scc is_rec binds_1) (dsMonoBinds auto_scc is_rec binds_2) +dsMonoBinds auto_scc is_rec (AndMonoBinds binds_1 binds_2) rest + = dsMonoBinds auto_scc is_rec binds_2 rest `thenDs` \ rest' -> + dsMonoBinds auto_scc is_rec binds_1 rest' -dsMonoBinds _ is_rec (CoreMonoBind var core_expr) - = returnDs [(var, core_expr)] +dsMonoBinds _ is_rec (CoreMonoBind var core_expr) rest + = returnDs ((var, core_expr) : rest) -dsMonoBinds _ is_rec (VarMonoBind var expr) +dsMonoBinds _ is_rec (VarMonoBind var expr) rest = dsExpr expr `thenDs` \ core_expr -> -- Dictionary bindings are always VarMonoBinds, so -- we only need do this here addDictScc var core_expr `thenDs` \ core_expr' -> - returnDs [(var, core_expr')] + returnDs ((var, core_expr') : rest) -dsMonoBinds auto_scc is_rec (FunMonoBind fun _ matches locn) +dsMonoBinds auto_scc is_rec (FunMonoBind fun _ matches locn) rest = putSrcLocDs locn $ matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) -> addAutoScc auto_scc (fun, mkValLam args body) `thenDs` \ pair -> - returnDs [pair] + returnDs (pair : rest) where error_string = "function " ++ showForErr fun -dsMonoBinds _ is_rec (PatMonoBind pat grhss_and_binds locn) +dsMonoBinds _ is_rec (PatMonoBind pat grhss_and_binds locn) rest = putSrcLocDs locn $ dsGuarded grhss_and_binds `thenDs` \ body_expr -> - mkSelectorBinds pat body_expr + mkSelectorBinds pat body_expr `thenDs` \ sel_binds -> + returnDs (sel_binds ++ rest) -- Common special case: no type or dictionary abstraction -dsMonoBinds auto_scc is_rec (AbsBinds [] [] exports binds) - = dsMonoBinds False is_rec binds `thenDs` \ prs -> - mapDs (addAutoScc auto_scc) [(global, Var local) | (_, global, local) <- exports] `thenDs` \ exports' -> - returnDs (prs ++ exports') +dsMonoBinds auto_scc is_rec (AbsBinds [] [] exports binds) rest + = mapDs (addAutoScc auto_scc) [(global, Var local) | (_, global, local) <- exports] `thenDs` \ exports' -> + dsMonoBinds False is_rec binds (exports' ++ rest) -- Another common case: one exported variable -- All non-recursive bindings come through this way -dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds) +dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts [(tyvars, global, local)] binds) rest = ASSERT( all (`elem` tyvars) all_tyvars ) - dsMonoBinds False is_rec binds `thenDs` \ core_prs -> + dsMonoBinds False is_rec binds [] `thenDs` \ core_prs -> let core_binds | is_rec = [Rec core_prs] | otherwise = [NonRec b e | (b,e) <- core_prs] in addAutoScc auto_scc (global, mkLam tyvars dicts $ mkCoLetsAny core_binds (Var local)) `thenDs` \ global' -> - returnDs [global'] + returnDs (global' : rest) -dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts exports binds) - = dsMonoBinds False is_rec binds `thenDs` \ core_prs -> +dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts exports binds) rest + = dsMonoBinds False is_rec binds [] `thenDs` \ core_prs -> let core_binds | is_rec = [Rec core_prs] | otherwise = [NonRec b e | (b,e) <- core_prs] @@ -170,7 +172,7 @@ dsMonoBinds auto_scc is_rec (AbsBinds all_tyvars dicts exports binds) in zipWithDs mk_bind exports [0..] `thenDs` \ export_binds -> -- don't scc (auto-)annotate the tuple itself. - returnDs ((tup_id, tup_expr) : export_binds) + returnDs ((tup_id, tup_expr) : (export_binds ++ rest)) \end{code} diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index c3a8a6d..e39e494 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -234,7 +234,7 @@ data Sig name SrcLoc | ClassOpSig name -- Selector name - name -- Default-method name + (Maybe name) -- Default-method name (if any) (HsType name) SrcLoc diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index b738395..f780f12 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -25,7 +25,7 @@ import HsCore ( UfExpr ) import BasicTypes ( Fixity, NewOrData(..) ) -- others: -import Name --( getOccName, OccName ) +import Name ( getOccName, OccName, NamedThing(..) ) import Outputable ( interppSP, interpp'SP, PprStyle(..), Outputable(..){-instance * []-} ) @@ -378,11 +378,17 @@ instance (NamedThing name, Outputable name) => Outputable (IfaceSig name) where data HsIdInfo name = HsArity ArityInfo - | HsStrictness (StrictnessInfo name) + | HsStrictness (HsStrictnessInfo name) | HsUnfold Bool (UfExpr name) -- True <=> INLINE pragma | HsUpdate UpdateInfo | HsDeforest DeforestInfo | HsArgUsage ArgUsageInfo | HsFBType FBTypeInfo -- ToDo: specialisations + +data HsStrictnessInfo name + = HsStrictnessInfo [Demand] + (Maybe (name, [name])) -- Worker, if any + -- and needed constructors + | HsBottom \end{code} diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 375a1e0..2e24797 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -10,6 +10,7 @@ module HsImpExp where IMP_Ubiq() +import BasicTypes ( IfaceFlavour(..) ) import Outputable import Pretty import SrcLoc ( SrcLoc ) @@ -29,7 +30,7 @@ One per \tr{import} declaration in a module. data ImportDecl name = ImportDecl Module -- module name Bool -- True => qualified - Bool -- True => source imported module + IfaceFlavour -- True => source imported module -- (current interpretation: ignore ufolding info) (Maybe Module) -- as Module (Maybe (Bool, [IE name])) -- (True => hiding, names) @@ -43,8 +44,8 @@ instance (NamedThing name, Outputable name) => Outputable (ImportDecl name) wher pp_qual qual, ptext mod, pp_as as]) 4 (pp_spec spec) where - pp_src False = empty - pp_src True = ptext SLIT("{-# SOURCE #-}") + pp_src HiFile = empty + pp_src HiBootFile = ptext SLIT("{-# SOURCE #-}") pp_qual False = empty pp_qual True = ptext SLIT("qualified") diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index a9581bf..3f949aa 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -24,7 +24,7 @@ module HsSyn ( EXP_MODULE(HsMatches) , EXP_MODULE(HsPat) , EXP_MODULE(HsTypes), - Fixity, NewOrData, + Fixity, NewOrData, IfaceFlavour, collectTopBinders, collectMonoBinders ) where @@ -49,7 +49,7 @@ import HsTypes import HsPragmas ( ClassPragmas, ClassOpPragmas, DataPragmas, GenPragmas, InstancePragmas ) import HsCore -import BasicTypes ( Fixity, SYN_IE(Version), NewOrData ) +import BasicTypes ( Fixity, SYN_IE(Version), NewOrData, IfaceFlavour ) -- others: import FiniteMap ( FiniteMap ) diff --git a/ghc/compiler/main/Main.lhs b/ghc/compiler/main/Main.lhs index 2ed03b4..803a798 100644 --- a/ghc/compiler/main/Main.lhs +++ b/ghc/compiler/main/Main.lhs @@ -149,17 +149,12 @@ doIt (core_cmds, stg_cmds) input_pgm checkErrors tc_errs_bag tc_warns_bag >> case tc_results - of { (typechecked_quint@(recsel_binds, class_binds, inst_binds, val_binds, const_binds), + of { (all_binds, local_tycons, local_classes, inst_info, pragma_tycon_specs, ddump_deriv) -> doDump opt_D_dump_tc "Typechecked:" - (pp_show (vcat [ - ppr pprStyle recsel_binds, - ppr pprStyle class_binds, - ppr pprStyle inst_binds, - ppr pprStyle const_binds, - ppr pprStyle val_binds])) >> + (pp_show (ppr pprStyle all_binds)) >> doDump opt_D_dump_deriv "Derived instances:" (pp_show (ddump_deriv pprStyle)) >> @@ -169,7 +164,7 @@ doIt (core_cmds, stg_cmds) input_pgm _scc_ "DeSugar" let (desugared,ds_warnings) - = deSugar ds_uniqs mod_name typechecked_quint + = deSugar ds_uniqs mod_name all_binds in (if isEmptyBag ds_warnings then return () diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 1e5a984..5ec4732 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -18,9 +18,9 @@ IMPORT_1_3(IO(Handle,hPutStr,openFile,hClose,IOMode(..))) import HsSyn import RdrHsSyn ( RdrName(..) ) import RnHsSyn ( SYN_IE(RenamedHsModule) ) -import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..) ) +import BasicTypes ( Fixity(..), FixityDirection(..), NewOrData(..), IfaceFlavour(..) ) import RnMonad -import RnEnv ( availName ) +import RnEnv ( availName, ifaceFlavour ) import TcInstUtil ( InstInfo(..) ) @@ -29,27 +29,27 @@ import Id ( idType, dataConRawArgTys, dataConFieldLabels, getIdInfo, getInlinePragma, omitIfaceSigForId, dataConStrictMarks, StrictnessMark(..), SYN_IE(IdSet), idSetToList, unionIdSets, unitIdSet, minusIdSet, - isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, + isEmptyIdSet, elementOfIdSet, emptyIdSet, mkIdSet, pprId, GenId{-instance NamedThing/Outputable-}, SYN_IE(Id) ) import IdInfo ( StrictnessInfo, ArityInfo, arityInfo, ppArityInfo, strictnessInfo, ppStrictnessInfo, - getWorkerId_maybe, bottomIsGuaranteed, IdInfo + workerExists, bottomIsGuaranteed, IdInfo ) import CoreSyn ( SYN_IE(CoreExpr), SYN_IE(CoreBinding), GenCoreExpr, GenCoreBinding(..) ) import CoreUnfold ( calcUnfoldingGuidance, UnfoldingGuidance(..), Unfolding ) import FreeVars ( addExprFVs ) +import WorkWrap ( getWorkerIdAndCons ) import Name ( isLocallyDefined, isWiredInName, modAndOcc, nameModule, pprOccName, OccName, occNameString, nameOccName, nameString, isExported, Name {-instance NamedThing-}, Provenance, NamedThing(..) ) import TyCon ( TyCon(..) {-instance NamedThing-} ) -import Class ( GenClass(..){-instance NamedThing-}, SYN_IE(Class), GenClassOp, - classOpLocalType, classSig ) +import Class ( GenClass(..){-instance NamedThing-}, SYN_IE(Class), classBigSig ) import FieldLabel ( FieldLabel{-instance NamedThing-}, fieldLabelName, fieldLabelType ) -import Type ( mkSigmaTy, mkDictTy, getAppTyCon, +import Type ( mkSigmaTy, mkDictTy, getAppTyCon, splitSigmaTy, mkTyVarTy, SYN_IE(Type) ) import TyVar ( GenTyVar {- instance Eq -} ) @@ -139,7 +139,7 @@ ifaceDecls (Just hdl) ifaceTyCons hdl tycons >> ifaceBinds hdl needed_ids final_ids binds >> return () - where + where null_decls = null binds && null tycons && null classes && @@ -151,9 +151,10 @@ ifaceUsages if_hdl import_usages = hPutStr if_hdl "_usages_\n" >> hPutCol if_hdl upp_uses (sortLt lt_imp_vers import_usages) where - upp_uses (m, mv, versions) - = hcat [upp_module m, space, int mv, ptext SLIT(" :: "), - upp_import_versions (sort_versions versions), semi] + upp_uses (m, hif, mv, versions) + = hsep [upp_module m, pp_hif hif, int mv, ptext SLIT("::"), + upp_import_versions (sort_versions versions) + ] <> semi -- For imported versions we do print the version number upp_import_versions nvs @@ -181,10 +182,15 @@ ifaceExports if_hdl avails mod = nameModule (availName avail) -- Print one module's worth of stuff - do_one_module (mod_name, avails) - = hcat [upp_module mod_name, space, - hsep (map upp_avail (sortLt lt_avail avails)), - semi] + do_one_module (mod_name, avails@(avail1:_)) + = hsep [pp_hif (ifaceFlavour (availName avail1)), + upp_module mod_name, + hsep (map upp_avail (sortLt lt_avail avails)) + ] <> semi + +-- The "!" indicates that the exported things came from a hi-boot interface +pp_hif HiFile = empty +pp_hif HiBootFile = char '!' ifaceFixities if_hdl [] = return () ifaceFixities if_hdl fixities @@ -222,7 +228,7 @@ ifaceInstances if_hdl inst_infos pp_inst (InstInfo clas tvs ty theta _ dfun_id _ _ _) = let forall_ty = mkSigmaTy tvs theta (mkDictTy clas ty) - renumbered_ty = renumber_ty forall_ty + renumbered_ty = nmbrGlobalType forall_ty in hcat [ptext SLIT("instance "), ppr_ty renumbered_ty, ptext SLIT(" = "), ppr_unqual_name dfun_id, semi] @@ -259,7 +265,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs idinfo = get_idinfo id inline_pragma = getInlinePragma id - ty_pretty = pprType PprInterface (initNmbr (nmbrType (idType id))) + ty_pretty = pprType PprInterface (nmbrGlobalType (idType id)) sig_pretty = hcat [ppr PprInterface (getOccName id), ptext SLIT(" _:_ "), ty_pretty] prag_pretty @@ -271,8 +277,15 @@ ifaceId get_idinfo needed_ids is_rec id rhs ------------ Strictness -------------- strict_info = strictnessInfo idinfo - maybe_worker = getWorkerId_maybe strict_info - strict_pretty = ppStrictnessInfo PprInterface strict_info + has_worker = workerExists strict_info + strict_pretty = ppStrictnessInfo PprInterface strict_info <+> wrkr_pretty + + wrkr_pretty | not has_worker = empty + | null con_list = pprId PprInterface work_id + | otherwise = pprId PprInterface work_id <+> braces (hsep (map (pprId PprInterface) con_list)) + + (work_id, wrapper_cons) = getWorkerIdAndCons id rhs + con_list = idSetToList wrapper_cons ------------ Unfolding -------------- unfold_pretty | show_unfold = hsep [ptext SLIT("_U_"), pprIfaceUnfolding rhs] @@ -281,7 +294,7 @@ ifaceId get_idinfo needed_ids is_rec id rhs show_unfold = not implicit_unfolding && -- Not unnecessary not dodgy_unfolding -- Not dangerous - implicit_unfolding = maybeToBool maybe_worker || + implicit_unfolding = has_worker || bottomIsGuaranteed strict_info dodgy_unfolding = case guidance of -- True <=> too big to show, or the Inline pragma @@ -301,9 +314,8 @@ ifaceId get_idinfo needed_ids is_rec id rhs | otherwise = worker_ids `unionIdSets` unfold_ids - worker_ids = case maybe_worker of - Just wkr -> unitIdSet wkr - Nothing -> emptyIdSet + worker_ids | has_worker = unitIdSet work_id + | otherwise = emptyIdSet unfold_ids | show_unfold = free_vars | otherwise = emptyIdSet @@ -450,23 +462,28 @@ ifaceClass sty clas = hsep [ptext SLIT("class"), ppr_decl_context sty theta, ppr sty clas, -- Print the name - pprTyVarBndr sty tyvar, + pprTyVarBndr sty clas_tyvar, pp_ops, semi ] where - (tyvar, super_classes, ops) = classSig clas - theta = super_classes `zip` repeat (mkTyVarTy tyvar) + (clas_tyvar, super_classes, _, sel_ids, defms) = classBigSig clas + theta = super_classes `zip` repeat (mkTyVarTy clas_tyvar) - pp_ops | null ops = empty + pp_ops | null sel_ids = empty | otherwise = hsep [ptext SLIT("where"), - braces (hsep (punctuate semi (map ppr_classop ops))) + braces (hsep (punctuate semi (zipWith ppr_classop sel_ids defms))) ] - ppr_classop op = hsep [ppr sty (getOccName op), - ptext SLIT("::"), - ppr sty (classOpLocalType op) - ] + ppr_classop sel_id maybe_defm + = ASSERT( sel_tyvars == [clas_tyvar]) + hsep [ppr sty (getOccName sel_id), + if maybeToBool maybe_defm then equals else empty, + ptext SLIT("::"), + ppr sty op_ty + ] + where + (sel_tyvars, _, op_ty) = splitSigmaTy (idType sel_id) ppr_decl_context :: PprStyle -> [(Class,Type)] -> Doc ppr_decl_context sty [] = empty @@ -496,13 +513,11 @@ upp_avail (AvailTC name []) = empty upp_avail (AvailTC name ns) = hcat [upp_occname (getOccName name), bang, upp_export ns'] where bang | name `elem` ns = empty - | otherwise = char '!' + | otherwise = char '|' ns' = filter (/= name) ns upp_export [] = empty -upp_export names = hcat [char '(', - hsep (map (upp_occname . getOccName) names), - char ')'] +upp_export names = parens (hsep (map (upp_occname . getOccName) names)) upp_fixity (occ, (Fixity prec dir, prov)) = hcat [upp_dir dir, space, int prec, space, @@ -530,8 +545,6 @@ ppr_tyvar tv = ppr PprInterface tv ppr_tyvar_bndr tv = pprTyVarBndr PprInterface tv ppr_decl decl = ppr PprInterface decl <> semi - -renumber_ty ty = initNmbr (nmbrType ty) \end{code} @@ -558,7 +571,7 @@ lt_lexical :: NamedThing a => a -> a -> Bool lt_lexical a1 a2 = getName a1 `lt_name` getName a2 lt_imp_vers :: ImportVersion a -> ImportVersion a -> Bool -lt_imp_vers (m1,_,_) (m2,_,_) = m1 < m2 +lt_imp_vers (m1,_,_,_) (m2,_,_,_) = m1 < m2 sort_versions vs = sortLt lt_vers vs diff --git a/ghc/compiler/nativeGen/MachRegs.lhs b/ghc/compiler/nativeGen/MachRegs.lhs index 13897a8..db21aaa 100644 --- a/ghc/compiler/nativeGen/MachRegs.lhs +++ b/ghc/compiler/nativeGen/MachRegs.lhs @@ -96,7 +96,6 @@ data Imm | LO Imm -- Possible restrictions... | HI Imm ,) - strImmLit s = ImmLit (text s) dblImmLit r = strImmLit ( @@ -296,7 +295,6 @@ data Reg | UnmappedReg Unique PrimRep -- One of an infinite supply of registers, -- always mapped to one of the earlier -- two (?) before we're done. - mkReg :: Unique -> PrimRep -> Reg mkReg = UnmappedReg diff --git a/ghc/compiler/parser/UgenUtil.lhs b/ghc/compiler/parser/UgenUtil.lhs index bb0d68e..11f6c59 100644 --- a/ghc/compiler/parser/UgenUtil.lhs +++ b/ghc/compiler/parser/UgenUtil.lhs @@ -36,6 +36,7 @@ import Name #endif import RdrHsSyn ( RdrName(..) ) +import BasicTypes ( IfaceFlavour ) import SrcLoc ( mkSrcLoc, noSrcLoc, SrcLoc ) \end{code} -- 1.7.10.4