Permalink
Browse files

[project @ 1996-07-15 16:16:46 by partain]

simonpj changes through 960715
  • Loading branch information...
1 parent 573ef10 commit 12899612693163154531da3285ec99c1c8ca2226 partain committed Jul 15, 1996
Showing with 1,500 additions and 2,215 deletions.
  1. +20 −50 ghc/compiler/basicTypes/Id.lhs
  2. +25 −41 ghc/compiler/basicTypes/IdInfo.lhs
  3. +24 −10 ghc/compiler/basicTypes/IdLoop.lhi
  4. +3 −1 ghc/compiler/basicTypes/IdLoop_1_3.lhi
  5. +3 −2 ghc/compiler/basicTypes/IdUtils.lhs
  6. +1 −1 ghc/compiler/codeGen/CgMonad.lhs
  7. +41 −20 ghc/compiler/coreSyn/CoreSyn.lhs
  8. +169 −114 ghc/compiler/coreSyn/CoreUnfold.lhs
  9. +15 −112 ghc/compiler/coreSyn/CoreUtils.lhs
  10. +2 −1 ghc/compiler/coreSyn/PprCore.lhs
  11. +22 −21 ghc/compiler/deSugar/DsExpr.lhs
  12. +3 −3 ghc/compiler/deforest/DefExpr.lhs
  13. +1 −0 ghc/compiler/hsSyn/HsPragmas.lhs
  14. +32 −12 ghc/compiler/main/CmdLineOpts.lhs
  15. +1 −0 ghc/compiler/main/Main.lhs
  16. +13 −0 ghc/compiler/prelude/PrelInfo.lhs
  17. +2 −2 ghc/compiler/prelude/PrelLoop.lhi
  18. +1 −1 ghc/compiler/rename/RnNames.lhs
  19. +35 −19 ghc/compiler/simplCore/BinderInfo.lhs
  20. +3 −5 ghc/compiler/simplCore/ConFold.lhs
  21. +2 −1 ghc/compiler/simplCore/LiberateCase.lhs
  22. +179 −160 ghc/compiler/simplCore/MagicUFs.lhs
  23. +33 −5 ghc/compiler/simplCore/OccurAnal.lhs
  24. +5 −4 ghc/compiler/simplCore/SetLevels.lhs
  25. +37 −46 ghc/compiler/simplCore/SimplCase.lhs
  26. +9 −32 ghc/compiler/simplCore/SimplCore.lhs
  27. +350 −601 ghc/compiler/simplCore/SimplEnv.lhs
  28. +8 −0 ghc/compiler/simplCore/SimplMonad.lhs
  29. +3 −5 ghc/compiler/simplCore/SimplPgm.lhs
  30. +6 −3 ghc/compiler/simplCore/SimplUtils.lhs
  31. +80 −272 ghc/compiler/simplCore/SimplVar.lhs
  32. +260 −387 ghc/compiler/simplCore/Simplify.lhs
  33. +19 −211 ghc/compiler/specialise/SpecEnv.lhs
  34. +12 −11 ghc/compiler/specialise/Specialise.lhs
  35. +3 −3 ghc/compiler/stranal/SaAbsInt.lhs
  36. +17 −13 ghc/compiler/stranal/StrictAnal.lhs
  37. +3 −3 ghc/compiler/stranal/WorkWrap.lhs
  38. +2 −1 ghc/compiler/typecheck/GenSpecEtc.lhs
  39. +2 −2 ghc/compiler/typecheck/Inst.lhs
  40. +1 −0 ghc/compiler/typecheck/TcBinds.lhs
  41. +4 −2 ghc/compiler/typecheck/TcClassDcl.lhs
  42. +1 −0 ghc/compiler/typecheck/TcDefaults.lhs
  43. +1 −0 ghc/compiler/typecheck/TcDeriv.lhs
  44. +5 −4 ghc/compiler/typecheck/TcExpr.lhs
  45. +2 −1 ghc/compiler/typecheck/TcInstDcls.lhs
  46. +3 −3 ghc/compiler/typecheck/TcMatches.lhs
  47. +1 −0 ghc/compiler/typecheck/TcModule.lhs
  48. +2 −1 ghc/compiler/typecheck/TcPat.lhs
  49. +2 −2 ghc/compiler/typecheck/TcPragmas.lhs
  50. +2 −1 ghc/compiler/typecheck/TcSimplify.lhs
  51. +1 −0 ghc/compiler/typecheck/TcTyClsDecls.lhs
  52. +24 −19 ghc/compiler/types/Type.lhs
  53. +2 −2 ghc/compiler/utils/Ubiq.lhi
  54. +1 −1 ghc/compiler/utils/Ubiq_1_3.lhi
  55. +2 −4 ghc/compiler/utils/UniqFM.lhs
