A bunch of patches from SLPJ to fix various things.
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(..) )
\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
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
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
-- 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
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
-------------------------------------------------------
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!
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
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)
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}
import Name ( Name, Provenance(..), ExportFlag(..), NamedThing(..),
ImportReason(..), getSrcLoc,
mkLocalName, mkImportedLocalName, mkGlobalName, isSystemName,
- nameOccName, setNameModule,
+ nameOccName, setNameModule, nameModule,
pprOccName, isLocallyDefined, nameUnique, nameOccName,
setNameProvenance, getNameProvenance, pprNameProvenance
)
%*********************************************************
\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)
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
--
-- 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
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 )
addListToRdrEnv = addListToFM
rdrEnvElts = eltsFM
extendRdrEnv = addToFM
+rdrEnvToList = fmToList
--------------------------------
type NameEnv a = UniqFM a -- Domain is Name
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
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
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
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
-- 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
\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) ->
-- (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
tidyType, tidyTypes, tidyTopType, tidyTyVar, tidyTyVars,
Type
)
-import Class ( Class, classSelIds )
import TysWiredIn ( smallIntegerDataCon, isIntegerTy )
import LiberateCase ( liberateCase )
import SAT ( doStaticArgs )
newId, newIds,
-- Counting
- SimplCount, Tick(..), TickCounts,
+ SimplCount, Tick(..),
tick, freeTick,
getSimplCount, zeroSimplCount, pprSimplCount,
plusSimplCount, isZeroSimplCount,
----------------------------------------------------------
type SimplCount = Int
-zeroSimplCount :: SimplCount
zeroSimplCount = 0
isZeroSimplCount n = n==0
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 )
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
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 )
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' ->
-- 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
+ -- that should not include these chaps!
rebuild_done case_expr
where
-- scrut_cons tells what constructors the scrutinee can't possibly match
match (Lam x1 e1) (Lam x2 e2) tpl_vars kont subst
= bind [x1] [x2] (match e1 e2) tpl_vars kont subst
+{- THESE EQUATIONS ARE BOGUS. SLPJ 19 May 99
-- This rule does eta expansion
-- (\x.M) ~ N iff M ~ N x
-- We must clone the binder in case it's already in scope in N
-- Remembering that by (A), y can't be free in M, we get this
match e1 (Lam x2 e2) tpl_vars kont subst
= match (App e1 (mkVarArg x2)) e2 tpl_vars kont subst
+-}
match (Case e1 x1 alts1) (Case e2 x2 alts2) tpl_vars kont subst
= match e1 e2 tpl_vars case_kont subst
type StgEnv = IdEnv Id
data StgFloatBind = NoBindF
- | NonRecF Id StgExpr RhsDemand
| RecF [(Id, StgRhs)]
+ | NonRecF
+ Id
+ StgExpr -- *Can* be a StgLam
+ RhsDemand
+ [StgFloatBind]
+
+-- The interesting one is the NonRecF
+-- NonRecF x rhs demand binds
+-- means
+-- x = let binds in rhs
+-- (or possibly case etc if x demand is strict)
+-- The binds are kept separate so they can be floated futher
+-- if appropriate
\end{code}
A @RhsDemand@ gives the demand on an RHS: strict (@isStrictDem@) and
coreBindsToStg env (b:bs)
= coreBindToStg TopLevel env b `thenUs` \ (bind_spec, new_env) ->
coreBindsToStg new_env bs `thenUs` \ new_bs ->
- let
- res_bs = case bind_spec of
- NonRecF bndr rhs dem -> ASSERT2( not (isStrictDem dem) && not (isUnLiftedType (idType bndr)),
- ppr b )
- -- No top-level cases!
- StgNonRec bndr (exprToRhs dem rhs) : new_bs
- RecF prs -> StgRec prs : new_bs
- NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) new_bs
- in
- returnUs res_bs
+ case bind_spec of
+ NonRecF bndr rhs dem floats
+ -> ASSERT2( not (isStrictDem dem) &&
+ not (isUnLiftedType (idType bndr)),
+ ppr b ) -- No top-level cases!
+
+ mkStgBinds floats rhs `thenUs` \ new_rhs ->
+ returnUs (StgNonRec bndr (exprToRhs dem new_rhs) : new_bs)
+ -- Keep all the floats inside...
+ -- Some might be cases etc
+ -- We might want to revisit this decision
+
+ RecF prs -> returnUs (StgRec prs : new_bs)
+ NoBindF -> pprTrace "topCoreBindsToStg" (ppr b) $
+ returnUs new_bs
\end{code}
coreBindToStg :: TopLevelFlag -> StgEnv -> CoreBind -> UniqSM (StgFloatBind, StgEnv)
coreBindToStg top_lev env (NonRec binder rhs)
- = coreExprToStg env rhs dem `thenUs` \ stg_rhs ->
- case stg_rhs of
- StgApp var [] | not (isExportedId binder)
+ = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_rhs) ->
+ case (floats, stg_rhs) of
+ ([], StgApp var []) | not (isExportedId binder)
-> returnUs (NoBindF, extendVarEnv env binder var)
-- A trivial binding let x = y in ...
-- can arise if postSimplExpr floats a NoRep literal out
-- occur; e.g. an exported user binding f = g
other -> newLocalId top_lev env binder `thenUs` \ (new_env, new_binder) ->
- returnUs (NonRecF new_binder stg_rhs dem, new_env)
+ returnUs (NonRecF new_binder stg_rhs dem floats, new_env)
where
dem = bdrDem binder
returnUs (RecF (binders' `zip` stg_rhss), env')
where
binders = map fst pairs
- do_rhs env (bndr,rhs) = coreRhsToStg env rhs (bdrDem bndr)
+ do_rhs env (bndr,rhs) = coreExprToStgFloat env rhs dem `thenUs` \ (floats, stg_expr) ->
+ mkStgBinds floats stg_expr `thenUs` \ stg_expr' ->
+ -- NB: stg_expr' might still be a StgLam (and we want that)
+ returnUs (exprToRhs dem stg_expr')
+ where
+ dem = bdrDem bndr
\end{code}
%************************************************************************
\begin{code}
-coreRhsToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgRhs
-coreRhsToStg env rhs dem
- = coreExprToStg env rhs dem `thenUs` \ stg_expr ->
- returnUs (exprToRhs dem stg_expr)
-
exprToRhs :: RhsDemand -> StgExpr -> StgRhs
-exprToRhs dem (StgLet (StgNonRec var1 rhs) (StgApp var2 []))
- | var1 == var2
- = rhs
- -- This curious stuff is to unravel what a lambda turns into
- -- We have to do it this way, rather than spot a lambda in the
- -- incoming rhs. Why? Because trivial bindings might conceal
- -- what the rhs is actually like.
+exprToRhs dem (StgLam _ bndrs body)
+ = ASSERT( not (null bndrs) )
+ StgRhsClosure noCCS
+ stgArgOcc
+ noSRT
+ bOGUS_FVs
+ ReEntrant -- binders is non-empty
+ bndrs
+ body
{-
We reject the following candidates for 'static constructor'dom:
-- This is where we arrange that a non-trivial argument is let-bound
coreArgToStg env (arg,dem)
- | isStrictDem dem || isUnLiftedType arg_ty
- -- Strict, so float all the binds out
- = coreExprToStgFloat env arg dem `thenUs` \ (binds, arg') ->
+ = coreExprToStgFloat env arg dem `thenUs` \ (floats, arg') ->
case arg' of
- StgCon con [] _ | isWHNFCon con -> returnUs (binds, StgConArg con)
- StgApp v [] -> returnUs (binds, StgVarArg v)
- other -> newStgVar arg_ty `thenUs` \ v ->
- returnUs (binds ++ [NonRecF v arg' dem], StgVarArg v)
- | otherwise
- -- Lazy
- = coreExprToStgFloat env arg dem `thenUs` \ (binds, arg') ->
- case (binds, arg') of
- ([], StgCon con [] _) | isWHNFCon con -> returnUs ([], StgConArg con)
- ([], StgApp v []) -> returnUs ([], StgVarArg v)
-
- -- A non-trivial argument: we must let-bind it
- -- We don't do the case part here... we leave that to mkStgLets
- (_, other) -> newStgVar arg_ty `thenUs` \ v ->
- returnUs ([NonRecF v (mkStgBinds binds arg') dem], StgVarArg v)
+ StgCon con [] _ -> returnUs (floats, StgConArg con)
+ StgApp v [] -> returnUs (floats, StgVarArg v)
+ other -> newStgVar arg_ty `thenUs` \ v ->
+ returnUs ([NonRecF v arg' dem floats], StgVarArg v)
where
arg_ty = coreExprType arg
\end{code}
\begin{code}
coreExprToStg :: StgEnv -> CoreExpr -> RhsDemand -> UniqSM StgExpr
coreExprToStg env expr dem
- = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) ->
- returnUs (mkStgBinds binds stg_expr)
+ = coreExprToStgFloat env expr dem `thenUs` \ (binds,stg_expr) ->
+ mkStgBinds binds stg_expr `thenUs` \ stg_expr' ->
+ deStgLam stg_expr'
\end{code}
%************************************************************************
-- given by RhsDemand, and is solely used ot figure out the usage
-- of constructor args: if the constructor is used once, then so are
-- its arguments. The strictness info in RhsDemand isn't used.
+
+-- The StgExpr returned *can* be an StgLam
\end{code}
Simple cases first
\begin{code}
coreExprToStgFloat env expr@(Lam _ _) dem
= let
+ expr_ty = coreExprType expr
(binders, body) = collectBinders expr
id_binders = filter isId binders
body_dem = trace "coreExprToStg: approximating body_dem in Lam"
safeDem
in
- newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
- coreExprToStg env' body body_dem `thenUs` \ stg_body ->
-
if null id_binders then -- It was all type/usage binders; tossed
- returnUs ([], stg_body)
+ coreExprToStgFloat env body dem
else
- case stg_body of
-
- -- if the body reduced to a lambda too...
- (StgLet (StgNonRec var (StgRhsClosure cc bi srt fvs uf args body))
- (StgApp var' []))
- | var == var' ->
- returnUs ([],
- -- ToDo: make this a float, but we need
- -- a lambda form for that! Sigh
- StgLet (StgNonRec var (StgRhsClosure noCCS
- stgArgOcc
- noSRT
- bOGUS_FVs
- ReEntrant
- (binders' ++ args)
- body))
- (StgApp var []))
-
- other ->
+ -- At least some value binders
+ newLocalIds NotTopLevel env id_binders `thenUs` \ (env', binders') ->
+ coreExprToStgFloat env' body body_dem `thenUs` \ (floats, stg_body) ->
+ mkStgBinds floats stg_body `thenUs` \ stg_body' ->
+
+ case stg_body' of
+ StgLam ty lam_bndrs lam_body ->
+ -- If the body reduced to a lambda too, join them up
+ returnUs ([], StgLam expr_ty (binders' ++ lam_bndrs) lam_body)
- -- We must let-bind the lambda
- newStgVar (coreExprType expr) `thenUs` \ var ->
- returnUs ([],
- -- Ditto
- StgLet (StgNonRec var (StgRhsClosure noCCS
- stgArgOcc
- noSRT
- bOGUS_FVs
- ReEntrant -- binders is non-empty
- binders'
- stg_body))
- (StgApp var []))
+ other ->
+ -- Body didn't reduce to a lambda, so return one
+ returnUs ([], StgLam expr_ty binders' stg_body')
\end{code}
+
%************************************************************************
%* *
\subsubsection[coreToStg-applications]{Applications}
(fun,rads,_,_) = collect_args expr
ads = reverse rads
in
- coreArgsToStg env ads `thenUs` \ (binds, stg_args) ->
+ coreArgsToStg env ads `thenUs` \ (arg_floats, stg_args) ->
-- Now deal with the function
case (fun, stg_args) of
(Var fun_id, _) -> -- A function Id, so do an StgApp; it's ok if
-- there are no arguments.
- returnUs (binds,
+ returnUs (arg_floats,
StgApp (stgLookup env fun_id) stg_args)
(non_var_fun, []) -> -- No value args, so recurse into the function
- ASSERT( null binds )
+ ASSERT( null arg_floats )
coreExprToStgFloat env non_var_fun dem
other -> -- A non-variable applied to things; better let-bind it.
- newStgVar (coreExprType fun) `thenUs` \ fun_id ->
- coreExprToStg env fun onceDem `thenUs` \ stg_fun ->
- returnUs (NonRecF fun_id stg_fun onceDem : binds,
+ newStgVar (coreExprType fun) `thenUs` \ fun_id ->
+ coreExprToStgFloat env fun onceDem `thenUs` \ (fun_floats, stg_fun) ->
+ returnUs (NonRecF fun_id stg_fun onceDem fun_floats : arg_floats,
StgApp fun_id stg_args)
where
dems' = zipWith mkDem stricts onces
args' = filter isValArg args
in
- coreArgsToStg env (zip args' dems') `thenUs` \ (binds, stg_atoms) ->
+ coreArgsToStg env (zip args' dems') `thenUs` \ (arg_floats, stg_atoms) ->
-- YUK YUK: must unique if present
(case con of
_ -> returnUs con
) `thenUs` \ con' ->
- returnUs (binds, StgCon con' stg_atoms (coreExprType expr))
+ returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr))
\end{code}
\begin{code}
-mkStgBinds :: [StgFloatBind] -> StgExpr -> StgExpr
-mkStgBinds binds body = foldr mkStgBind body binds
+-- Stg doesn't have a lambda *expression*,
+deStgLam (StgLam ty bndrs body) = mkStgLamExpr ty bndrs body
+deStgLam expr = returnUs expr
+
+mkStgLamExpr ty bndrs body
+ = ASSERT( not (null bndrs) )
+ newStgVar ty `thenUs` \ fn ->
+ returnUs (StgLet (StgNonRec fn lam_closure) (StgApp fn []))
+ where
+ lam_closure = StgRhsClosure noCCS
+ stgArgOcc
+ noSRT
+ bOGUS_FVs
+ ReEntrant -- binders is non-empty
+ bndrs
+ body
+
+mkStgBinds :: [StgFloatBind]
+ -> StgExpr -- *Can* be a StgLam
+ -> UniqSM StgExpr -- *Can* be a StgLam
+
+mkStgBinds [] body = returnUs body
+mkStgBinds (b:bs) body
+ = deStgLam body `thenUs` \ body' ->
+ go (b:bs) body'
+ where
+ go [] body = returnUs body
+ go (b:bs) body = go bs body `thenUs` \ body' ->
+ mkStgBind b body'
-mkStgBind NoBindF body = body
-mkStgBind (RecF prs) body = StgLet (StgRec prs) body
+-- The 'body' arg of mkStgBind can't be a StgLam
+mkStgBind NoBindF body = returnUs body
+mkStgBind (RecF prs) body = returnUs (StgLet (StgRec prs) body)
-mkStgBind (NonRecF bndr rhs dem) body
+mkStgBind (NonRecF bndr rhs dem floats) body
#ifdef DEBUG
-- We shouldn't get let or case of the form v=w
= case rhs of
StgApp v [] -> pprTrace "mkStgLet" (ppr bndr <+> ppr v)
- (mk_stg_let bndr rhs dem body)
- other -> mk_stg_let bndr rhs dem body
+ (mk_stg_let bndr rhs dem floats body)
+ other -> mk_stg_let bndr rhs dem floats body
-mk_stg_let bndr rhs dem body
+mk_stg_let bndr rhs dem floats body
#endif
- | isUnLiftedType bndr_ty -- Use a case/PrimAlts
+ | isUnLiftedType bndr_ty -- Use a case/PrimAlts
= ASSERT( not (isUnboxedTupleType bndr_ty) )
+ mkStgBinds floats $
mkStgCase rhs bndr (StgPrimAlts bndr_ty [] (StgBindDefault body))
- | isStrictDem dem && not_whnf -- Use an case/AlgAlts
- = mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
-
- | otherwise
- = ASSERT( not (isUnLiftedType bndr_ty) )
- StgLet (StgNonRec bndr expr_rhs) body
+ | is_whnf
+ = if is_strict then
+ -- Strict let with WHNF rhs
+ mkStgBinds floats $
+ StgLet (StgNonRec bndr (exprToRhs dem rhs)) body
+ else
+ -- Lazy let with WHNF rhs; float until we find a strict binding
+ let
+ (floats_out, floats_in) = splitFloats floats
+ in
+ mkStgBinds floats_in rhs `thenUs` \ new_rhs ->
+ mkStgBinds floats_out $
+ StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body
+
+ | otherwise -- Not WHNF
+ = if is_strict then
+ -- Strict let with non-WHNF rhs
+ mkStgBinds floats $
+ mkStgCase rhs bndr (StgAlgAlts bndr_ty [] (StgBindDefault body))
+ else
+ -- Lazy let with non-WHNF rhs, so keep the floats in the RHS
+ mkStgBinds floats rhs `thenUs` \ new_rhs ->
+ returnUs (StgLet (StgNonRec bndr (exprToRhs dem new_rhs)) body)
+
where
- bndr_ty = idType bndr
- expr_rhs = exprToRhs dem rhs
- not_whnf = case expr_rhs of
- StgRhsClosure _ _ _ _ _ args _ -> null args
- StgRhsCon _ _ _ -> False
-
-mkStgCase (StgLet bind expr) bndr alts
- = StgLet bind (mkStgCase expr bndr alts)
+ bndr_ty = idType bndr
+ is_strict = isStrictDem dem
+ is_whnf = case rhs of
+ StgCon _ _ _ -> True
+ StgLam _ _ _ -> True
+ other -> False
+
+-- Split at the first strict binding
+splitFloats fs@(NonRecF _ _ dem _ : _)
+ | isStrictDem dem = ([], fs)
+
+splitFloats (f : fs) = case splitFloats fs of
+ (fs_out, fs_in) -> (f : fs_out, fs_in)
+
+splitFloats [] = ([], [])
+
+
mkStgCase scrut bndr alts
- = StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
+ = ASSERT( case scrut of { StgLam _ _ _ -> False; other -> True } )
+ -- We should never find
+ -- case (\x->e) of { ... }
+ -- The simplifier eliminates such things
+ StgCase scrut bOGUS_LVs bOGUS_LVs bndr noSRT alts
\end{code}
where
con_ty = conType con
+lintStgExpr (StgLam _ bndrs _)
+ = addErrL (ptext SLIT("Unexpected StgLam") <+> ppr bndrs) `thenL_`
+ returnL Nothing
+
lintStgExpr (StgLet binds body)
= lintStgBinds binds `thenL` \ binders ->
addLoc (BodyOfLetRec binders) (
%************************************************************************
%* *
+\subsubsection{@StgLam@}
+%* *
+%************************************************************************
+
+StgLam is used *only* during CoreToStg's work. Before CoreToStg has finished
+it encodes (\x -> e) as (let f = \x -> e in f)
+
+\begin{code}
+ | StgLam
+ Type -- Type of whole lambda (useful when making a binder for it)
+ [Id]
+ StgExpr -- Body of lambda
+\end{code}
+
+
+%************************************************************************
+%* *
\subsubsection{@GenStgExpr@: case-expressions}
%* *
%************************************************************************
\begin{code}
pprStgExpr (StgCon con args _)
= hsep [ ppr con, brackets (interppSP args)]
+
+pprStgExpr (StgLam _ bndrs body)
+ =sep [ char '\\' <+> ppr bndrs <+> ptext SLIT("->"),
+ pprStgExpr body ]
\end{code}
\begin{code}
\begin{code}
classKey (Class key _ _ _ _ _ _ _ _) = key
classSuperClassTheta (Class _ _ _ scs _ _ _ _ _) = scs
-classSelIds (Class _ _ _ _ _ sels _ _ _) = sels
+classSelIds (Class _ _ _ _ sc_sels op_sels _ _ _) = sc_sels ++ op_sels
classTyCon (Class _ _ _ _ _ _ _ _ tc) = tc
classInstEnv (Class _ _ _ _ _ _ _ env _) = env
-- (minusFM a1 a2) deletes from a1 any bindings which are bound in a2
intersectFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt
-intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt -> elt -> elt2)
- -> FiniteMap key elt -> FiniteMap key elt -> FiniteMap key elt2
+intersectFM_C :: (Ord key OUTPUTABLE_key) => (elt1 -> elt2 -> elt3)
+ -> FiniteMap key elt1 -> FiniteMap key elt2 -> FiniteMap key elt3
-- MAPPING, FOLDING, FILTERING
foldFM :: (key -> elt -> a -> a) -> a -> FiniteMap key elt -> a
projects / ghc-hetmet.git / commitdiff