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-},
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
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)
SYN_IE(Version), SYN_IE(Arity),
SYN_IE(Module), moduleString, pprModule,
Fixity(..), FixityDirection(..),
- NewOrData(..)
+ NewOrData(..), IfaceFlavour(..)
) where
IMP_Ubiq()
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}
+
%************************************************************************
%* *
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
_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 ;;
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,
idWantsToBeINLINEd, getInlinePragma,
idMustBeINLINEd, idMustNotBeINLINEd,
isBottomingId,
- isConstMethodId,
- isConstMethodId_maybe,
isDataCon, isAlgCon, isNewCon,
isDefaultMethodId,
isDefaultMethodId_maybe,
isPrimitiveId_maybe,
isSysLocalId,
isTupleCon,
- isWorkerId,
isWrapperId,
toplevelishId,
unfoldingUnfriendlyId,
apply_to_Id,
-- PRINTING and RENUMBERING
- addId,
- nmbrDataCon,
- nmbrId,
pprId,
showId,
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,
isLocallyDefinedName, occNameString, modAndOcc,
isLocallyDefined, changeUnique, isWiredInName,
nameString, getOccString, setNameVisibility,
- isExported, ExportFlag(..), DefnInfo, Provenance,
+ isExported, ExportFlag(..), Provenance,
OccName(..), Name, SYN_IE(Module),
NamedThing(..)
)
#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
| 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
| DefaultMethodId -- Default method for a particular class op
Class -- same class, <blah-blah> 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 <op>"'.
-- see below
| DictFunId Class -- A DictFun is uniquely identified
-- 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
-- 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
\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.
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
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
(TupleConId _) -> True
(RecordSelId _) -> True
(SuperDictSelId _ _) -> True
- (MethodSelId _ _) -> True
+ (MethodSelId _) -> True
other -> False -- Don't omit!
-- NB DefaultMethodIds are not omitted
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
`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
\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
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}
%************************************************************************
%* *
%************************************************************************
\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}
-- 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}
%************************************************************************
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}
= 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
length con_theta + length arg_tys }
isNullaryDataCon con = dataConNumFields con == 0 -- function of convenience
+
\end{code}
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
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}
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}
StrictnessInfo(..), -- Non-abstract
Demand(..), NewOrData, -- Non-abstract
- getWorkerId_maybe,
workerExists,
mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed,
strictnessInfo, ppStrictnessInfo, addStrictnessInfo,
import {-# SOURCE #-} StdIdInfo
#endif
-import Type ( eqSimpleTy, splitFunTyExpandingDicts )
import BasicTypes ( NewOrData )
import CmdLineOpts ( opt_OmitInterfacePragmas )
ord = fromEnum :: Char -> Int
#endif
-applySubstToTy = panic "IdInfo.applySubstToTy"
showTypeCategory = panic "IdInfo.showTypeCategory"
\end{code}
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
= 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.
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}
it exists); i.e. its calling convention.
\begin{code}
-data StrictnessInfo bdee
+data StrictnessInfo
= NoStrictnessInfo
| BottomGuaranteed -- This Id guarantees never to return;
-- 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)
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}
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,
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import OccurAnal ( occurAnalyseGlobalExpr )
import Outputable ( Outputable(..), PprStyle )
-import PprEnv ( NmbrEnv )
import PprType ( pprParendGenType )
import PragmaInfo ( PragmaInfo )
import Pretty ( Doc )
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
data DemandInfo
data SpecEnv
-data NmbrEnv
data MagicUnfoldingFun
data FormSummary = VarForm | ValueForm | BottomForm | OtherForm
OccName(..),
pprOccName, occNameString, occNameFlavour,
isTvOcc, isTCOcc, isVarOcc, prefixOccName,
- quoteInText, parenInCode,
+ uniqToOccName,
-- The Name type
Name, -- Abstract
minusNameSet, elemNameSet, nameSetToList, addOneToNameSet, addListToNameSet, isEmptyNameSet,
-- Misc
- DefnInfo(..),
Provenance(..), pprProvenance,
ExportFlag(..),
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__ )
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}
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 }
\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}
| 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
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
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
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
-> 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
-- 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}
%************************************************************************
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
\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}
\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}
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
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}
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...]
#else
import GlaExts
import ST
-#if __GLASGOW_HASKELL__ == 202
-import PrelBase ( Char(..) )
-#endif
+import PrelBase ( Char(..), chr, ord )
#endif
IMP_Ubiq(){-uitous-}
= 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}
%************************************************************************
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
= 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
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
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
import CgRetConv ( assignRegs, dataReturnConvAlg,
DataReturnConvention(..)
)
-import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
+import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
mkPhantomInfoTableLabel, mkInfoTableLabel,
mkConInfoTableLabel, mkStaticClosureLabel,
mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
-- 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):
-- 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
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
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-} )
infixr 9 `thenL`
-updateIdType = panic "CoreLift.updateIdType"
\end{code}
%************************************************************************
(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
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)
IMPORT_DELOOPER(SmplLoop)
#else
import {-# SOURCE #-} MagicUFs
-import {-# SOURCE #-} Id ( Id )
#endif
import Bag ( emptyBag, unitBag, unionBags, Bag )
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 )
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#
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
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,
)
import Usage ( SYN_IE(UVar) )
import Util ( zipEqual, panic, pprTrace, pprPanic, assertPanic )
-import Pretty
type TypeEnv = TyVarEnv Type
applyUsage = panic "CoreUtils.applyUsage:ToDo"
)
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-} )
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 )
\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}
\begin{code}
#include "HsVersions.h"
-module DsBinds ( dsBinds ) where
+module DsBinds ( dsBinds, dsMonoBinds ) where
IMP_Ubiq()
#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
= 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
\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]
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}
SrcLoc
| ClassOpSig name -- Selector name
- name -- Default-method name
+ (Maybe name) -- Default-method name (if any)
(HsType name)
SrcLoc
import BasicTypes ( Fixity, NewOrData(..) )
-- others:
-import Name --( getOccName, OccName )
+import Name ( getOccName, OccName, NamedThing(..) )
import Outputable ( interppSP, interpp'SP,
PprStyle(..), Outputable(..){-instance * []-}
)
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}
IMP_Ubiq()
+import BasicTypes ( IfaceFlavour(..) )
import Outputable
import Pretty
import SrcLoc ( SrcLoc )
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)
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")
EXP_MODULE(HsMatches) ,
EXP_MODULE(HsPat) ,
EXP_MODULE(HsTypes),
- Fixity, NewOrData,
+ Fixity, NewOrData, IfaceFlavour,
collectTopBinders, collectMonoBinders
) where
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 )
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)) >>
_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 ()
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(..) )
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 -} )
ifaceTyCons hdl tycons >>
ifaceBinds hdl needed_ids final_ids binds >>
return ()
- where
+ where
null_decls = null binds &&
null tycons &&
null classes &&
= 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
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
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]
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
------------ 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]
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
| 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
= 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
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,
ppr_tyvar_bndr tv = pprTyVarBndr PprInterface tv
ppr_decl decl = ppr PprInterface decl <> semi
-
-renumber_ty ty = initNmbr (nmbrType ty)
\end{code}
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
| LO Imm -- Possible restrictions...
| HI Imm
,)
-
strImmLit s = ImmLit (text s)
dblImmLit r
= strImmLit (
| 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
#endif
import RdrHsSyn ( RdrName(..) )
+import BasicTypes ( IfaceFlavour )
import SrcLoc ( mkSrcLoc, noSrcLoc, SrcLoc )
\end{code}
projects / ghc-hetmet.git / commitdiff