@@ -90,6 +90,10 @@ module Id (
pprId,
showId,
+ -- Specialialisation
+ getIdSpecialisation,
+ addIdSpecialisation,
+
-- UNFOLDING, ARITY, UPDATE, AND STRICTNESS STUFF (etc)
addIdArity,
addIdDemandInfo,
@@ -126,6 +130,7 @@ module Id (
mkIdEnv,
mkIdSet,
modifyIdEnv,
+ modifyIdEnv_Directly,
nullIdEnv,
rngIdEnv,
unionIdSets,
@@ -160,6 +165,8 @@ import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
)
import PprStyle
import Pretty
+import SpecEnv ( SpecEnv(..) )
+import MatchEnv ( MatchEnv )
import SrcLoc ( mkBuiltinSrcLoc )
import TyCon ( TyCon, mkTupleTyCon, tyConDataCons )
import Type ( mkSigmaTy, mkTyVarTys, mkFunTys, mkDictTy,
@@ -778,46 +785,7 @@ unfoldingUnfriendlyId -- return True iff it is definitely a bad
-> Bool -- mentions this Id. Reason: it cannot
-- possibly be seen in another module.
-unfoldingUnfriendlyId id = True -- ToDo:panic "Id.unfoldingUnfriendlyId"
-{-LATER:
-
-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 _ _ _ (MethodSelId _ _) _ _) = 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)
- = naughty_DictFunId dfun
-
-unfoldingUnfriendlyId d@(Id _ _ _ dfun@(DictFunId _ 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 _ _ _) = panic "False" -- came from outside; must be OK
-naughty_DictFunId (DictFunId _ ty _)
- = not (isGroundTy ty)
--}
+unfoldingUnfriendlyId id = not (externallyVisibleId id)
\end{code}
@externallyVisibleId@: is it true that another module might be
@@ -1482,9 +1450,8 @@ Notice the ``big lambdas'' and type arguments to @Con@---we are producing
%************************************************************************
@getIdUnfolding@ takes a @Id@ (we are discussing the @DataCon@ case)
-and generates an @UnfoldingDetails@ for its unfolding. The @Ids@ and
-@TyVars@ don't really have to be new, because we are only producing a
-template.
+and generates an @Unfolding@. The @Ids@ and @TyVars@ don't really
+have to be new, because we are only producing a template.
ToDo: what if @DataConId@'s type has a context (haven't thought about it
--WDP)?
@@ -1497,16 +1464,16 @@ dictionaries, in the even of an overloaded data-constructor---none at
present.)
\begin{code}
-getIdUnfolding :: Id -> UnfoldingDetails
+getIdUnfolding :: Id -> Unfolding
getIdUnfolding (Id _ _ _ _ _ info) = getInfo_UF info
{-LATER:
-addIdUnfolding :: Id -> UnfoldingDetails -> Id
+addIdUnfolding :: Id -> Unfolding -> Id
addIdUnfolding id@(Id u n ty info details) unfold_details
= ASSERT(
case (isLocallyDefined id, unfold_details) of
- (_, NoUnfoldingDetails) -> True
+ (_, NoUnfolding) -> True
(True, IWantToBeINLINEd _) -> True
(False, IWantToBeINLINEd _) -> False -- v bad
(False, _) -> True
@@ -1574,14 +1541,12 @@ addIdFBTypeInfo (Id u n ty info details) upd_info
\end{code}
\begin{code}
-{- LATER:
getIdSpecialisation :: Id -> SpecEnv
getIdSpecialisation (Id _ _ _ _ _ info) = getInfo info
addIdSpecialisation :: Id -> SpecEnv -> Id
addIdSpecialisation (Id u n ty details prags info) spec_info
= Id u n ty details prags (info `addInfo` spec_info)
--}
\end{code}
Strictness: we snaffle the info out of the IdInfo.
@@ -1712,7 +1677,7 @@ delManyFromIdEnv :: IdEnv a -> [GenId ty] -> IdEnv a
delOneFromIdEnv :: IdEnv a -> GenId ty -> IdEnv a
combineIdEnvs :: (a -> a -> a) -> IdEnv a -> IdEnv a -> IdEnv a
mapIdEnv :: (a -> b) -> IdEnv a -> IdEnv b
-modifyIdEnv :: IdEnv a -> (a -> a) -> GenId ty -> IdEnv a
+modifyIdEnv :: (a -> a) -> IdEnv a -> GenId ty -> IdEnv a
rngIdEnv :: IdEnv a -> [a]
isNullIdEnv :: IdEnv a -> Bool
@@ -1740,10 +1705,15 @@ lookupNoFailIdEnv env id = case (lookupIdEnv env id) of { Just xx -> xx }
-- modifyIdEnv: Look up a thing in the IdEnv, then mash it with the
-- modify function, and put it back.
-modifyIdEnv env mangle_fn key
+modifyIdEnv mangle_fn env key
= case (lookupIdEnv env key) of
Nothing -> env
Just xx -> addOneToIdEnv env key (mangle_fn xx)
+
+modifyIdEnv_Directly mangle_fn env key
+ = case (lookupUFM_Directly env key) of
+ Nothing -> env
+ Just xx -> addToUFM_Directly env key (mangle_fn xx)
\end{code}
\begin{code}
@@ -77,7 +77,6 @@ IMPORT_DELOOPER(IdLoop) -- IdInfo is a dependency-loop ranch, and
import CmdLineOpts ( opt_OmitInterfacePragmas )
import Maybes ( firstJust )
-import MatchEnv ( nullMEnv, isEmptyMEnv, mEnvToList, MatchEnv )
import Outputable ( ifPprInterface, Outputable(..){-instances-} )
import PprStyle ( PprStyle(..) )
import Pretty
@@ -117,16 +116,13 @@ data IdInfo
DemandInfo -- Whether or not it is definitely
-- demanded
- (MatchEnv [Type] CoreExpr)
- -- Specialisations of this function which exist
- -- This corresponds to a SpecEnv which we do
- -- not import directly to avoid loop
+ SpecEnv -- Specialisations of this function which exist
StrictnessInfo -- Strictness properties, notably
-- how to conjure up "worker" functions
- UnfoldingDetails -- Its unfolding; for locally-defined
- -- things, this can *only* be NoUnfoldingDetails
+ Unfolding -- Its unfolding; for locally-defined
+ -- things, this can *only* be NoUnfolding
UpdateInfo -- Which args should be updated
@@ -162,7 +158,7 @@ boringIdInfo (IdInfo UnknownArity
_ {- no f/b w/w -}
_ {- src_loc: no effect on interfaces-}
)
- | null (mEnvToList specenv)
+ | isNullSpecEnv specenv
&& boring_strictness strictness
&& boring_unfolding unfolding
= True
@@ -171,8 +167,8 @@ boringIdInfo (IdInfo UnknownArity
boring_strictness BottomGuaranteed = False
boring_strictness (StrictnessInfo wrap_args _) = all_present_WwLazies wrap_args
- boring_unfolding NoUnfoldingDetails = True
- boring_unfolding _ = False
+ boring_unfolding NoUnfolding = True
+ boring_unfolding _ = False
boringIdInfo _ = False
@@ -185,7 +181,7 @@ nasty loop, friends...)
\begin{code}
apply_to_IdInfo ty_fn idinfo@(IdInfo arity demand spec strictness unfold
update deforest arg_usage fb_ww srcloc)
- | isEmptyMEnv spec
+ | isNullSpecEnv spec
= idinfo
| otherwise
= panic "IdInfo:apply_to_IdInfo"
@@ -253,7 +249,7 @@ ppIdInfo :: PprStyle
-> Id -- The Id for which we're printing this IdInfo
-> Bool -- True <=> print specialisations, please
-> (Id -> Id) -- to look up "better Ids" w/ better IdInfos;
- -> IdEnv UnfoldingDetails
+ -> IdEnv Unfolding
-- inlining info for top-level fns in this module
-> IdInfo -- see MkIface notes
-> Pretty
@@ -279,8 +275,8 @@ ppIdInfo sty for_this_id specs_please better_id_fn inline_env
else pp_unfolding sty for_this_id inline_env unfold,
if specs_please
- then ppSpecs sty (not (isDataCon for_this_id))
- better_id_fn inline_env (mEnvToList specenv)
+ then panic "ppSpecs (ToDo)" -- sty (not (isDataCon for_this_id))
+ -- better_id_fn inline_env (mEnvToList specenv)
else pp_NONE,
-- DemandInfo needn't be printed since it has no effect on interfaces
@@ -414,19 +410,16 @@ instance OptIdInfo DemandInfo where
See SpecEnv.lhs
\begin{code}
-instance OptIdInfo (MatchEnv [Type] CoreExpr) where
- noInfo = nullMEnv
+instance OptIdInfo SpecEnv where
+ noInfo = nullSpecEnv
getInfo (IdInfo _ _ spec _ _ _ _ _ _ _) = spec
- addInfo id_info spec | null (mEnvToList spec) = id_info
+ addInfo id_info spec | isNullSpecEnv spec = id_info
addInfo (IdInfo a b _ d e f g h i j) spec = IdInfo a b spec d e f g h i j
- ppInfo sty better_id_fn spec
- = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
-
-ppSpecs sty print_spec_id_info better_id_fn inline_env spec_env
- = if null spec_env then ppNil else panic "IdInfo:ppSpecs"
+ ppInfo sty better_id_fn spec = panic "IdInfo:ppSpecs"
+-- = ppSpecs sty True better_id_fn nullIdEnv (mEnvToList spec)
\end{code}
%************************************************************************
@@ -737,25 +730,18 @@ pp_strictness sty for_this_id_maybe better_id_fn inline_env
\begin{code}
mkUnfolding guide expr
- = GenForm (mkFormSummary NoStrictnessInfo expr)
- (occurAnalyseGlobalExpr expr)
- guide
+ = CoreUnfolding (SimpleUnfolding (mkFormSummary expr)
+ guide
+ (occurAnalyseGlobalExpr expr))
\end{code}
\begin{code}
-noInfo_UF = NoUnfoldingDetails
-
-getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _)
- = case unfolding of
- GenForm _ _ BadUnfolding -> NoUnfoldingDetails
- unfolding_as_was -> unfolding_as_was
+noInfo_UF = NoUnfolding
--- getInfo_UF ensures that any BadUnfoldings are never returned
--- We had to delay the test required in TcPragmas until now due
--- to strictness constraints in TcPragmas
+getInfo_UF (IdInfo _ _ _ _ unfolding _ _ _ _ _) = unfolding
-addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfoldingDetails = id_info
-addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
+addInfo_UF id_info@(IdInfo a b c d e f g h i j) NoUnfolding = id_info
+addInfo_UF (IdInfo a b d e _ f g h i j) uf = IdInfo a b d e uf f g h i j
\end{code}
\begin{code}
@@ -764,14 +750,12 @@ pp_unfolding sty for_this_id inline_env uf_details
Nothing -> pp uf_details
Just dt -> pp dt
where
- pp NoUnfoldingDetails = pp_NONE
+ pp NoUnfolding = pp_NONE
- pp (MagicForm tag _)
+ pp (MagicUnfolding tag _)
= ppCat [ppPStr SLIT("_MF_"), pprUnique tag]
- pp (GenForm _ _ BadUnfolding) = pp_NONE
-
- pp (GenForm _ template guide)
+ pp (CoreUnfolding (SimpleUnfolding _ guide template))
= let
untagged = unTagBinders template
in
@@ -8,14 +8,17 @@ import PreludeStdIO ( Maybe )
import BinderInfo ( BinderInfo )
import CoreSyn ( CoreExpr(..), GenCoreExpr, GenCoreArg )
-import CoreUnfold ( FormSummary(..), UnfoldingDetails(..), UnfoldingGuidance(..) )
+import CoreUnfold ( Unfolding(..), UnfoldingGuidance(..),
+ SimpleUnfolding(..), FormSummary(..) )
import CoreUtils ( unTagBinders )
import Id ( externallyVisibleId, isDataCon, isWorkerId, isWrapperId,
unfoldingUnfriendlyId, getIdInfo, nmbrId,
nullIdEnv, lookupIdEnv, IdEnv(..),
Id(..), GenId
)
+import CostCentre ( CostCentre )
import IdInfo ( IdInfo )
+import SpecEnv ( SpecEnv, nullSpecEnv, isNullSpecEnv )
import Literal ( Literal )
import MagicUFs ( mkMagicUnfoldingFun, MagicUnfoldingFun )
import OccurAnal ( occurAnalyseGlobalExpr )
@@ -32,6 +35,9 @@ import Usage ( GenUsage )
import Util ( Ord3(..) )
import WwLib ( mAX_WORKER_ARGS )
+nullSpecEnv :: SpecEnv
+isNullSpecEnv :: SpecEnv -> Bool
+
occurAnalyseGlobalExpr :: GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique -> GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique
externallyVisibleId :: Id -> Bool
isDataCon :: GenId ty -> Bool
@@ -62,20 +68,28 @@ instance Outputable (GenTyVar a)
instance (Outputable a) => Outputable (GenId a)
instance (Eq a, Outputable a, Eq b, Outputable b) => Outputable (GenType a b)
+data SpecEnv
data NmbrEnv
data MagicUnfoldingFun
-data FormSummary = WhnfForm | BottomForm | OtherForm
-data UnfoldingDetails
- = NoUnfoldingDetails
- | OtherLitForm [Literal]
- | OtherConForm [GenId (GenType (GenTyVar (GenUsage Unique)) Unique)]
- | GenForm FormSummary (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique) UnfoldingGuidance
- | MagicForm Unique MagicUnfoldingFun
+data FormSummary = VarForm | ValueForm | BottomForm | OtherForm
+
+data Unfolding
+ = NoUnfolding
+ | CoreUnfolding SimpleUnfolding
+ | MagicUnfolding Unique MagicUnfoldingFun
+
+
+data SimpleUnfolding = SimpleUnfolding FormSummary UnfoldingGuidance (GenCoreExpr (GenId (GenType (GenTyVar (GenUsage Unique)) Unique), BinderInfo) (GenId (GenType (GenTyVar (GenUsage Unique)) Unique)) (GenTyVar (GenUsage Unique)) Unique)
+
data UnfoldingGuidance
= UnfoldNever
| UnfoldAlways
- | EssentialUnfolding
| UnfoldIfGoodArgs Int Int [Bool] Int
- | BadUnfolding
+
+data CostCentre
\end{code}
+
+
+
+
@@ -3,7 +3,7 @@ interface IdLoop_1_3 1
__exports__
CoreSyn CoreExpr
CoreUnfold FormSummary (..)
-CoreUnfold UnfoldingDetails (..)
+CoreUnfold Unfolding (..)
CoreUnfold UnfoldingGuidance (..)
CoreUtils unTagBinders (..)
Id IdEnv
@@ -19,5 +19,7 @@ MagicUFs MagicUnfoldingFun
MagicUFs mkMagicUnfoldingFun (..)
OccurAnal occurAnalyseGlobalExpr (..)
PprType pprParendGenType (..)
+SpecEnv isNullSpecEnv (..)
+SpecEnv nullSpecEnv (..)
WwLib mAX_WORKER_ARGS (..)
\end{code}
Oops, something went wrong. Retry.

0 comments on commit 1289961

Please sign in to comment.