Commit f922d703 authored by simonmar's avatar simonmar

[project @ 1999-05-21 12:52:28 by simonmar]

A bunch of patches from SLPJ to fix various things.
parent 9325140f
......@@ -32,7 +32,6 @@ import Demand ( wwLazy )
import Name ( getOccName, tidyTopName, mkLocalName, isLocallyDefined )
import OccName ( initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTypes, tidyTyVar, tidyTyVars )
import Class ( Class, classSelIds )
import Module ( Module )
import UniqSupply ( UniqSupply )
import Unique ( Uniquable(..) )
......
......@@ -109,7 +109,11 @@ applyTypeToArgs e op_ty (other_arg : args)
\begin{code}
data FormSummary
= VarForm -- Expression is a variable (or scc var, etc)
| ValueForm -- Expression is a value: i.e. a value-lambda,constructor, or literal
-- May 1999: I'm experimenting with allowing "cheap" non-values
-- here.
| BottomForm -- Expression is guaranteed to be bottom. We're more gung
-- ho about inlining such things, because it can't waste work
| OtherForm -- Anything else
......@@ -137,10 +141,16 @@ mkFormSummary expr
go n (Note _ e) = go n e
go n (Let (NonRec b r) e) | exprIsTrivial r = go n e -- let f = f' alpha in (f,g)
-- should be treated as a value
go n (Let (NonRec b r) e) | exprIsCheap r = go n e -- let f = f' alpha in (f,g)
-- should be treated as a value
go n (Let _ e) = OtherForm
go n (Case _ _ _) = OtherForm
-- We want selectors to look like values
-- e.g. case x of { (a,b) -> a }
-- should give a ValueForm, so that it will be inlined
-- vigorously
go n expr@(Case _ _ _) | exprIsCheap expr = ValueForm
| otherwise = OtherForm
go 0 (Lam x e) | isId x = ValueForm -- NB: \x.bottom /= bottom!
| otherwise = go 0 e
......
......@@ -259,7 +259,7 @@ ppr_expr pe (Note (Coerce to_ty from_ty) expr)
ppr_parend_expr pe expr]
#else
ppr_expr pe (Note (Coerce to_ty from_ty) expr)
= sep [sep [ptext SLIT("__coerce"), nest 4 pTy pe to_ty],
= sep [sep [ptext SLIT("__coerce"), nest 4 (pTy pe to_ty)],
ppr_parend_expr pe expr]
#endif
......
......@@ -458,6 +458,13 @@ tidy1 v (LazyPat pat) match_result
-- re-express <con-something> as (ConPat ...) [directly]
tidy1 v (RecPat data_con pat_ty tvs dicts rpats) match_result
| null rpats
= -- Special case for C {}, which can be used for
-- a constructor that isn't declared to have
-- fields at all
returnDs (ConPat data_con pat_ty tvs dicts (map WildPat con_arg_tys'), match_result)
| otherwise
= returnDs (ConPat data_con pat_ty tvs dicts pats, match_result)
where
pats = map mk_pat tagged_arg_tys
......
......@@ -576,8 +576,10 @@ isAmongSimpl on_switches -- Switches mentioned later occur *earlier*
case (indexArray# stuff (tagOf_SimplSwitch switch)) of
#if __GLASGOW_HASKELL__ < 400
Lift v -> v
#else
#elif __GLASGOW_HASKELL__ < 403
(# _, v #) -> v
#else
(# v #) -> v
#endif
}
where
......
......@@ -213,26 +213,59 @@ isOrphanDecl other = False
-------------------------------------------------------
slurpImpDecls source_fvs
= traceRn (text "slurpImp" <+> fsep (map ppr (nameSetToList source_fvs))) `thenRn_`
-- The current slurped-set records all local things
getSlurped `thenRn` \ local_binders ->
slurpSourceRefs source_fvs `thenRn` \ (decls1, needed1, wired_in) ->
let
inst_gates1 = foldr (plusFV . getWiredInGates) source_fvs wired_in
inst_gates2 = foldr (plusFV . getGates source_fvs) inst_gates1 decls1
in
-- Do this first slurpDecls before the getImportedInstDecls,
-- so that the home modules of all the inst_gates will be sure to be loaded
slurpDecls decls1 needed1 `thenRn` \ (decls2, needed2) ->
mapRn_ (load_home local_binders) wired_in `thenRn_`
-- The current slurped-set records all local things
getSlurped `thenRn` \ source_binders ->
slurpSourceRefs source_binders source_fvs `thenRn` \ (decls1, needed1, inst_gates) ->
-- Now we can get the instance decls
getImportedInstDecls inst_gates2 `thenRn` \ inst_decls ->
rnIfaceDecls decls2 needed2 inst_decls `thenRn` \ (decls3, needed3) ->
closeDecls decls3 needed3
slurpInstDecls decls1 needed1 inst_gates `thenRn` \ (decls2, needed2) ->
-- And finally get everything else
closeDecls decls2 needed2
where
-------------------------------------------------------
slurpSourceRefs :: NameSet -- Variables defined in source
-> FreeVars -- Variables referenced in source
-> RnMG ([RenamedHsDecl],
FreeVars, -- Un-satisfied needs
FreeVars) -- "Gates"
-- The declaration (and hence home module) of each gate has
-- already been loaded
slurpSourceRefs source_binders source_fvs
= go [] -- Accumulating decls
emptyFVs -- Unsatisfied needs
source_fvs -- Accumulating gates
(nameSetToList source_fvs) -- Gates whose defn hasn't been loaded yet
where
load_home local_binders name
| name `elemNameSet` local_binders = returnRn ()
go decls fvs gates []
= returnRn (decls, fvs, gates)
go decls fvs gates (wanted_name:refs)
| isWiredInName wanted_name
= load_home wanted_name `thenRn_`
go decls fvs (gates `plusFV` getWiredInGates wanted_name) refs
| otherwise
= importDecl wanted_name `thenRn` \ maybe_decl ->
case maybe_decl of
-- No declaration... (already slurped, or local)
Nothing -> go decls fvs gates refs
Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
let
new_gates = getGates source_fvs new_decl
in
go (new_decl : decls)
(fvs1 `plusFV` fvs)
(gates `plusFV` new_gates)
(nameSetToList new_gates ++ refs)
-- When we find a wired-in name we must load its
-- home module so that we find any instance decls therein
load_home name
| name `elemNameSet` source_binders = returnRn ()
-- When compiling the prelude, a wired-in thing may
-- be defined in this module, in which case we don't
-- want to load its home module!
......@@ -246,42 +279,30 @@ slurpImpDecls source_fvs
doc = ptext SLIT("need home module for wired in thing") <+> ppr name
-------------------------------------------------------
slurpSourceRefs :: FreeVars -- Variables referenced in source
-> RnMG ([RenamedHsDecl],
FreeVars, -- Un-satisfied needs
[Name]) -- Those variables referenced in the source
-- that turned out to be wired in things
-- slurpInstDecls imports appropriate instance decls.
-- It has to incorporate a loop, because consider
-- instance Foo a => Baz (Maybe a) where ...
-- It may be that Baz and Maybe are used in the source module,
-- but not Foo; so we need to chase Foo too.
slurpInstDecls decls needed gates
| isEmptyFVs gates
= returnRn (decls, needed)
slurpSourceRefs source_fvs
= go [] emptyFVs [] (nameSetToList source_fvs)
| otherwise
= getImportedInstDecls gates `thenRn` \ inst_decls ->
rnInstDecls decls needed emptyFVs inst_decls `thenRn` \ (decls1, needed1, gates1) ->
slurpInstDecls decls1 needed1 gates1
where
go decls fvs wired []
= returnRn (decls, fvs, wired)
go decls fvs wired (wanted_name:refs)
| isWiredInName wanted_name
= go decls fvs (wanted_name:wired) refs
| otherwise
= importDecl wanted_name `thenRn` \ maybe_decl ->
case maybe_decl of
-- No declaration... (already slurped, or local)
Nothing -> go decls fvs wired refs
Just decl -> rnIfaceDecl decl `thenRn` \ (new_decl, fvs1) ->
go (new_decl : decls) (fvs1 `plusFV` fvs) wired
(extraGates new_decl ++ refs)
-- Hack alert. If we suck in a class
-- class Ord a => Baz a where ...
-- then Eq is also a 'gate'. Why? Because Eq is a superclass of Ord,
-- and hence may be needed during context reduction even though
-- Eq is never mentioned explicitly. So we snaffle out the super-classes
-- right now, so that slurpSourceRefs will heave them in
--
-- Similarly the RHS of type synonyms
extraGates (TyClD (ClassDecl ctxt _ tvs _ _ _ _ _ _ _))
= nameSetToList (delListFromNameSet (extractHsCtxtTyNames ctxt) (map getTyVarName tvs))
extraGates (TyClD (TySynonym _ tvs ty _))
= nameSetToList (delListFromNameSet (extractHsTyNames ty) (map getTyVarName tvs))
extraGates other = []
rnInstDecls decls fvs gates []
= returnRn (decls, fvs, gates)
rnInstDecls decls fvs gates (d:ds)
= rnIfaceDecl d `thenRn` \ (new_decl, fvs1) ->
rnInstDecls (new_decl:decls)
(fvs1 `plusFV` fvs)
(gates `plusFV` getInstDeclGates new_decl)
ds
-------------------------------------------------------
-- closeDecls keeps going until the free-var set is empty
......@@ -366,7 +387,7 @@ getGates source_fvs (TyClD (ClassDecl ctxt cls tvs sigs _ _ _ _ _ _))
getGates source_fvs (TyClD (TySynonym tycon tvs ty _))
= delListFromNameSet (extractHsTyNames ty)
(map getTyVarName tvs)
`addOneToNameSet` tycon
-- A type synonym type constructor isn't a "gate" for instance decls
getGates source_fvs (TyClD (TyData _ ctxt tycon tvs cons _ _ _))
= delListFromNameSet (foldr (plusFV . get) (extractHsCtxtTyNames ctxt) cons)
......@@ -407,26 +428,25 @@ getWiredInGates is just like getGates, but it sees a wired-in Name
rather than a declaration.
\begin{code}
getWiredInGates name | is_tycon = get_wired_tycon the_tycon
| otherwise = get_wired_id the_id
getWiredInGates :: Name -> FreeVars
getWiredInGates name -- No classes are wired in
| is_id = getWiredInGates_s (namesOfType (idType the_id))
| isSynTyCon the_tycon = getWiredInGates_s (delListFromNameSet (namesOfType ty) (map getName tyvars))
| otherwise = unitFV name
where
maybe_wired_in_tycon = maybeWiredInTyConName name
is_tycon = maybeToBool maybe_wired_in_tycon
maybe_wired_in_id = maybeWiredInIdName name
Just the_tycon = maybe_wired_in_tycon
is_id = maybeToBool maybe_wired_in_id
maybe_wired_in_tycon = maybeWiredInTyConName name
Just the_id = maybe_wired_in_id
Just the_tycon = maybe_wired_in_tycon
(tyvars,ty) = getSynTyConDefn the_tycon
get_wired_id id = namesOfType (idType id)
get_wired_tycon tycon
| isSynTyCon tycon
= namesOfType ty `minusNameSet` mkNameSet (map getName tyvars)
getWiredInGates_s names = foldr (plusFV . getWiredInGates) emptyFVs (nameSetToList names)
\end{code}
| otherwise -- data or newtype
= foldr (unionNameSets . namesOfType . dataConType) emptyNameSet data_cons
where
(tyvars,ty) = getSynTyConDefn tycon
data_cons = tyConDataCons tycon
\begin{code}
getInstDeclGates (InstD (InstDecl inst_ty _ _ _ _)) = extractHsTyNames inst_ty
getInstDeclGates other = emptyFVs
\end{code}
......
......@@ -22,7 +22,7 @@ import RnMonad
import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
ImportReason(..), getSrcLoc,
mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName,
nameOccName, setNameModule,
nameOccName, setNameModule, nameModule,
pprOccName, isLocallyDefined, nameUnique, nameOccName,
setNameProvenance, getNameProvenance, pprNameProvenance
)
......@@ -55,54 +55,7 @@ import Maybes ( mapMaybe )
%*********************************************************
\begin{code}
newImportedBinder :: Module -> RdrName -> RnM d Name
-- Make a new imported binder. It might be in the cache already,
-- but if so it will have a dopey provenance, so replace it.
newImportedBinder mod rdr_name
= ASSERT2( isUnqual rdr_name, ppr rdr_name )
-- First check the cache
getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
let
occ = rdrNameOcc rdr_name
key = (moduleName mod, occ)
in
case lookupFM cache key of
-- A hit in the cache!
-- Overwrite the thing in the cache with a Name whose Module and Provenance
-- is correct. It might be in the cache arising from an *occurrence*,
-- whereas we are now at the binding site.
-- Similarly for known-key things.
-- For example, GHCmain.lhs imports as SOURCE
-- Main; but Main.main is a known-key thing.
Just name -> getOmitQualFn `thenRn` \ omit_fn ->
let
new_name = setNameProvenance (setNameModule name mod)
(NonLocalDef ImplicitImport (omit_fn name))
new_cache = addToFM cache key new_name
in
setNameSupplyRn (us, inst_ns, new_cache) `thenRn_`
returnRn new_name
Nothing -> -- Miss in the cache!
-- Build a new original name, and put it in the cache
getOmitQualFn `thenRn` \ omit_fn ->
let
(us', us1) = splitUniqSupply us
uniq = uniqFromSupply us1
name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport (omit_fn name))
-- For in-scope things we improve the provenance
-- in RnNames.importsFromImportDecl
new_cache = addToFM cache key name
in
setNameSupplyRn (us', inst_ns, new_cache) `thenRn_`
returnRn name
-- Make an imported global name, checking first to see if it's in the cache
mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name
mkImportedGlobalName mod_name occ
newImportedGlobalName mod_name occ mod
= getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
let
key = (mod_name, occ)
......@@ -114,9 +67,29 @@ mkImportedGlobalName mod_name occ
where
(us', us1) = splitUniqSupply us
uniq = uniqFromSupply us1
name = mkGlobalName uniq (mkVanillaModule mod_name) occ
(NonLocalDef ImplicitImport False)
name = mkGlobalName uniq mod occ (NonLocalDef ImplicitImport False)
new_cache = addToFM cache key name
updateProvenances :: [Name] -> RnM d ()
updateProvenances names
= getNameSupplyRn `thenRn` \ (us, inst_ns, cache) ->
setNameSupplyRn (us, inst_ns, update cache names)
where
update cache [] = cache
update cache (name:names) = WARN( not (key `elemFM` cache), ppr name )
update (addToFM cache key name) names
where
key = (moduleName (nameModule name), nameOccName name)
newImportedBinder :: Module -> RdrName -> RnM d Name
newImportedBinder mod rdr_name
= ASSERT2( isUnqual rdr_name, ppr rdr_name )
newImportedGlobalName (moduleName mod) (rdrNameOcc rdr_name) mod
-- Make an imported global name, checking first to see if it's in the cache
mkImportedGlobalName :: ModuleName -> OccName -> RnM d Name
mkImportedGlobalName mod_name occ
= newImportedGlobalName mod_name occ (mkVanillaModule mod_name)
mkImportedGlobalFromRdrName rdr_name
| isQual rdr_name
......
......@@ -291,15 +291,25 @@ loadInstDecl mod insts decl@(InstDecl inst_ty binds uprags dfun_name src_loc)
--
-- Here the gates are Baz and T, but *not* Foo.
let
munged_inst_ty = case inst_ty of
HsForAllTy tvs cxt ty -> HsForAllTy tvs [] ty
other -> inst_ty
free_names = extractHsTyRdrNames munged_inst_ty
munged_inst_ty = removeContext inst_ty
free_names = extractHsTyRdrNames munged_inst_ty
in
setModuleRn (moduleName mod) $
mapRn mkImportedGlobalFromRdrName free_names `thenRn` \ gate_names ->
returnRn ((mkNameSet gate_names, (mod, InstD decl)) `consBag` insts)
-- In interface files, the instance decls now look like
-- forall a. Foo a -> Baz (T a)
-- so we have to strip off function argument types as well
-- as the bit before the '=>' (which is always empty in interface files)
removeContext (HsForAllTy tvs cxt ty) = HsForAllTy tvs [] (removeFuns ty)
removeContext ty = removeFuns ty
removeFuns (MonoFunTy _ ty) = removeFuns ty
removeFuns ty = ty
loadRule :: Module -> Bag GatedDecl
-> RdrNameRuleDecl -> RnM d (Bag GatedDecl)
-- "Gate" the rule simply by whether the rule variable is
......
......@@ -47,7 +47,7 @@ import SrcLoc ( SrcLoc, mkGeneratedSrcLoc )
import Unique ( Unique, getUnique, unboundKey )
import UniqFM ( UniqFM )
import FiniteMap ( FiniteMap, emptyFM, bagToFM, lookupFM, addToFM, addListToFM,
addListToFM_C, addToFM_C, eltsFM
addListToFM_C, addToFM_C, eltsFM, fmToList
)
import Bag ( Bag, mapBag, emptyBag, isEmptyBag, snocBag )
import Maybes ( mapMaybe )
......@@ -156,6 +156,7 @@ lookupRdrEnv = lookupFM
addListToRdrEnv = addListToFM
rdrEnvElts = eltsFM
extendRdrEnv = addToFM
rdrEnvToList = fmToList
--------------------------------
type NameEnv a = UniqFM a -- Domain is Name
......
......@@ -37,11 +37,11 @@ import Bag ( bagToList )
import Maybes ( maybeToBool )
import Module ( ModuleName, mkThisModule, pprModuleName, WhereFrom(..) )
import NameSet
import Name ( Name, ExportFlag(..), ImportReason(..),
isLocallyDefined, setNameImportReason,
import Name ( Name, ExportFlag(..), ImportReason(..), Provenance(..),
isLocallyDefined, setNameProvenance,
nameOccName, getSrcLoc, pprProvenance, getNameProvenance
)
import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual )
import RdrName ( RdrName, rdrNameOcc, mkRdrQual, mkRdrUnqual, isQual )
import SrcLoc ( SrcLoc )
import NameSet ( elemNameSet, emptyNameSet )
import Outputable
......@@ -71,17 +71,17 @@ getGlobalNames :: RdrNameHsModule
getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
= -- These two fix-loops are to get the right
-- provenance information into a Name
fixRn (\ ~(rec_exported_avails, _) ->
fixRn (\ ~(rec_gbl_env, rec_exported_avails, _) ->
fixRn (\ ~(rec_rn_env, _) ->
-- fixRn (\ ~(rec_rn_env, _) ->
let
rec_unqual_fn :: Name -> Bool -- Is this chap in scope unqualified?
rec_unqual_fn = unQualInScope rec_rn_env
rec_unqual_fn = unQualInScope rec_gbl_env
rec_exp_fn :: Name -> ExportFlag
rec_exp_fn = mk_export_fn (availsToNameSet rec_exported_avails)
in
setOmitQualFn rec_unqual_fn $
-- setOmitQualFn rec_unqual_fn $
setModuleRn this_mod $
-- PROCESS LOCAL DECLS
......@@ -97,8 +97,8 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
is_source_import (ImportDecl _ ImportByUserSource _ _ _ _) = True
is_source_import other = False
in
mapAndUnzipRn importsFromImportDecl ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
mapAndUnzipRn importsFromImportDecl source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) ordinary `thenRn` \ (imp_gbl_envs1, imp_avails_s1) ->
mapAndUnzipRn (importsFromImportDecl rec_unqual_fn) source `thenRn` \ (imp_gbl_envs2, imp_avails_s2) ->
-- COMBINE RESULTS
-- We put the local env second, so that a local provenance
......@@ -111,8 +111,8 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
all_avails :: ExportAvails
all_avails = foldr plusExportAvails local_mod_avails (imp_avails_s2 ++ imp_avails_s1)
in
returnRn (gbl_env, all_avails)
) `thenRn` \ (gbl_env, all_avails) ->
-- returnRn (gbl_env, all_avails)
-- ) `thenRn` \ (gbl_env, all_avails) ->
-- TRY FOR EARLY EXIT
-- We can't go for an early exit before this because we have to check
......@@ -131,21 +131,30 @@ getGlobalNames (HsModule this_mod _ exports imports decls mod_loc)
-- why we wait till after the plusEnv stuff to do the early-exit.
checkEarlyExit this_mod `thenRn` \ up_to_date ->
if up_to_date then
returnRn (junk_exp_fn, Nothing)
returnRn (gbl_env, junk_exp_fn, Nothing)
else
-- RECORD BETTER PROVENANCES IN THE CACHE
-- The names in the envirnoment have better provenances (e.g. imported on line x)
-- than the names in the name cache. We update the latter now, so that we
-- we start renaming declarations we'll get the good names
-- The isQual is because the qualified name is always in scope
updateProvenances (concat [names | (rdr_name, names) <- rdrEnvToList imp_gbl_env,
isQual rdr_name]) `thenRn_`
-- PROCESS EXPORT LISTS
exportsFromAvail this_mod exports all_avails gbl_env `thenRn` \ exported_avails ->
-- DONE
returnRn (exported_avails, Just (all_avails, gbl_env))
) `thenRn` \ (exported_avails, maybe_stuff) ->
returnRn (gbl_env, exported_avails, Just all_avails)
) `thenRn` \ (gbl_env, exported_avails, maybe_stuff) ->
case maybe_stuff of {
Nothing -> returnRn Nothing ;
Just (all_avails, gbl_env) ->
Just all_avails ->
traceRn (text "updateProv" <+> fsep (map ppr (rdrEnvElts gbl_env))) `thenRn_`
-- DEAL WITH FIXITIES
fixitiesFromLocalDecls gbl_env decls `thenRn` \ local_fixity_env ->
let
......@@ -215,11 +224,12 @@ checkEarlyExit mod
\end{code}
\begin{code}
importsFromImportDecl :: RdrNameImportDecl
importsFromImportDecl :: (Name -> Bool) -- OK to omit qualifier
-> RdrNameImportDecl
-> RnMG (GlobalRdrEnv,
ExportAvails)
importsFromImportDecl (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
importsFromImportDecl is_unqual (ImportDecl imp_mod_name from qual_only as_mod import_spec iloc)
= pushSrcLocRn iloc $
getInterfaceExports imp_mod_name from `thenRn` \ (imp_mod, avails) ->
......@@ -237,7 +247,8 @@ importsFromImportDecl (ImportDecl imp_mod_name from qual_only as_mod import_spec
-- (b) the print-unqualified field
-- But don't fiddle with wired-in things or we get in a twist
let
improve_prov name = setNameImportReason name (UserImport imp_mod iloc (is_explicit name))
improve_prov name = setNameProvenance name (NonLocalDef (UserImport imp_mod iloc (is_explicit name))
(is_unqual name))
is_explicit name = name `elemNameSet` explicits
in
qualifyImports imp_mod_name
......
......@@ -55,7 +55,6 @@ import Type ( Type, splitAlgTyConApp_maybe,
tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
Type
)
import Class ( Class, classSelIds )
import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
......
......@@ -27,7 +27,7 @@ module SimplMonad (
newId, newIds,
-- Counting
SimplCount, Tick(..), TickCounts,
SimplCount, Tick(..),
tick, freeTick,
getSimplCount, zeroSimplCount, pprSimplCount,
plusSimplCount, isZeroSimplCount,
......@@ -423,7 +423,6 @@ plusSimplCount :: SimplCount -> SimplCount -> SimplCount
----------------------------------------------------------
type SimplCount = Int
zeroSimplCount :: SimplCount
zeroSimplCount = 0
isZeroSimplCount n = n==0
......
......@@ -18,7 +18,7 @@ import BinderInfo
import CmdLineOpts ( opt_SimplDoLambdaEtaExpansion, opt_SimplCaseMerge )
import CoreSyn
import CoreFVs ( exprFreeVars )
import CoreUtils ( exprIsCheap, exprIsTrivial, cheapEqExpr, coreExprType,
import CoreUtils ( exprIsTrivial, cheapEqExpr, coreExprType,
exprIsWHNF, FormSummary(..)
)
import Subst ( substBndrs, substBndr, substIds )
......@@ -293,35 +293,37 @@ to the result) deals OK with this).
There is no point in looking for a combination of the two,
because that would leave use with some lets sandwiched between lambdas;
but it's awkward to detect that case, so we don't bother.
that's what the final test in the first equation is for.
\begin{code}
tryEtaExpansion :: InExpr -> SimplM InExpr
tryEtaExpansion rhs
| not opt_SimplDoLambdaEtaExpansion
|| exprIsTrivial rhs -- Don't eta-expand a trival RHS
|| null y_tys -- No useful expansion
|| exprIsTrivial rhs -- Don't eta-expand a trival RHS
|| null y_tys -- No useful expansion
|| not (null x_bndrs || and trivial_args) -- Not (no x-binders or no z-binds)
= returnSmpl rhs
| otherwise -- Consider eta expansion
= newIds y_tys ( \ y_bndrs ->
tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
mapAndUnzipSmpl bind_z_arg args `thenSmpl` (\ (z_binds, z_args) ->
returnSmpl (mkLams x_bndrs $
mkLets (catMaybes z_binds) $
mkLams y_bndrs $
= newIds y_tys $ ( \ y_bndrs ->
tick (EtaExpansion (head y_bndrs)) `thenSmpl_`
mapAndUnzipSmpl bind_z_arg (args `zip` trivial_args) `thenSmpl` (\ (maybe_z_binds, z_args) ->
returnSmpl (mkLams x_bndrs $
mkLets (catMaybes maybe_z_binds) $
mkLams y_bndrs $
mkApps (mkApps fun z_args) (map Var y_bndrs))))
where
(x_bndrs, body) = collectValBinders rhs
(fun, args) = collectArgs body
no_of_xs = length x_bndrs
trivial_args = map exprIsTrivial args
fun_arity = case fun of
Var v -> arityLowerBound (getIdArity v)
other -> 0
bind_z_arg arg | exprIsTrivial arg = returnSmpl (Nothing, arg)
| otherwise = newId (coreExprType arg) $ \ z ->
returnSmpl (Just (NonRec z arg), Var z)
bind_z_arg (arg, trivial_arg)
| trivial_arg = returnSmpl (Nothing, arg)
| otherwise = newId (coreExprType arg) $ \ z ->
returnSmpl (Just (NonRec z arg), Var z)
-- Note: I used to try to avoid the coreExprType call by using
-- the type of the binder. But this type doesn't necessarily
......
......@@ -45,9 +45,8 @@ import CoreFVs ( exprFreeVars )
import CoreUnfold ( Unfolding(..), mkUnfolding, callSiteInline,
isEvaldUnfolding, blackListed )
import CoreUtils ( cheapEqExpr, exprIsDupable, exprIsWHNF, exprIsTrivial,
coreExprType, coreAltsType, exprIsCheap, exprArity,
exprOkForSpeculation,
FormSummary(..), mkFormSummary, whnfOrBottom
coreExprType, coreAltsType, exprArity,
exprOkForSpeculation
)
import Rules ( lookupRule )
import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC )
......@@ -239,6 +238,7 @@ simplExprF (Let (Rec pairs) body) cont
simplRecBind NotTopLevel pairs bndrs' (simplExprF body cont)
simplExprF expr@(Lam _ _) cont = simplLam expr cont
simplExprF (Type ty) cont
= ASSERT( case cont of { Stop _ -> True; ArgOf _ _ _ -> True; other -> False } )
simplType ty `thenSmpl` \ ty' ->
......@@ -1146,21 +1146,26 @@ rebuild_case scrut case_bndr alts se cont
-- Deal with the case binder, and prepare the continuation;
-- The new subst_env is in place
simplBinder case_bndr $ \ case_bndr' ->
prepareCaseCont better_alts cont $ \ cont' ->
-- Deal with variable scrutinee
substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
let
case_bndr'' = zap_occ_info case_bndr'
in
( simplBinder case_bndr $ \ case_bndr' ->
substForVarScrut scrut case_bndr' $ \ zap_occ_info ->
let
case_bndr'' = zap_occ_info case_bndr'
in
-- Deal with the case alternaatives
simplAlts zap_occ_info scrut_cons
case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
simplAlts zap_occ_info scrut_cons
case_bndr'' better_alts cont' `thenSmpl` \ alts' ->
mkCase scrut case_bndr'' alts'
) `thenSmpl` \ case_expr ->
mkCase scrut case_bndr'' alts' `thenSmpl` \ case_expr ->
-- Notice that the simplBinder, prepareCaseCont, etc, do *not* scope
-- over the rebuild_done; rebuild_done returns the in-scope set, and