-pprIdInUnfolding :: IdSet -> Id -> Pretty
-
-pprIdInUnfolding in_scopes v
- = let
- v_ty = getIdUniType v
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- pprUnique (getTheUnique v)
-
- -- ubiquitous Ids with special syntax:
- else if v == nilDataCon then
- ppPStr SLIT("_NIL_")
- else if isTupleCon v then
- ppBeside (ppPStr SLIT("_TUP_")) (ppInt (getDataConArity v))
-
- -- ones to think about:
- else
- let
- (Id _ _ _ v_details) = v
- in
- case v_details of
- -- these ones must have been exported by their original module
- ImportedId _ -> pp_full_name
- PreludeId _ -> pp_full_name
-
- -- these ones' exportedness checked later...
- TopLevId _ -> pp_full_name
- DataConId _ _ _ _ _ _ -> pp_full_name
-
- -- class-ish things: class already recorded as "mentioned"
- SuperDictSelId c sc
- -> ppCat [ppPStr SLIT("_SDSEL_"), pp_class c, pp_class sc]
- ClassOpId c o
- -> ppCat [ppPStr SLIT("_METH_"), pp_class c, pp_class_op o]
- DefaultMethodId c o _
- -> ppCat [ppPStr SLIT("_DEFM_"), pp_class c, pp_class_op o]
-
- -- instance-ish things: should we try to figure out
- -- *exactly* which extra instances have to be exported? (ToDo)
- DictFunId c t _ _
- -> ppCat [ppPStr SLIT("_DFUN_"), pp_class c, pp_type t]
- ConstMethodId c t o _ _
- -> ppCat [ppPStr SLIT("_CONSTM_"), pp_class c, pp_class_op o, pp_type t]
-
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- pp = pprIdInUnfolding in_scopes unspec
- in
- ppCat [ppPStr SLIT("_SPEC_"), pp, ppLbrack,
- ppIntersperse pp'SP{-'-} (map pp_ty_maybe ty_maybes),
- ppRbrack]
-
- WorkerId unwrkr
- -> let
- pp = pprIdInUnfolding in_scopes unwrkr
- in
- ppBeside (ppPStr SLIT("_WRKR_ ")) pp
-
- -- anything else? we're nae interested
- other_id -> panic "pprIdInUnfolding:mystery Id"
- where
- ppr_Unfolding = PprUnfolding (panic "Id:ppr_Unfolding")
-
- pp_full_name
- = let
- (m_str, n_str) = getOrigName v
-
- pp_n =
- if isAvarop n_str || isAconop n_str then
- ppBesides [ppLparen, ppPStr n_str, ppRparen]
- else
- ppPStr n_str
- in
- if fromPreludeCore v then
- pp_n
- else
- ppCat [ppPStr SLIT("_ORIG_"), ppPStr m_str, pp_n]
-
- pp_class :: Class -> Pretty
- pp_class_op :: ClassOp -> Pretty
- pp_type :: UniType -> Pretty
- pp_ty_maybe :: Maybe UniType -> Pretty
-
- pp_class clas = ppr ppr_Unfolding clas
- pp_class_op op = ppr ppr_Unfolding op
-
- pp_type t = ppBesides [ppLparen, ppr ppr_Unfolding t, ppRparen]
-
- pp_ty_maybe Nothing = ppPStr SLIT("_N_")
- pp_ty_maybe (Just t) = pp_type t
-\end{code}
-
-@whatsMentionedInId@ ferrets out the types/classes/instances on which
-this @Id@ depends. If this Id is to appear in an interface, then
-those entities had Jolly Well be in scope. Someone else up the
-call-tree decides that.
-
-\begin{code}
-whatsMentionedInId
- :: IdSet -- Ids known to be in scope
- -> Id -- Id being processed
- -> (Bag Id, Bag TyCon, Bag Class) -- mentioned Ids/TyCons/etc.
-
-whatsMentionedInId in_scopes v
- = let
- v_ty = getIdUniType v
-
- (tycons, clss)
- = getMentionedTyConsAndClassesFromUniType v_ty
-
- result0 id_bag = (id_bag, tycons, clss)
-
- result1 ids tcs cs
- = (ids `unionBags` unitBag v, -- we add v to "mentioned"...
- tcs `unionBags` tycons,
- cs `unionBags` clss)
- in
- -- local vars first:
- if v `elementOfUniqSet` in_scopes then
- result0 emptyBag -- v not added to "mentioned"
-
- -- ones to think about:
- else
- let
- (Id _ _ _ v_details) = v
- in
- case v_details of
- -- specialisations and workers
- SpecId unspec ty_maybes _
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unspec
- in
- result1 ids2 tcs2 cs2
-
- WorkerId unwrkr
- -> let
- (ids2, tcs2, cs2) = whatsMentionedInId in_scopes unwrkr
- in
- result1 ids2 tcs2 cs2
-
- anything_else -> result0 (unitBag v) -- v is added to "mentioned"
-\end{code}
-
-Tell them who my wrapper function is.
-\begin{code}
-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
- -> Bool -- mentions this Id. Reason: it cannot
- -- possibly be seen in another module.
-
-unfoldingUnfriendlyId id
- | not (externallyVisibleId id) -- that settles that...
- = True
-
-unfoldingUnfriendlyId (Id _ _ _ (WorkerId wrapper))
- = class_thing wrapper
- where
- -- "class thing": If we're going to use this worker Id in
- -- an interface, we *have* to be able to untangle the wrapper's
- -- strictness when reading it back in. At the moment, this
- -- is not always possible: in precisely those cases where
- -- we pass tcGenPragmas a "Nothing" for its "ty_maybe".
-
- class_thing (Id _ _ _ (SuperDictSelId _ _)) = True
- class_thing (Id _ _ _ (ClassOpId _ _)) = True
- class_thing (Id _ _ _ (DefaultMethodId _ _ _)) = True
- class_thing other = False
-
-unfoldingUnfriendlyId (Id _ _ _ (SpecId d@(Id _ _ _ dfun@(DictFunId _ t _ _)) _ _))
- -- a SPEC of a DictFunId can end up w/ gratuitous
- -- TyVar(Templates) in the i/face; only a problem
- -- if -fshow-pragma-name-errs; but we can do without the pain.
- -- A HACK in any case (WDP 94/05/02)
- = --pprTrace "unfriendly1:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun
- --)
-
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ t _ _))
- = --pprTrace "unfriendly2:" (ppCat [ppr PprDebug d, ppr PprDebug t]) (
- naughty_DictFunId dfun -- similar deal...
- --)
-
-unfoldingUnfriendlyId other_id = False -- is friendly in all other cases
-
-naughty_DictFunId :: IdDetails -> Bool
- -- True <=> has a TyVar(Template) in the "type" part of its "name"
-
-naughty_DictFunId (DictFunId _ _ False _) = False -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _ _)
- = not (isGroundTy ty)
-\end{code}
-
-@externallyVisibleId@: is it true that another module might be
-able to ``see'' this Id?
-
-We need the @toplevelishId@ check as well as @isExported@ for when we
-compile instance declarations in the prelude. @DictFunIds@ are
-``exported'' if either their class or tycon is exported, but, in
-compiling the prelude, the compiler may not recognise that as true.
-
-\begin{code}
-externallyVisibleId :: Id -> Bool
-
-externallyVisibleId id@(Id _ _ _ details)
- = if isLocallyDefined id then
- toplevelishId id && isExported id && not (weird_datacon details)
- else
- not (weird_tuplecon details)
- -- if visible here, it must be visible elsewhere, too.
- where
- -- If it's a DataCon, it's not enough to know it (meaning
- -- its TyCon) is exported; we need to know that it might
- -- be visible outside. Consider:
- --
- -- data Foo a = Mumble | BigFoo a WeirdLocalType
- --
- -- We can't tell the outside world *anything* about Foo, because
- -- of WeirdLocalType; but we need to know this when asked if
- -- "Mumble" is externally visible...
-
- weird_datacon (DataConId _ _ _ _ _ tycon)
- = maybeToBool (maybePurelyLocalTyCon tycon)
- weird_datacon not_a_datacon_therefore_not_weird = False
-
- weird_tuplecon (TupleConId arity)
- = arity > 32 -- sigh || isBigTupleTyCon tycon -- generated *purely* for local use
- weird_tuplecon _ = False
-\end{code}
-
-\begin{code}
-idWantsToBeINLINEd :: Id -> Bool
-
-idWantsToBeINLINEd id
- = case (getIdUnfolding id) of
- IWantToBeINLINEd _ -> True
- _ -> False
-\end{code}
-
-For @unlocaliseId@: See the brief commentary in
-\tr{simplStg/SimplStg.lhs}.
-
-\begin{code}
-unlocaliseId :: FAST_STRING{-modulename-} -> Id -> Maybe Id
-
-unlocaliseId mod (Id u ty info (TopLevId fn))
- = Just (Id u ty info (TopLevId (unlocaliseFullName fn)))
-
-unlocaliseId mod (Id u ty info (LocalId sn no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod u sn
- in
- Just (Id u ty info (TopLevId full_name))
-
-unlocaliseId mod (Id u ty info (SysLocalId sn no_ftvs))
- = --false?: on PreludeGlaST: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod u sn
- in
- Just (Id u ty info (TopLevId full_name))
-
-unlocaliseId mod (Id u ty info (SpecId unspec ty_maybes no_ftvs))
- = case unlocalise_parent mod u unspec of
- Nothing -> Nothing
- Just xx -> Just (Id u ty info (SpecId xx ty_maybes no_ftvs))
-
-unlocaliseId mod (Id u ty info (WorkerId unwrkr))
- = case unlocalise_parent mod u unwrkr of
- Nothing -> Nothing
- Just xx -> Just (Id u ty info (WorkerId xx))
-
-unlocaliseId mod (Id u ty info (InstId inst))
- = Just (Id u ty info (TopLevId full_name))
- -- type might be wrong, but it hardly matters
- -- at this stage (just before printing C) ToDo
- where
- name = let (bit1:bits) = getInstNamePieces True inst in
- _CONCAT_ (bit1 : [ _CONS_ '.' b | b <- bits ])
-
- full_name = mkFullName mod (mod _APPEND_ name) InventedInThisModule ExportAll mkGeneratedSrcLoc
-
-#ifdef DPH
-unlocaliseId mod (PodId dim ity id)
- = case (unlocaliseId mod id) of
- Just id' -> Just (PodId dim ity id')
- Nothing -> Nothing
-#endif {- Data Parallel Haskell -}
-
-unlocaliseId mod other_id = Nothing
-
---------------------
--- we have to be Very Careful for workers/specs of
--- local functions!
-
-unlocalise_parent mod uniq (Id _ ty info (LocalId sn no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod uniq sn
- in
- Just (Id uniq ty info (TopLevId full_name))
-
-unlocalise_parent mod uniq (Id _ ty info (SysLocalId sn no_ftvs))
- = --false?: ASSERT(no_ftvs)
- let
- full_name = unlocaliseShortName mod uniq sn
- in
- Just (Id uniq ty info (TopLevId full_name))
-
-unlocalise_parent mod uniq other_id = unlocaliseId mod other_id
- -- we're OK otherwise
-\end{code}
-
-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}
-applyTypeEnvToId :: TypeEnv -> Id -> Id
-
-applyTypeEnvToId type_env id@(Id u ty info details)
- | idHasNoFreeTyVars id
- = id
- | otherwise
- = apply_to_Id ( \ ty ->
- applyTypeEnvToTy type_env ty
- ) id
-\end{code}
-
-\begin{code}
-apply_to_Id :: (UniType -> UniType)
- -> Id
- -> Id
-
-apply_to_Id ty_fn (Id u ty info details)
- = Id u (ty_fn ty) (apply_to_IdInfo ty_fn info) (apply_to_details details)
- where
- apply_to_details (InstId inst)
- = let
- new_inst = apply_to_Inst ty_fn inst
- in
- InstId new_inst
-
- apply_to_details (SpecId unspec ty_maybes no_ftvs)
- = let
- new_unspec = apply_to_Id ty_fn unspec
- new_maybes = map apply_to_maybe ty_maybes
- in
- SpecId new_unspec new_maybes no_ftvs
- -- ToDo: recalc no_ftvs????
- where
- 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
-
-#ifdef DPH
- apply_to_details (PodId d ity id )
- = PodId d ity (apply_to_Id ty_fn id)
-#endif {- Data Parallel Haskell -}
-
- 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}
-applySubstToId :: Subst -> Id -> (Subst, Id)
-
-applySubstToId subst id@(Id u 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 new_ty new_info new_details) }}}
- where
- apply_to_details subst _ (InstId inst)
- = case (applySubstToInst subst inst) of { (s2, new_inst) ->
- (s2, InstId new_inst) }
-
- 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)
-
-#ifdef DPH
-applySubstToId (PodId d ity id )
- = ???? ToDo:DPH; not sure what! returnLft (PodId d ity (applySubstToId id))
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-getIdNamePieces :: Bool {-show Uniques-} -> Id -> [FAST_STRING]
-
-getIdNamePieces show_uniqs (Id u ty info details)
- = case details of
- DataConId n _ _ _ _ _ ->
- case (getOrigName n) of { (mod, name) ->
- if fromPrelude mod then [name] else [mod, name] }
-
- TupleConId a -> [SLIT("Tup") _APPEND_ (_PK_ (show a))]
-
- ImportedId n -> get_fullname_pieces n
- PreludeId n -> get_fullname_pieces n
- TopLevId n -> get_fullname_pieces n
-
- SuperDictSelId c sc ->
- case (getOrigName c) of { (c_mod, c_name) ->
- case (getOrigName sc) of { (sc_mod, sc_name) ->
- let
- c_bits = if fromPreludeCore c
- then [c_name]
- else [c_mod, c_name]
-
- sc_bits= if fromPreludeCore sc
- then [sc_name]
- else [sc_mod, sc_name]
- in
- [SLIT("sdsel")] ++ c_bits ++ sc_bits }}
-
- ClassOpId clas op ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
- if fromPreludeCore clas then [op_name] else [c_mod, c_name, op_name]
- } }
-
- DefaultMethodId clas op _ ->
- case (getOrigName clas) of { (c_mod, c_name) ->
- case (getClassOpString op) of { op_name ->
- if fromPreludeCore clas
- then [SLIT("defm"), op_name]
- else [SLIT("defm"), c_mod, c_name, op_name] }}
-
- DictFunId c ty _ _ ->
- case (getOrigName c) of { (c_mod, c_name) ->
- let
- c_bits = if fromPreludeCore c
- then [c_name]
- else [c_mod, c_name]
-
- ty_bits = getTypeString ty
- in
- [SLIT("dfun")] ++ c_bits ++ ty_bits }
-
-
- ConstMethodId c ty o _ _ ->
- case (getOrigName c) of { (c_mod, c_name) ->
- case (getTypeString ty) of { ty_bits ->
- case (getClassOpString o) of { o_name ->
- case (if fromPreludeCore c
- then []
- else [c_mod, c_name]) of { c_bits ->
- [SLIT("const")] ++ c_bits ++ ty_bits ++ [o_name] }}}}
-
- -- if the unspecialised equiv is "top-level",
- -- the name must be concocted from its name and the
- -- names of the types to which specialised...
-
- SpecId unspec ty_maybes _ ->
- getIdNamePieces show_uniqs unspec ++ (
- if not (toplevelishId unspec)
- then [showUnique u]
- else concat (map typeMaybeString ty_maybes)
- )
-
- WorkerId unwrkr ->
- getIdNamePieces show_uniqs unwrkr ++ (
- if not (toplevelishId unwrkr)
- then [showUnique u]
- else [SLIT("wrk")] -- show u
- )
-
- InstId inst -> getInstNamePieces show_uniqs inst
- LocalId n _ -> let local = getLocalName n in
- if show_uniqs then [local, showUnique u] else [local]
- SysLocalId n _ -> [getLocalName n, showUnique u]
- SpecPragmaId n _ _ -> [getLocalName n, showUnique u]
-
-#ifdef DPH
- ProcessorCon a _ -> ["MkProcessor" ++ (show a)]
- PodId n ity id -> getIdNamePieces show_uniqs id ++
- ["mapped", "POD" ++ (show n), show ity]
-#endif {- Data Parallel Haskell -}
-
-get_fullname_pieces :: FullName -> [FAST_STRING]
-get_fullname_pieces n
- = BIND (getOrigName n) _TO_ (mod, name) ->
- if fromPrelude mod
- then [name]
- else [mod, name]
- BEND
-\end{code}
-
-Really Inst-ish, but only used in this module...
-\begin{code}
-getInstNamePieces :: Bool -> Inst -> [FAST_STRING]
-
-getInstNamePieces show_uniqs (Dict u clas ty _)
- = let (mod, nm) = getOrigName clas in
- if fromPreludeCore clas
- then [SLIT("d"), nm, showUnique u]
- else [SLIT("d"), mod, nm, showUnique u]
-
-getInstNamePieces show_uniqs (Method u id tys _)
- = let local = getIdNamePieces show_uniqs id in
- if show_uniqs then local ++ [showUnique u] else local
-
-getInstNamePieces show_uniqs (LitInst u _ _ _) = [SLIT("lit"), showUnique u]
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Id-type-funs]{Type-related @Id@ functions}
-%* *
-%************************************************************************
-
-\begin{code}
-getIdUniType :: Id -> UniType
-
-getIdUniType (Id _ ty _ _) = ty
-
-#ifdef DPH
--- ToDo: DPH
-getIdUniType (ProcessorCon _ ty) = ty
-getIdUniType (PodId d ity id)
- = let (foralls,rho) = splitForalls (getIdUniType id) in
- let tys = get_args rho in
- let itys_mask = infoTypeNumToMask ity in
- let tys' = zipWith convert tys itys_mask in
- mkForallTy foralls (foldr1 mkFunTy tys')
- where -- ToDo(hilly) change to use getSourceType etc...
-
- get_args ty = case (maybeUnpackFunTy ty) of
- Nothing -> [ty]
- Just (arg,res) -> arg:get_args res
-
- convert ty cond = if cond
- then ty
- else (coerce ty)
-
- coerce ty = case (maybeUnpackFunTy ty) of
- Nothing ->mkPodizedPodNTy d ty
- Just (arg,res) ->mkFunTy (coerce arg) (coerce res)
-#endif {- Data Parallel Haskell -}
-\end{code}
-
-\begin{code}
-getMentionedTyConsAndClassesFromId :: Id -> (Bag TyCon, Bag Class)
-
-getMentionedTyConsAndClassesFromId id
- = getMentionedTyConsAndClassesFromUniType (getIdUniType id)
-\end{code}
-
-\begin{code}
-getIdKind i = kindFromType (getIdUniType i)
-\end{code}
-
-\begin{code}
-getInstIdModule (Id _ _ _ (DictFunId _ _ _ mod)) = mod
-getInstIdModule (Id _ _ _ (ConstMethodId _ _ _ _ mod)) = mod
-getInstIdModule other = panic "Id:getInstIdModule"
-\end{code}
-
-
-\begin{code}
-{- NOT USED
-getIdTauType :: Id -> TauType
-getIdTauType i = expandTySyn (getTauType (getIdUniType i))
-
-getIdSourceTypes :: Id -> [TauType]
-getIdSourceTypes i = map expandTySyn (sourceTypes (getTauType (getIdUniType i)))
-
-getIdTargetType :: Id -> TauType
-getIdTargetType i = expandTySyn (targetType (getTauType (getIdUniType i)))
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[Id-overloading]{Functions related to overloading}
-%* *
-%************************************************************************
-
-\begin{code}
-mkSuperDictSelId u c sc ty info = Id u ty info (SuperDictSelId c sc)
-mkClassOpId u c op ty info = Id u ty info (ClassOpId c op)
-mkDefaultMethodId u c op gen ty info = Id u ty info (DefaultMethodId c op gen)
-
-mkDictFunId u c ity full_ty from_here modname info
- = Id u full_ty info (DictFunId c ity from_here modname)
-
-mkConstMethodId u c op ity full_ty from_here modname info
- = Id u full_ty info (ConstMethodId c ity op from_here modname)
-
-mkWorkerId u unwrkr ty info = Id u ty info (WorkerId unwrkr)
-
-mkInstId inst
- = Id u (getInstUniType inst) noIdInfo (InstId inst)
- where
- u = case inst of
- Dict u c t o -> u
- Method u i ts o -> u
- LitInst u l ty o -> u
-
-{- UNUSED:
-getSuperDictSelIdSig (Id _ _ _ (SuperDictSelId input_class result_class))
- = (input_class, result_class)
--}
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[local-funs]{@LocalId@-related functions}
-%* *
-%************************************************************************
-
-\begin{code}
-mkImported u n ty info = Id u ty info (ImportedId n)
-mkPreludeId u n ty info = Id u ty info (PreludeId n)
-
-#ifdef DPH
-mkPodId d i = PodId d i
-#endif
-
-updateIdType :: Id -> UniType -> Id
-updateIdType (Id u _ info details) ty = Id u ty info details
-\end{code}
-
-\begin{code}
-no_free_tvs ty = null (extractTyVarsFromTy ty)