Haskell. [WDP 94/11])
\begin{code}
-#include "HsVersions.h"
-
module IdInfo (
IdInfo, -- Abstract
noDemandInfo, mkDemandInfo, demandInfo, ppDemandInfo, addDemandInfo, willBeDemanded,
StrictnessInfo(..), -- Non-abstract
- Demand(..), -- Non-abstract
- wwLazy, wwStrict, wwUnpack, wwPrim, wwEnum,
+ Demand(..), NewOrData, -- Non-abstract
- getWorkerId_maybe,
workerExists,
mkStrictnessInfo, mkBottomStrictnessInfo, noStrictnessInfo, bottomIsGuaranteed,
strictnessInfo, ppStrictnessInfo, addStrictnessInfo,
unfoldInfo, addUnfoldInfo,
- specInfo, addSpecInfo,
+ IdSpecEnv, specInfo, addSpecInfo,
- UpdateInfo, SYN_IE(UpdateSpec),
+ UpdateInfo, UpdateSpec,
mkUpdateInfo, updateInfo, updateInfoMaybe, ppUpdateInfo, addUpdateInfo,
- DeforestInfo(..),
- deforestInfo, ppDeforestInfo, addDeforestInfo,
-
- ArgUsageInfo, ArgUsage(..), SYN_IE(ArgUsageType),
+ ArgUsageInfo, ArgUsage(..), ArgUsageType,
mkArgUsageInfo, argUsageInfo, addArgUsageInfo, getArgUsage,
FBTypeInfo, FBType(..), FBConsum(..), FBProd(..),
fbTypeInfo, ppFBTypeInfo, addFBTypeInfo, mkFBTypeInfo, getFBType
) where
-IMP_Ubiq()
-IMPORT_1_3(Char(toLower))
+#include "HsVersions.h"
+
-IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
- -- we break those loops by using IdLoop and
- -- *not* importing much of anything else,
- -- except from the very general "utils".
+import {-# SOURCE #-} CoreUnfold ( Unfolding, noUnfolding )
+import {-# SOURCE #-} CoreSyn ( SimplifiableCoreExpr )
-import Type ( eqSimpleTy, splitFunTyExpandingDicts )
-import CmdLineOpts ( opt_OmitInterfacePragmas )
+import SpecEnv ( SpecEnv, emptySpecEnv, isEmptySpecEnv )
+import BasicTypes ( NewOrData )
import Demand
import Maybes ( firstJust )
-import Outputable ( ifPprInterface, Outputable(..){-instances-} )
-import PprStyle ( PprStyle(..) )
-import Pretty
+import Outputable
import Unique ( pprUnique )
-import Util ( mapAccumL, panic, assertPanic, pprPanic )
+import Util ( mapAccumL )
-#ifdef REALLY_HASKELL_1_3
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
+ IdSpecEnv -- 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
- DeforestInfo -- Whether its definition should be
- -- unfolded during deforestation
-
ArgUsageInfo -- how this Id uses its arguments
FBTypeInfo -- the Foldr/Build W/W property of this function.
\end{code}
\begin{code}
-noIdInfo = IdInfo UnknownArity UnknownDemand nullSpecEnv NoStrictnessInfo noUnfolding
- NoUpdateInfo Don'tDeforest NoArgUsageInfo NoFBTypeInfo
+noIdInfo = IdInfo UnknownArity UnknownDemand emptySpecEnv NoStrictnessInfo noUnfolding
+ NoUpdateInfo NoArgUsageInfo NoFBTypeInfo
\end{code}
Simply turgid. But BE CAREFUL: don't @apply_to_Id@ if that @Id@
nasty loop, friends...)
\begin{code}
apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
- update deforest arg_usage fb_ww)
- | isNullSpecEnv spec
+ update arg_usage fb_ww)
+ | isEmptySpecEnv spec
= 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.
\begin{code}
applySubstToIdInfo s0 (IdInfo arity demand spec strictness unfold
- update deforest arg_usage fb_ww)
+ update 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}
-ppIdInfo :: PprStyle
- -> Bool -- True <=> print specialisations, please
+ppIdInfo :: Bool -- True <=> print specialisations, please
-> IdInfo
- -> Doc
+ -> SDoc
-ppIdInfo sty specs_please
- (IdInfo arity demand specenv strictness unfold update deforest arg_usage fbtype)
+ppIdInfo specs_please
+ (IdInfo arity demand specenv strictness unfold update arg_usage fbtype)
= hsep [
-- order is important!:
- ppArityInfo sty arity,
- ppUpdateInfo sty update,
- ppDeforestInfo sty deforest,
+ ppArityInfo arity,
+ ppUpdateInfo update,
- ppStrictnessInfo sty strictness,
+ ppStrictnessInfo strictness,
if specs_please
then empty -- ToDo -- sty (not (isDataCon for_this_id))
else empty,
-- DemandInfo needn't be printed since it has no effect on interfaces
- ppDemandInfo sty demand,
- ppFBTypeInfo sty fbtype
+ ppDemandInfo demand,
+ ppFBTypeInfo fbtype
]
\end{code}
atLeastArity = ArityAtLeast
unknownArity = UnknownArity
-arityInfo (IdInfo arity _ _ _ _ _ _ _ _) = arity
+arityInfo (IdInfo arity _ _ _ _ _ _ _) = arity
-addArityInfo (IdInfo _ a c d e f g h i) arity = IdInfo arity a c d e f g h i
+addArityInfo (IdInfo _ a b c d e f g) arity = IdInfo arity a b c d e f g
-ppArityInfo sty UnknownArity = empty
-ppArityInfo sty (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity]
-ppArityInfo sty (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity]
+ppArityInfo UnknownArity = empty
+ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("_A_"), int arity]
+ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("_A>_"), int arity]
\end{code}
%************************************************************************
\end{code}
\begin{code}
-demandInfo (IdInfo _ demand _ _ _ _ _ _ _) = demand
+demandInfo (IdInfo _ demand _ _ _ _ _ _) = demand
-addDemandInfo (IdInfo a _ c d e f g h i) demand = IdInfo a demand c d e f g h i
+addDemandInfo (IdInfo a _ c d e f g h) demand = IdInfo a demand c d e f g h
-ppDemandInfo PprInterface _ = empty
-ppDemandInfo sty UnknownDemand = text "{-# L #-}"
-ppDemandInfo sty (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
+ppDemandInfo UnknownDemand = text "{-# L #-}"
+ppDemandInfo (DemandedAsPer info) = hsep [text "{-#", text (showList [info] ""), text "#-}"]
\end{code}
%************************************************************************
%* *
%************************************************************************
-See SpecEnv.lhs
+A @IdSpecEnv@ holds details of an @Id@'s specialisations.
+
+\begin{code}
+type IdSpecEnv = SpecEnv SimplifiableCoreExpr
+\end{code}
+
+For example, if \tr{f}'s @SpecEnv@ contains the mapping:
+\begin{verbatim}
+ [List a, b] ===> (\d -> f' a b)
+\end{verbatim}
+then when we find an application of f to matching types, we simply replace
+it by the matching RHS:
+\begin{verbatim}
+ f (List Int) Bool ===> (\d -> f' Int Bool)
+\end{verbatim}
+All the stuff about how many dictionaries to discard, and what types
+to apply the specialised function to, are handled by the fact that the
+SpecEnv contains a template for the result of the specialisation.
+
+There is one more exciting case, which is dealt with in exactly the same
+way. If the specialised value is unboxed then it is lifted at its
+definition site and unlifted at its uses. For example:
+
+ pi :: forall a. Num a => a
+
+might have a specialisation
+
+ [Int#] ===> (case pi' of Lift pi# -> pi#)
+
+where pi' :: Lift Int# is the specialised version of pi.
+
\begin{code}
-specInfo (IdInfo _ _ spec _ _ _ _ _ _) = spec
+specInfo :: IdInfo -> IdSpecEnv
+specInfo (IdInfo _ _ spec _ _ _ _ _) = spec
-addSpecInfo id_info spec | isNullSpecEnv spec = id_info
-addSpecInfo (IdInfo a b _ d e f g h i) spec = IdInfo a b spec d e f g h i
+addSpecInfo id_info spec | isEmptySpecEnv spec = id_info
+addSpecInfo (IdInfo a b _ d e f g h) spec = IdInfo a b spec d e f g h
\end{code}
+
%************************************************************************
%* *
\subsection[strictness-IdInfo]{Strictness info about an @Id@}
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) -- Worker's Id, if applicable.
- -- (It may not be applicable 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 -> 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)
bottomIsGuaranteed BottomGuaranteed = True
bottomIsGuaranteed other = False
-strictnessInfo (IdInfo _ _ _ strict _ _ _ _ _) = strict
+strictnessInfo (IdInfo _ _ _ strict _ _ _ _) = strict
addStrictnessInfo id_info NoStrictnessInfo = id_info
-addStrictnessInfo (IdInfo a b d _ e f g h i) strict = IdInfo a b d strict e f g h i
+addStrictnessInfo (IdInfo a b d _ e f g h) strict = IdInfo a b d strict e f g h
-ppStrictnessInfo sty NoStrictnessInfo = empty
-ppStrictnessInfo sty BottomGuaranteed = ptext SLIT("_bot_")
+ppStrictnessInfo NoStrictnessInfo = empty
+ppStrictnessInfo 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 -> ppr sty wrkr
+ppStrictnessInfo (StrictnessInfo wrapper_args wrkr_maybe)
+ = 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 _ maybe_worker_id) = maybe_worker_id
-getWorkerId_maybe other = Nothing
+workerExists :: StrictnessInfo -> Bool
+workerExists (StrictnessInfo _ worker_exists) = worker_exists
+workerExists other = False
\end{code}
%************************************************************************
\begin{code}
-unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _ _) = unfolding
+unfoldInfo (IdInfo _ _ _ _ unfolding _ _ _) = unfolding
-addUnfoldInfo (IdInfo a b d e _ f g h i) uf = IdInfo a b d e uf f g h i
+addUnfoldInfo (IdInfo a b d e _ f g h) uf = IdInfo a b d e uf f g h
\end{code}
%************************************************************************
ok_digit c | c >= '0' && c <= '2' = ord c - ord '0'
| otherwise = panic "IdInfo: not a digit while reading update pragma"
-updateInfo (IdInfo _ _ _ _ _ update _ _ _) = update
+updateInfo (IdInfo _ _ _ _ _ update _ _) = update
addUpdateInfo id_info NoUpdateInfo = id_info
-addUpdateInfo (IdInfo a b d e f _ g h i) upd_info = IdInfo a b d e f upd_info g h i
-
-ppUpdateInfo sty NoUpdateInfo = empty
-ppUpdateInfo sty (SomeUpdateInfo []) = empty
-ppUpdateInfo sty (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec))
-\end{code}
-
-%************************************************************************
-%* *
-\subsection[deforest-IdInfo]{Deforestation info about an @Id@}
-%* *
-%************************************************************************
-
-The deforest info says whether this Id is to be unfolded during
-deforestation. Therefore, when the deforest pragma is true, we must
-also have the unfolding information available for this Id.
-
-\begin{code}
-data DeforestInfo
- = Don'tDeforest -- just a bool, might extend this
- | DoDeforest -- later.
- -- deriving (Eq, Ord)
-\end{code}
-
-\begin{code}
-deforestInfo (IdInfo _ _ _ _ _ _ deforest _ _) = deforest
-
-addDeforestInfo id_info Don'tDeforest = id_info
-addDeforestInfo (IdInfo a b d e f g _ h i) deforest = IdInfo a b d e f g deforest h i
+addUpdateInfo (IdInfo a b d e f _ g h) upd_info = IdInfo a b d e f upd_info g h
-ppDeforestInfo sty Don'tDeforest = empty
-ppDeforestInfo sty DoDeforest = ptext SLIT("_DEFOREST_")
+ppUpdateInfo NoUpdateInfo = empty
+ppUpdateInfo (SomeUpdateInfo []) = empty
+ppUpdateInfo (SomeUpdateInfo spec) = (<>) (ptext SLIT("_U_ ")) (hcat (map int spec))
\end{code}
%************************************************************************
\end{code}
\begin{code}
-argUsageInfo (IdInfo _ _ _ _ _ _ _ au _) = au
+argUsageInfo (IdInfo _ _ _ _ _ _ au _) = au
addArgUsageInfo id_info NoArgUsageInfo = id_info
-addArgUsageInfo (IdInfo a b d e f g h _ i) au_info = IdInfo a b d e f g h au_info i
+addArgUsageInfo (IdInfo a b d e f g _ h) au_info = IdInfo a b d e f g au_info h
-ppArgUsageInfo sty NoArgUsageInfo = empty
-ppArgUsageInfo sty (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut)
+ppArgUsageInfo NoArgUsageInfo = empty
+ppArgUsageInfo (SomeArgUsageInfo aut) = (<>) (ptext SLIT("_L_ ")) (ppArgUsageType aut)
ppArgUsage (ArgUsage n) = int n
ppArgUsage (UnknownArgUsage) = char '-'
\end{code}
\begin{code}
-fbTypeInfo (IdInfo _ _ _ _ _ _ _ _ fb) = fb
+fbTypeInfo (IdInfo _ _ _ _ _ _ _ fb) = fb
addFBTypeInfo id_info NoFBTypeInfo = id_info
-addFBTypeInfo (IdInfo a b d e f g h i _) fb_info = IdInfo a b d e f g h i fb_info
+addFBTypeInfo (IdInfo a b d e f g h _) fb_info = IdInfo a b d e f g h fb_info
-ppFBTypeInfo sty NoFBTypeInfo = empty
-ppFBTypeInfo sty (SomeFBTypeInfo (FBType cons prod))
+ppFBTypeInfo NoFBTypeInfo = empty
+ppFBTypeInfo (SomeFBTypeInfo (FBType cons prod))
= (<>) (ptext SLIT("_F_ ")) (ppFBType cons prod)
ppFBType cons prod = hcat
projects / ghc-hetmet.git / blobdiff