From: simonmar Date: Fri, 21 May 1999 12:52:51 +0000 (+0000) Subject: [project @ 1999-05-21 12:52:28 by simonmar] X-Git-Tag: Approximately_9120_patches~6191 X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=f922d7032692a14890391d0720751c38ce0f7546;p=ghc-hetmet.git [project @ 1999-05-21 12:52:28 by simonmar] A bunch of patches from SLPJ to fix various things. --- diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 26ac675..76d43f5 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -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(..) ) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index a07793f..049578e 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index c57eb66..397bea4 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -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 diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index c71eb5c..7e70501 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -458,6 +458,13 @@ tidy1 v (LazyPat pat) match_result -- re-express 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 diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 14f0cf6..06b9cf7 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -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 diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index bc01d7c..fc1d7e5 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -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} diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index be76422..b249118 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -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 diff --git a/ghc/compiler/rename/RnIfaces.lhs b/ghc/compiler/rename/RnIfaces.lhs index ff21596..37abbdc 100644 --- a/ghc/compiler/rename/RnIfaces.lhs +++ b/ghc/compiler/rename/RnIfaces.lhs @@ -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 diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index d6ab30b..687451c 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -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 diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 8e76d05..0b7691f 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -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 diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 5eed5f9..24a0f13 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -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 ) diff --git a/ghc/compiler/simplCore/SimplMonad.lhs b/ghc/compiler/simplCore/SimplMonad.lhs index 17a4639..c277162 100644 --- a/ghc/compiler/simplCore/SimplMonad.lhs +++ b/ghc/compiler/simplCore/SimplMonad.lhs @@ -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 diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 3615dbf..72c9e1a 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -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 diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 5940184..714d501 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -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 + -- that should not include these chaps! rebuild_done case_expr where -- scrut_cons tells what constructors the scrutinee can't possibly match diff --git a/ghc/compiler/specialise/Rules.lhs b/ghc/compiler/specialise/Rules.lhs index 9ae32e6..7c2bf86 100644 --- a/ghc/compiler/specialise/Rules.lhs +++ b/ghc/compiler/specialise/Rules.lhs @@ -222,6 +222,7 @@ match (App f1 a1) (App f2 a2) tpl_vars kont subst 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 @@ -237,6 +238,7 @@ match (Lam x1 e1) e2 tpl_vars kont subst -- 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 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index fb9529f..64e7e48 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -109,8 +109,20 @@ A binder to be floated out becomes an @StgFloatBind@. 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 @@ -167,16 +179,21 @@ topCoreBindsToStg us core_binds 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} @@ -190,9 +207,9 @@ topCoreBindsToStg us core_binds 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 @@ -201,7 +218,7 @@ coreBindToStg top_lev env (NonRec binder rhs) -- 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 @@ -211,7 +228,12 @@ coreBindToStg top_lev env (Rec pairs) 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} @@ -222,19 +244,16 @@ coreBindToStg top_lev env (Rec pairs) %************************************************************************ \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: @@ -329,25 +348,12 @@ coreArgToStg :: StgEnv -> (CoreArg,RhsDemand) -> UniqSM ([StgFloatBind], StgArg) -- 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} @@ -362,8 +368,9 @@ coreArgToStg env (arg,dem) \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} %************************************************************************ @@ -380,6 +387,8 @@ coreExprToStgFloat :: StgEnv -> CoreExpr -- 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 @@ -420,51 +429,31 @@ coreExprToStgFloat env expr@(Type _) dem \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} @@ -477,23 +466,23 @@ coreExprToStgFloat env expr@(App _ _) dem (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 @@ -574,7 +563,7 @@ coreExprToStgFloat env expr@(Con con args) dem 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 @@ -583,7 +572,7 @@ coreExprToStgFloat env expr@(Con con args) dem _ -> returnUs con ) `thenUs` \ con' -> - returnUs (binds, StgCon con' stg_atoms (coreExprType expr)) + returnUs (arg_floats, StgCon con' stg_atoms (coreExprType expr)) \end{code} @@ -700,41 +689,101 @@ newLocalIds top_lev env (b:bs) \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} diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 9a70947..d844e9d 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -148,6 +148,10 @@ lintStgExpr e@(StgCon con args _) 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) ( diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 1f67634..1c10d34 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -147,6 +147,23 @@ An example might be: @f x = x:[]@. %************************************************************************ %* * +\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} %* * %************************************************************************ @@ -587,6 +604,10 @@ pprStgExpr (StgApp func args) \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} diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index d68074e..82f6fa5 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -88,7 +88,7 @@ The rest of these functions are just simple selectors. \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 diff --git a/ghc/compiler/utils/FiniteMap.lhs b/ghc/compiler/utils/FiniteMap.lhs index c811e28..abcdc2a 100644 --- a/ghc/compiler/utils/FiniteMap.lhs +++ b/ghc/compiler/utils/FiniteMap.lhs @@ -131,8 +131,8 @@ minusFM :: (Ord key OUTPUTABLE_key) => FiniteMap key elt -> FiniteMap key elt - -- (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