From 685e04e4af2e2332f2555990122596c7931cb543 Mon Sep 17 00:00:00 2001 From: simonpj Date: Thu, 18 Oct 2001 16:29:14 +0000 Subject: [PATCH 1/1] [project @ 2001-10-18 16:29:12 by simonpj] ---------------------------------------------- The CoreTidy/CorePrep/CoreToStg saga continues [actually, this commit mostly completes the job] ---------------------------------------------- DO NOT MERGE! * CorePrep injects implicit bindings, not the type checker, nor CgConTbls. (This way, all the code generators see them, so no need to fiddle with the byte code generator.) As a result, all bindings in the module are for LocalIds, at least until CoreTidy. This is a Big Win. Hence remove nasty isImplicitId test in update_bndr in SimplCore and DmdAnal * hasNoBinding is no longer true of a dataConId (worker). There's an implicit curried binding for it. * Remove yukky test in exprIsTrivial that did not regard a hasNoBinding Id as trivial; similarly in SimplUtils.tryEtaReduce * In CoreTidy, get the names to avoid from the type env. That way it includes implicit bindings too. * CoreTidy set the Arity of a top-level Id permanently; it's up to the rest of the compiler to respect it. Notably, CorePrep uses etaExpand to make the manifest arity match the claimed arity. * As a result, nuke CgArity, so that CgInfo now contains only CafInfo. The CafInfo is knot-tied as before. Other things * In Simplify.simplLazyBind, be a bit keener to float bindings out if it's a top-level binding. --- ghc/compiler/basicTypes/Id.lhs | 21 +---- ghc/compiler/basicTypes/IdInfo.lhs | 33 +++---- ghc/compiler/basicTypes/MkId.lhs | 11 +-- ghc/compiler/codeGen/CgConTbls.lhs | 37 +------- ghc/compiler/codeGen/ClosureInfo.lhs | 6 +- ghc/compiler/coreSyn/CorePrep.lhs | 134 +++++++++++++++++++++------ ghc/compiler/coreSyn/CoreTidy.lhs | 162 ++++++++++++++++----------------- ghc/compiler/coreSyn/CoreUtils.lhs | 46 +++++----- ghc/compiler/main/HscMain.lhs | 11 +-- ghc/compiler/main/HscTypes.lhs | 26 ++++-- ghc/compiler/main/MkIface.lhs | 6 +- ghc/compiler/simplCore/SimplCore.lhs | 8 +- ghc/compiler/simplCore/SimplUtils.lhs | 29 ++---- ghc/compiler/simplCore/Simplify.lhs | 19 ++-- ghc/compiler/stgSyn/CoreToStg.lhs | 34 ++----- ghc/compiler/stranal/DmdAnal.lhs | 14 +-- ghc/compiler/typecheck/TcIfaceSig.lhs | 3 +- ghc/compiler/typecheck/TcModule.lhs | 26 ++---- 18 files changed, 296 insertions(+), 330 deletions(-) diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index b212920..9575acd 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -62,7 +62,6 @@ module Id ( idSpecialisation, idCgInfo, idCafInfo, - idCgArity, idCprInfo, idLBVarInfo, idOccInfo, @@ -266,11 +265,12 @@ isDataConWrapId id = case globalIdDetails id of DataConWrapId con -> True other -> False - -- hasNoBinding returns True of an Id which may not have a - -- binding, even though it is defined in this module. Notably, - -- the constructors of a dictionary are in this situation. +-- hasNoBinding returns True of an Id which may not have a +-- binding, even though it is defined in this module. +-- Data constructor workers used to be things of this kind, but +-- they aren't any more. Instead, we inject a binding for +-- them at the CorePrep stage. hasNoBinding id = case globalIdDetails id of - DataConId _ -> True PrimOpId _ -> True FCallId _ -> True other -> False @@ -429,17 +429,6 @@ idCafInfo id = cgCafInfo (idCgInfo id) #endif --------------------------------- - -- CG ARITY -idCgArity :: Id -> Arity -#ifdef DEBUG -idCgArity id = case cgInfo (idInfo id) of - NoCgInfo -> pprPanic "idCgArity" (ppr id) - info -> cgArity info -#else -idCgArity id = cgArity (idCgInfo id) -#endif - - --------------------------------- -- CPR INFO idCprInfo :: Id -> CprInfo idCprInfo id = case cprInfo (idInfo id) of diff --git a/ghc/compiler/basicTypes/IdInfo.lhs b/ghc/compiler/basicTypes/IdInfo.lhs index 0a8067b..07598a3 100644 --- a/ghc/compiler/basicTypes/IdInfo.lhs +++ b/ghc/compiler/basicTypes/IdInfo.lhs @@ -62,9 +62,8 @@ module IdInfo ( -- CG info CgInfo(..), cgInfo, setCgInfo, pprCgInfo, - cgArity, cgCafInfo, vanillaCgInfo, + cgCafInfo, vanillaCgInfo, CgInfoEnv, lookupCgInfo, - setCgArity, -- CAF info CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs, @@ -118,7 +117,6 @@ infixl 1 `setDemandInfo`, `setOccInfo`, `setCgInfo`, `setCafInfo`, - `setCgArity`, `setNewStrictnessInfo`, `setNewDemandInfo` -- infixl so you can say (id `set` a `set` b) @@ -341,7 +339,7 @@ vanillaIdInfo } noCafNoTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever - `setCgInfo` (CgInfo 0 NoCafRefs) + `setCgInfo` CgInfo NoCafRefs -- Used for built-in type Ids in MkId. -- Many built-in things have fixed types, so we shouldn't -- run around generalising them @@ -539,33 +537,24 @@ but only as a thunk --- the information is only actually produced further downstream, by the code generator. \begin{code} -data CgInfo = CgInfo - !Arity -- Exact arity for calling purposes - !CafInfo -#ifdef DEBUG +#ifndef DEBUG +newtype CgInfo = CgInfo CafInfo -- We are back to only having CafRefs in CgInfo +noCgInfo = panic "NoCgInfo!" +#else +data CgInfo = CgInfo CafInfo | NoCgInfo -- In debug mode we don't want a black hole here -- See Id.idCgInfo - -- noCgInfo is used for local Ids, which shouldn't need any CgInfo noCgInfo = NoCgInfo -#else -noCgInfo = panic "NoCgInfo!" #endif -cgArity (CgInfo arity _) = arity -cgCafInfo (CgInfo _ caf_info) = caf_info - -setCafInfo info caf_info = - case cgInfo info of { CgInfo arity _ -> - info `setCgInfo` CgInfo arity caf_info } +cgCafInfo (CgInfo caf_info) = caf_info -setCgArity info arity = - case cgInfo info of { CgInfo _ caf_info -> - info `setCgInfo` CgInfo arity caf_info } +setCafInfo info caf_info = info `setCgInfo` CgInfo caf_info seqCg c = c `seq` () -- fields are strict anyhow -vanillaCgInfo = CgInfo 0 MayHaveCafRefs -- Definitely safe +vanillaCgInfo = CgInfo MayHaveCafRefs -- Definitely safe -- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs). @@ -583,7 +572,7 @@ mayHaveCafRefs _ = False seqCaf c = c `seq` () -pprCgInfo (CgInfo arity caf_info) = ppArity arity <+> ppCafInfo caf_info +pprCgInfo (CgInfo caf_info) = ppCafInfo caf_info ppArity 0 = empty ppArity n = hsep [ptext SLIT("__A"), int n] diff --git a/ghc/compiler/basicTypes/MkId.lhs b/ghc/compiler/basicTypes/MkId.lhs index 7fc7804..75060e9 100644 --- a/ghc/compiler/basicTypes/MkId.lhs +++ b/ghc/compiler/basicTypes/MkId.lhs @@ -71,10 +71,10 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, ) import IdInfo ( IdInfo, noCafNoTyGenIdInfo, setUnfoldingInfo, - setArityInfo, setSpecInfo, setCgInfo, + setArityInfo, setSpecInfo, setCgInfo, setCafInfo, mkNewStrictnessInfo, setNewStrictnessInfo, GlobalIdDetails(..), CafInfo(..), CprInfo(..), - CgInfo(..), setCgArity + CgInfo ) import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..), mkTopDmdType, topDmd, evalDmd, Demand(..), Keepity(..) ) @@ -145,7 +145,6 @@ mkDataConId work_name data_con = mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info where info = noCafNoTyGenIdInfo - `setCgArity` arity `setArityInfo` arity `setNewStrictnessInfo` Just strict_sig @@ -234,7 +233,6 @@ mkDataConWrapId data_con info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs) - `setCgArity` arity -- The NoCaf-ness is set by noCafNoTyGenIdInfo `setArityInfo` arity -- It's important to specify the arity, so that partial @@ -433,7 +431,7 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id -- With all this unpackery it's not easy! info = noCafNoTyGenIdInfo - `setCgInfo` CgInfo arity caf_info + `setCafInfo` caf_info `setArityInfo` arity `setUnfoldingInfo` mkTopUnfolding rhs_w_str `setNewStrictnessInfo` Just strict_sig @@ -570,7 +568,6 @@ mkDictSelId name clas tag = assoc "MkId.mkDictSelId" (map idName (classSelIds clas) `zip` allFieldLabelTags) name info = noCafNoTyGenIdInfo - `setCgArity` 1 `setArityInfo` 1 `setUnfoldingInfo` mkTopUnfolding rhs `setNewStrictnessInfo` Just strict_sig @@ -630,7 +627,6 @@ mkPrimOpId prim_op info = noCafNoTyGenIdInfo `setSpecInfo` rules - `setCgArity` arity `setArityInfo` arity `setNewStrictnessInfo` Just (mkNewStrictnessInfo id arity strict_info NoCPRInfo) -- Until we modify the primop generation code @@ -661,7 +657,6 @@ mkFCallId uniq fcall ty name = mkFCallName uniq occ_str info = noCafNoTyGenIdInfo - `setCgArity` arity `setArityInfo` arity `setNewStrictnessInfo` Just strict_sig diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index ee5b37b..6666b14 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -9,22 +9,17 @@ module CgConTbls ( genStaticConBits ) where #include "HsVersions.h" import AbsCSyn -import StgSyn import CgMonad import AbsCUtils ( mkAbstractCs, mkAbsCStmts ) import CostCentre ( subsumedCCS ) -import CgCon ( cgTopRhsCon ) -import CgClosure ( cgTopRhsClosure ) import CgTailCall ( performReturn, mkStaticAlgReturnCode ) -import ClosureInfo ( layOutStaticConstr, layOutDynConstr, mkClosureLFInfo, ClosureInfo ) -import DataCon ( DataCon, dataConName, dataConRepArgTys, dataConId, isNullaryDataCon ) -import Id ( mkTemplateLocals ) +import ClosureInfo ( layOutStaticConstr, layOutDynConstr, ClosureInfo ) +import DataCon ( DataCon, dataConName, dataConRepArgTys, isNullaryDataCon ) import Name ( getOccName ) import OccName ( occNameUserString ) import TyCon ( tyConDataCons, isEnumerationTyCon, TyCon ) import Type ( typePrimRep ) -import BasicTypes ( TopLevelFlag(..) ) import Outputable \end{code} @@ -114,8 +109,7 @@ genConInfo comp_info data_con = -- Order of things is to reduce forward references mkAbstractCs [CSplitMarker, closure_code, - static_code, - wrkr_code] + static_code] where (closure_info, body_code) = mkConCodeAndInfo data_con @@ -128,7 +122,6 @@ genConInfo comp_info data_con profCtrC SLIT("TICK_ENT_CON") [CReg node] `thenC` body_code) - wrkr_code = initC comp_info (cgWorker data_con `thenFC` \ _ -> returnFC ()) con_descr = occNameUserString (getOccName data_con) -- Don't need any dynamic closure code for zero-arity constructors @@ -169,27 +162,3 @@ mkConCodeAndInfo con in (closure_info, body_code) \end{code} - -For a constructor C, make a binding - - $wC = \x y -> $wC x y - -i.e. a curried constructor that allocates. This means that we can treat -the worker for a constructor like any other function in the rest of the compiler. - -\begin{code} -cgWorker data_con - | isNullaryDataCon data_con - = cgTopRhsCon work_id data_con [] - - | otherwise - = cgTopRhsClosure work_id - subsumedCCS noBinderInfo NoSRT - arg_ids rhs - lf_info - where - work_id = dataConId data_con - arg_ids = mkTemplateLocals (dataConRepArgTys data_con) - rhs = StgConApp data_con [StgVarArg id | id <- arg_ids] - lf_info = mkClosureLFInfo work_id TopLevel [{-no fvs-}] ReEntrant arg_ids -\end{code} diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 6ba2ec0..b7e6ace 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.48 2001/09/26 15:11:50 simonpj Exp $ +% $Id: ClosureInfo.lhs,v 1.49 2001/10/18 16:29:13 simonpj Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -77,7 +77,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, opt_Parallel, opt_DoTickyProfiling, opt_SMP ) -import Id ( Id, idType, idCgArity ) +import Id ( Id, idType, idArity ) import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, isNullaryDataCon, dataConName ) @@ -249,7 +249,7 @@ mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo mkLFImported id - = case idCgArity id of + = case idArity id of n | n > 0 -> LFReEntrant (idType id) TopLevel n True -- n > 0 other -> LFImported -- Not sure of exact arity \end{code} diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 36495d2..eb543a3 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -24,9 +24,11 @@ import VarSet import VarEnv import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdType, isPrimOpId_maybe, isFCallId, isGlobalId, - hasNoBinding, idNewStrictness, setIdArity + hasNoBinding, idNewStrictness, + isDataConId_maybe, idUnfolding ) -import HscTypes ( ModDetails(..) ) +import HscTypes ( ModDetails(..), implicitTyThingIds, typeEnvElts ) +import Unique ( mkBuiltinUnique ) import BasicTypes ( Arity, TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -72,13 +74,19 @@ The goal of this pass is to prepare for code generation. 7. Give each dynamic CCall occurrence a fresh unique; this is rather like the cloning step above. +8. Inject bindings for the "implicit" Ids: + * Constructor wrappers + * Constructor workers + * Record selectors + We want curried definitions for all of these in case they + aren't inlined by some caller. + This is all done modulo type applications and abstractions, so that when type erasure is done for conversion to STG, we don't end up with any trivial or useless bindings. - -- ----------------------------------------------------------------------------- -- Top level stuff -- ----------------------------------------------------------------------------- @@ -89,13 +97,18 @@ corePrepPgm dflags mod_details = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let floats = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details)) - new_binds = foldrOL get [] floats - get (FloatLet b) bs = b:bs - get b bs = pprPanic "corePrepPgm" (ppr b) + let implicit_binds = mkImplicitBinds (md_types mod_details) + -- NB: we must feed mkImplicitBinds through corePrep too + -- so that they are suitably cloned and eta-expanded - endPass dflags "CorePrep" Opt_D_dump_prep new_binds - return (mod_details { md_binds = new_binds }) + binds_out = initUs_ us ( + corePrepTopBinds (md_binds mod_details) `thenUs` \ floats1 -> + corePrepTopBinds implicit_binds `thenUs` \ floats2 -> + returnUs (deFloatTop (floats1 `appOL` floats2)) + ) + + endPass dflags "CorePrep" Opt_D_dump_prep binds_out + return (mod_details { md_binds = binds_out }) corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr corePrepExpr dflags expr @@ -105,7 +118,52 @@ corePrepExpr dflags expr dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) return new_expr +\end{code} + +-- ----------------------------------------------------------------------------- +-- Implicit bindings +-- ----------------------------------------------------------------------------- + +Create any necessary "implicit" bindings (data constructors etc). +Namely: + * Constructor workers + * Constructor wrappers + * Data type record selectors + * Class op selectors + +In the latter three cases, the Id contains the unfolding to use for +the binding. In the case of data con workers we create the rather +strange (non-recursive!) binding + + $wC = \x y -> $wC x y + +i.e. a curried constructor that allocates. This means that we can +treat the worker for a constructor like any other function in the rest +of the compiler. The point here is that CoreToStg will generate a +StgConApp for the RHS, rather than a call to the worker (which would +give a loop). As Lennart says: the ice is thin here, but it works. + +Hmm. Should we create bindings for dictionary constructors? They are +always fully applied, and the bindings are just there to support +partial applications. But it's easier to let them through. + +\begin{code} +mkImplicitBinds type_env + = [ NonRec id (get_unfolding id) + | id <- implicitTyThingIds (typeEnvElts type_env) ] + -- The etaExpand is so that the manifest arity of the + -- binding matches its claimed arity, which is an + -- invariant of top level bindings going into the code gen + where + tmpl_uniqs = map mkBuiltinUnique [1..] +get_unfolding id -- See notes above + | Just data_con <- isDataConId_maybe id = Var id -- The ice is thin here, but it works + | otherwise = unfoldingTemplate (idUnfolding id) +\end{code} + + +\begin{code} -- --------------------------------------------------------------------------- -- Dealing with bindings -- --------------------------------------------------------------------------- @@ -120,6 +178,14 @@ instance Outputable FloatingBind where type CloneEnv = IdEnv Id -- Clone local Ids +deFloatTop :: OrdList FloatingBind -> [CoreBind] +-- For top level only; we don't expect any FloatCases +deFloatTop floats + = foldrOL get [] floats + where + get (FloatLet b) bs = b:bs + get b bs = pprPanic "corePrepPgm" (ppr b) + allLazy :: TopLevelFlag -> RecFlag -> OrdList FloatingBind -> Bool allLazy top_lvl is_rec floats = foldrOL check True floats @@ -137,13 +203,14 @@ allLazy top_lvl is_rec floats -- Bindings -- --------------------------------------------------------------------------- -corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM (OrdList FloatingBind) -corePrepTopBinds env [] = returnUs nilOL - -corePrepTopBinds env (bind : binds) - = corePrepTopBind env bind `thenUs` \ (env', bind') -> - corePrepTopBinds env' binds `thenUs` \ binds' -> - returnUs (bind' `appOL` binds') +corePrepTopBinds :: [CoreBind] -> UniqSM (OrdList FloatingBind) +corePrepTopBinds binds + = go emptyVarEnv binds + where + go env [] = returnUs nilOL + go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') -> + go env' binds `thenUs` \ binds' -> + returnUs (bind' `appOL` binds') -- NB: we do need to float out of top-level bindings -- Consider x = length [True,False] @@ -159,6 +226,7 @@ corePrepTopBinds env (bind : binds) -- x* = f a -- And then x will actually end up case-bound +-------------------------------- corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) corePrepTopBind env (NonRec bndr rhs) = cloneBndr env bndr `thenUs` \ (env', bndr') -> @@ -167,6 +235,7 @@ corePrepTopBind env (NonRec bndr rhs) corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs +-------------------------------- corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind) -- This one is used for *local* bindings corePrepBind env (NonRec bndr rhs) @@ -217,14 +286,12 @@ corePrepArg env arg dem = corePrepExprFloat env arg `thenUs` \ (floats, arg') -> if exprIsTrivial arg' then returnUs (floats, arg') - else newVar (exprType arg') (exprArity arg') `thenUs` \ v -> - mkLocalNonRec v dem floats arg' `thenUs` \ floats' -> + else newVar (exprType arg') `thenUs` \ v -> + mkLocalNonRec v dem floats arg' `thenUs` \ floats' -> returnUs (floats', Var v) -- version that doesn't consider an scc annotation to be trivial. -exprIsTrivial (Var v) - | hasNoBinding v = idArity v == 0 - | otherwise = True +exprIsTrivial (Var v) = True exprIsTrivial (Type _) = True exprIsTrivial (Lit lit) = True exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e @@ -369,7 +436,7 @@ corePrepExprFloat env expr@(App _ _) -- non-variable fun, better let-bind it collect_args fun depth = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') -> - newVar ty (exprArity fun') `thenUs` \ fn_id -> + newVar ty `thenUs` \ fn_id -> mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats -> returnUs (Var fn_id, (Var fn_id, depth), ty, floats, []) where @@ -444,6 +511,10 @@ mkLocalNonRec bndr dem floats rhs = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') -> returnUs (floats' `snocOL` FloatLet (NonRec bndr rhs')) + where + bndr_ty = idType bndr + bndr_rep_ty = repType bndr_ty + mkBinds :: OrdList FloatingBind -> CoreExpr -> UniqSM CoreExpr mkBinds binds body | isNilOL binds = returnUs body @@ -484,7 +555,13 @@ etaExpandRhs bndr rhs -- f = /\a -> \y -> let s = h 3 in g s y -- getUniquesUs `thenUs` \ us -> - returnUs (etaExpand (idArity bndr) us rhs (idType bndr)) + returnUs (etaExpand arity us rhs (idType bndr)) + where + -- For a GlobalId, take the Arity from the Id. + -- It was set in CoreTidy and must not change + -- For all others, just expand at will + arity | isGlobalId bndr = idArity bndr + | otherwise = exprArity rhs -- --------------------------------------------------------------------------- -- Eliminate Lam as a non-rhs (STG doesn't have such a thing) @@ -505,7 +582,7 @@ deLam expr | otherwise = case tryEta bndrs body of Just no_lam_result -> returnUs no_lam_result - Nothing -> newVar (exprType expr) (exprArity expr) `thenUs` \ fn -> + Nothing -> newVar (exprType expr) `thenUs` \ fn -> returnUs (Let (NonRec fn expr) (Var fn)) where (bndrs,body) = collectBinders expr @@ -677,12 +754,9 @@ fiddleCCall id -- Generating new binders -- --------------------------------------------------------------------------- -newVar :: Type -> Arity -> UniqSM Id --- We're creating a new let binder, and we must give --- it the right arity for the benefit of the code generator. -newVar ty arity +newVar :: Type -> UniqSM Id +newVar ty = seqType ty `seq` getUniqueUs `thenUs` \ uniq -> - returnUs (mkSysLocal SLIT("sat") uniq ty - `setIdArity` arity) + returnUs (mkSysLocal SLIT("sat") uniq ty) \end{code} diff --git a/ghc/compiler/coreSyn/CoreTidy.lhs b/ghc/compiler/coreSyn/CoreTidy.lhs index 4e1a4d5..bc3dd71 100644 --- a/ghc/compiler/coreSyn/CoreTidy.lhs +++ b/ghc/compiler/coreSyn/CoreTidy.lhs @@ -21,11 +21,9 @@ import VarEnv import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, isExportedId, - idSpecialisation, idUnique, isDataConWrapId, - mkVanillaGlobal, mkGlobalId, isLocalId, - isDataConId, mkUserLocal, isGlobalId, globalIdDetails, - idNewDemandInfo, setIdNewDemandInfo, setIdCgInfo, - idNewStrictness, setIdNewStrictness + idSpecialisation, idUnique, + mkVanillaGlobal, isLocalId, + isImplicitId, mkUserLocal, setIdInfo ) import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig ) @@ -40,7 +38,7 @@ import Module ( Module, moduleName ) import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ), NameSupply( nsNames, nsUniqs ), - TypeEnv, extendTypeEnvList, + TypeEnv, extendTypeEnvList, typeEnvIds, ModDetails(..), TyThing(..) ) import FiniteMap ( lookupFM, addToFM ) @@ -151,11 +149,18 @@ tidyCorePgm dflags mod pcs cg_info_env orig_ns = prsOrig prs init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in, - isGlobalName (idName bndr)] + avoids = [getOccName name | bndr <- typeEnvIds env_tc, + let name = idName bndr, + isGlobalName name] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. ; let ((orig_ns', occ_env, subst_env), tidy_binds) - = mapAccumL (tidyTopBind mod ext_ids) + = mapAccumL (tidyTopBind mod ext_ids cg_info_env) init_tidy_env binds_in ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules @@ -163,7 +168,7 @@ tidyCorePgm dflags mod pcs cg_info_env ; let prs' = prs { prsOrig = orig_ns' } pcs' = pcs { pcs_PRS = prs' } - ; let final_ids = [ addCgInfo cg_info_env id + ; let final_ids = [ id | bind <- tidy_binds , id <- bindersOf bind , isGlobalName (idName id)] @@ -190,16 +195,6 @@ tidyCorePgm dflags mod pcs cg_info_env ; return (pcs', tidy_details) } -addCgInfo :: CgInfoEnv -> Id -> Id --- Pin on the info that comes from the code generator --- This doesn't make its way into the *bindings* that --- go on to the code generator (that might give black holes etc) --- Rather, it's pinned onto the Id in the type environment --- that (a) generates the interface file --- (b) in GHCi goes into subsequent compilations -addCgInfo cg_info_env id - = id `setIdCgInfo` lookupCgInfo cg_info_env (idName id) - tidyCoreExpr :: CoreExpr -> IO CoreExpr tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) \end{code} @@ -235,9 +230,9 @@ mkFinalTypeEnv type_env final_ids -- in interface files, because they are needed by importing modules when -- using the compilation manager - -- We keep constructor workers, - -- because they won't appear in the bindings from which final_ids are derived! - keep_it (AnId id) = isDataConId id -- Remove all Ids except constructor workers + -- We keep implicit Ids, because they won't appear + -- in the bindings from which final_ids are derived! + keep_it (AnId id) = isImplicitId id -- Remove all Ids except implicit ones keep_it other = True -- Keep all TyCons and Classes \end{code} @@ -386,18 +381,20 @@ type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var) tidyTopBind :: Module -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too + -> CgInfoEnv -> TopTidyEnv -> CoreBind -> (TopTidyEnv, CoreBind) -tidyTopBind mod ext_ids top_tidy_env (NonRec bndr rhs) +tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs) = ((orig,occ,subst) , NonRec bndr' rhs') where ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids rec_tidy_env rhs' top_tidy_env bndr + = tidyTopBinder mod ext_ids cg_info_env + rec_tidy_env rhs' top_tidy_env bndr rec_tidy_env = (occ,subst) rhs' = tidyExpr rec_tidy_env rhs -tidyTopBind mod ext_ids top_tidy_env (Rec prs) +tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs) = (final_env, Rec prs') where (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs @@ -407,12 +404,12 @@ tidyTopBind mod ext_ids top_tidy_env (Rec prs) = ((orig,occ,subst), (bndr',rhs')) where ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids + = tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs' top_tidy_env bndr rhs' = tidyExpr rec_tidy_env rhs -tidyTopBinder :: Module -> IdEnv Bool +tidyTopBinder :: Module -> IdEnv Bool -> CgInfoEnv -> TidyEnv -> CoreExpr -- The TidyEnv is used to tidy the IdInfo -- The expr is the already-tided RHS @@ -420,34 +417,10 @@ tidyTopBinder :: Module -> IdEnv Bool -> TopTidyEnv -> Id -> (TopTidyEnv, Id) -- NB: tidyTopBinder doesn't affect the unique supply -tidyTopBinder mod ext_ids tidy_env rhs +tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs env@(ns2, occ_env2, subst_env2) id - - | isDataConWrapId id -- Don't tidy constructor wrappers - = (env, id) -- The Id is stored in the TyCon, so it would be bad - -- if anything changed - --- HACK ALERT: we *do* tidy record selectors. Reason: they mention error --- messages, which may be floated out: --- x_field pt = case pt of --- Rect x y -> y --- Pol _ _ -> error "buggle wuggle" --- The error message will be floated out so we'll get --- lvl5 = error "buggle wuggle" --- x_field pt = case pt of --- Rect x y -> y --- Pol _ _ -> lvl5 --- --- When this happens, it's vital that the Id exposed to importing modules --- (by ghci) mentions lvl5 in its unfolding, not the un-tidied version. --- --- What about the Id in the TyCon? It probably shouldn't be in the TyCon at --- all, but in any case it will have the error message inline so it won't matter. - - - | otherwise -- This function is the heart of Step 2 - -- The second env is the one to use for the IdInfo + -- The rec_tidy_env is the one to use for the IdInfo -- It's necessary because when we are dealing with a recursive -- group, a variable late in the group might be mentioned -- in the IdInfo of one early in the group @@ -459,13 +432,12 @@ tidyTopBinder mod ext_ids tidy_env rhs (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2 is_external (idName id) - ty' = tidyTopType (idType id) - idinfo' = tidyIdInfo tidy_env is_external unfold_info id + ty' = tidyTopType (idType id) + idinfo = tidyTopIdInfo rec_tidy_env is_external + (idInfo id) unfold_info + (lookupCgInfo cg_info_env name') - id' | isGlobalId id = mkGlobalId (globalIdDetails id) name' ty' idinfo' - | otherwise = mkVanillaGlobal name' ty' idinfo' - -- The test ensures that record selectors (which must be tidied; see above) - -- retain their details. If it's forgotten, importing modules get confused. + id' = mkVanillaGlobal name' ty' idinfo subst_env' = extendVarEnv subst_env2 id id' @@ -478,26 +450,46 @@ tidyTopBinder mod ext_ids tidy_env rhs | otherwise = noUnfolding -tidyIdInfo tidy_env is_external unfold_info id +-- tidyTopIdInfo creates the final IdInfo for top-level +-- binders. There are two delicate pieces: +-- +-- * Arity. We assume that the simplifier has just run, so +-- that there is a reasonable arity on each binder. +-- After CoreTidy, this arity must not change any more. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. +-- +-- * CAF info, which comes from the CoreToStg pass via a knot. +-- The CAF info will not be looked at by the downstream stuff: +-- it *generates* it, and knot-ties it back. It will only be +-- looked at by (a) MkIface when generating an interface file +-- (b) In GHCi, importing modules +-- Nevertheless, we add the info here so that it propagates to all +-- occurrences of the binders in RHSs, and hence to occurrences in +-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. +-- +-- An alterative would be to do a second pass over the unfoldings +-- of Ids, and rules, right at the top, but that would be a pain. + +tidyTopIdInfo tidy_env is_external idinfo unfold_info cg_info | opt_OmitInterfacePragmas || not is_external - -- No IdInfo if the Id isn't external, or if we don't have -O - = vanillaIdInfo - `setArityInfo` arityInfo core_idinfo - `setNewStrictnessInfo` newStrictnessInfo core_idinfo - -- Keep strictness and arity; both are used by CorePrep + -- Only basic info if the Id isn't external, or if we don't have -O + = basic_info - | otherwise - = vanillaIdInfo - `setArityInfo` arityInfo core_idinfo - `setNewStrictnessInfo` newStrictnessInfo core_idinfo - `setInlinePragInfo` inlinePragInfo core_idinfo + | otherwise -- Add extra optimisation info + = basic_info + `setInlinePragInfo` inlinePragInfo idinfo `setUnfoldingInfo` unfold_info - `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo) - -- NB: we throw away the Rules - -- They have already been extracted by findExternalRules + `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo) + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules + where - core_idinfo = idInfo id - + -- baasic_info is attached to every top-level binder + basic_info = vanillaIdInfo + `setCgInfo` cg_info + `setArityInfo` arityInfo idinfo + `setNewStrictnessInfo` newStrictnessInfo idinfo -- This is where we set names to local/global based on whether they really are -- externally visible (see comment at the top of this module). If the name @@ -523,7 +515,9 @@ tidyTopName mod ns occ_env external name Nothing -> (ns { nsUniqs = us2, nsNames = ns_names' }, occ_env', global_name) -- If we want to globalise a currently-local name, check -- whether we have already assigned a unique for it. - -- If so, use it; if not, extend the table + -- If so, use it; if not, extend the table. + -- This is needed when *re*-compiling a module in GHCi; we want to + -- use the same name for externally-visible things as we did before. where global = isGlobalName name @@ -647,8 +641,14 @@ tidyLetBndr env (id,rhs) -- -- Similarly for the demand info - on a let binder, this tells -- CorePrep to turn the let into a case. - final_id = new_id `setIdNewDemandInfo` idNewDemandInfo id - `setIdNewStrictness` idNewStrictness id + -- + -- Similarly arity info for eta expansion in CorePrep + final_id = new_id `setIdInfo` new_info + idinfo = idInfo id + new_info = vanillaIdInfo + `setArityInfo` arityInfo idinfo + `setNewStrictnessInfo` newStrictnessInfo idinfo + `setNewDemandInfo` newDemandInfo idinfo -- Override the env we get back from tidyId with the new IdInfo -- so it gets propagated to the usage sites. @@ -662,8 +662,8 @@ tidyIdBndr env@(tidy_env, var_env) id -- The SrcLoc isn't important now, -- though we could extract it from the Id -- - -- All local Ids now have the same IdInfo, which should save some - -- space. + -- All nested Ids now have the same IdInfo, namely none, + -- which should save some space. (tidy_env', occ') = tidyOccName tidy_env (getOccName id) ty' = tidyType env (idType id) id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index c8f800f..21bb2bf 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -19,10 +19,11 @@ module CoreUtils ( exprIsValue,exprOkForSpeculation, exprIsBig, exprIsConApp_maybe, exprIsAtom, idAppIsBottom, idAppIsCheap, - exprArity, - -- Expr transformation - etaExpand, exprArity, exprEtaExpandArity, + + -- Arity and eta expansion + manifestArity, exprArity, + exprEtaExpandArity, etaExpand, -- Size coreBindsSize, @@ -49,7 +50,7 @@ import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, import PrimOp ( primOpOkForSpeculation, primOpIsCheap ) import Id ( Id, idType, globalIdDetails, idNewStrictness, idLBVarInfo, mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda, - isDataConId_maybe, mkSysLocal, hasNoBinding, isDataConId, isBottomingId + isDataConId_maybe, mkSysLocal, isDataConId, isBottomingId ) import IdInfo ( LBVarInfo(..), GlobalIdDetails(..), @@ -298,26 +299,25 @@ findAlt con alts @exprIsBottom@ is true of expressions that are guaranteed to diverge +There used to be a gruesome test for (hasNoBinding v) in the +Var case: + exprIsTrivial (Var v) | hasNoBinding v = idArity v == 0 +The idea here is that a constructor worker, like $wJust, is +really short for (\x -> $wJust x), becuase $wJust has no binding. +So it should be treated like a lambda. Ditto unsaturated primops. +But now constructor workers are not "have-no-binding" Ids. And +completely un-applied primops and foreign-call Ids are sufficiently +rare that I plan to allow them to be duplicated and put up with +saturating them. + \begin{code} -exprIsTrivial (Var v) - | hasNoBinding v = idArity v == 0 - -- WAS: | Just op <- isPrimOpId_maybe v = primOpIsDupable op - -- The idea here is that a constructor worker, like $wJust, is - -- really short for (\x -> $wJust x), becuase $wJust has no binding. - -- So it should be treated like a lambda. - -- Ditto unsaturated primops. - -- This came up when dealing with eta expansion/reduction for - -- x = $wJust - -- Here we want to eta-expand. This looks like an optimisation, - -- but it's important (albeit tiresome) that CoreSat doesn't increase - -- anything's arity - | otherwise = True -exprIsTrivial (Type _) = True -exprIsTrivial (Lit lit) = True -exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e -exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body -exprIsTrivial other = False +exprIsTrivial (Var v) = True -- See notes above +exprIsTrivial (Type _) = True +exprIsTrivial (Lit lit) = True +exprIsTrivial (App e arg) = not (isRuntimeArg arg) && exprIsTrivial e +exprIsTrivial (Note _ e) = exprIsTrivial e +exprIsTrivial (Lam b body) = not (isRuntimeVar b) && exprIsTrivial body +exprIsTrivial other = False exprIsAtom :: CoreExpr -> Bool -- Used to decide whether to let-binding an STG argument diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index 5da7b8d..0a95cec 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -435,19 +435,14 @@ myCoreToStg dflags this_mod tidy_binds <- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds let env_rhs :: CgInfoEnv - env_rhs = mkNameEnv [ (idName bndr, CgInfo (stgRhsArity rhs) caf_info) + env_rhs = mkNameEnv [ (idName bndr, CgInfo caf_info) | (bind,_) <- stg_binds2, let caf_info | stgBindHasCafRefs bind = MayHaveCafRefs - | otherwise = NoCafRefs, - (bndr,rhs) <- stgBindPairs bind ] + | otherwise = NoCafRefs, + bndr <- stgBinders bind ] return (stg_binds2, cost_centre_info, env_rhs) - where - stgBindPairs (StgNonRec _ b r) = [(b,r)] - stgBindPairs (StgRec _ prs) = prs - - \end{code} diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 3c76b60..c29421c 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -26,7 +26,7 @@ module HscTypes ( TypeEnv, lookupType, mkTypeEnv, emptyTypeEnv, extendTypeEnvList, extendTypeEnvWithIds, - typeEnvClasses, typeEnvTyCons, typeEnvIds, + typeEnvElts, typeEnvClasses, typeEnvTyCons, typeEnvIds, ImportedModuleInfo, WhetherHasOrphans, ImportVersion, WhatsImported(..), PersistentRenamerState(..), IsBootInterface, DeclsMap, @@ -64,7 +64,7 @@ import Rules ( RuleBase ) import CoreSyn ( CoreBind ) import Id ( Id ) import Class ( Class, classSelIds ) -import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) +import TyCon ( TyCon, isNewTyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable ) import DataCon ( dataConId, dataConWrapId ) import BasicTypes ( Version, initialVersion, Fixity ) @@ -189,7 +189,7 @@ data ModDetails -- The ModDetails takes on several slightly different forms: -- -- After typecheck + desugar --- md_types Contains TyCons, Classes, and hasNoBinding Ids +-- md_types Contains TyCons, Classes, and implicit Ids -- md_insts All instances from this module (incl derived ones) -- md_rules All rules from this module -- md_binds Desugared bindings @@ -317,9 +317,16 @@ instance Outputable TyThing where ppr (ATyCon tc) = ptext SLIT("ATyCon") <+> ppr tc ppr (AClass cl) = ptext SLIT("AClass") <+> ppr cl -typeEnvClasses env = [cl | AClass cl <- nameEnvElts env] -typeEnvTyCons env = [tc | ATyCon tc <- nameEnvElts env] -typeEnvIds env = [id | AnId id <- nameEnvElts env] + +typeEnvElts :: TypeEnv -> [TyThing] +typeEnvClasses :: TypeEnv -> [Class] +typeEnvTyCons :: TypeEnv -> [TyCon] +typeEnvIds :: TypeEnv -> [Id] + +typeEnvElts env = nameEnvElts env +typeEnvClasses env = [cl | AClass cl <- typeEnvElts env] +typeEnvTyCons env = [tc | ATyCon tc <- typeEnvElts env] +typeEnvIds env = [id | AnId id <- typeEnvElts env] implicitTyThingIds :: [TyThing] -> [Id] -- Add the implicit data cons and selectors etc @@ -331,8 +338,13 @@ implicitTyThingIds things go (ATyCon tc) = tyConGenIds tc ++ tyConSelIds tc ++ [ n | dc <- tyConDataConsIfAvailable tc, - n <- [dataConId dc, dataConWrapId dc] ] + n <- implicitConIds tc dc] -- Synonyms return empty list of constructors and selectors + + implicitConIds tc dc -- Newtypes have a constructor wrapper, + -- but no worker + | isNewTyCon tc = [dataConWrapId dc] + | otherwise = [dataConId dc, dataConWrapId dc] \end{code} diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 4f24901..734f64b 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -29,7 +29,7 @@ import HscTypes ( VersionInfo(..), ModIface(..), ModDetails(..), TyThing(..), DFunId, Avails, WhatsImported(..), GenAvailInfo(..), ImportVersion, AvailInfo, Deprecations(..), - lookupVersion, + lookupVersion, typeEnvIds ) import CmdLineOpts @@ -256,7 +256,7 @@ ifaceTyThing (AnId id) = iface_sig id_type = idType id id_info = idInfo id cg_info = idCgInfo id - arity_info = cgArity cg_info + arity_info = arityInfo id_info caf_info = cgCafInfo cg_info hs_idinfo | opt_OmitInterfacePragmas = [] @@ -452,7 +452,7 @@ pprModDetails (ModDetails { md_types = type_env, md_insts = dfun_ids, md_rules = dump_types dfun_ids type_env = text "TYPE SIGNATURES" $$ nest 4 (dump_sigs ids) where - ids = [id | AnId id <- nameEnvElts type_env, want_sig id] + ids = [id | id <- typeEnvIds type_env, want_sig id] want_sig id | opt_PprStyle_Debug = True | otherwise = isLocalId id && isGlobalName (idName id) && diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index 5ed34a4..f5fb7c9 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -31,7 +31,7 @@ import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) import CoreLint ( endPass ) import FloatIn ( floatInwards ) import FloatOut ( floatOutwards ) -import Id ( idName, setIdLocalExported, isImplicitId ) +import Id ( idName, setIdLocalExported ) import VarSet import LiberateCase ( liberateCase ) import SAT ( doStaticArgs ) @@ -282,12 +282,6 @@ updateBinders rule_ids rule_rhs_fvs is_exported binds update_bndrs (Rec prs) = Rec [(update_bndr b, r) | (b,r) <- prs] update_bndr bndr - | isImplicitId bndr = bndr_with_rules - -- Constructors, selectors; doesn't - -- make sense to call setIdLocalExported - -- They can have rules, though; e.g. - -- class Foo a where { op :: a->a } - -- {-# RULES op x = y #-} | dont_discard bndr = setIdLocalExported bndr_with_rules | otherwise = bndr_with_rules where diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 4d68228..ffeb43c 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -5,8 +5,8 @@ \begin{code} module SimplUtils ( - simplBinder, simplBinders, simplRecBndrs, simplLetBndr, - simplLamBndrs, simplTopBndrs, + simplBinder, simplBinders, simplRecBndrs, + simplLetBndr, simplLamBndrs, newId, mkLam, mkCase, -- The continuation type @@ -30,8 +30,8 @@ import CoreUtils ( cheapEqExpr, exprType, findDefault, exprOkForSpeculation, exprIsValue ) import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr ) -import Id ( Id, idType, idInfo, isLocalId, - mkSysLocal, hasNoBinding, isDeadBinder, idNewDemandInfo, +import Id ( Id, idType, idInfo, + mkSysLocal, isDeadBinder, idNewDemandInfo, idUnfolding, idNewStrictness ) import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) @@ -447,26 +447,11 @@ simplLetBndr env id seqBndr id' `seq` returnSmpl (setSubst env subst', id') -simplTopBndrs, simplLamBndrs, simplRecBndrs +simplLamBndrs, simplRecBndrs :: SimplEnv -> [InBinder] -> SimplM (SimplEnv, [OutBinder]) -simplTopBndrs = simplBndrs simplTopBinder simplRecBndrs = simplBndrs Subst.simplLetId simplLamBndrs = simplBndrs Subst.simplLamBndr --- For top-level binders, don't use simplLetId for GlobalIds. --- There are some of these, notably consructor wrappers, and we don't --- want to clone them or fiddle with them at all. --- Rather tiresomely, the specialiser may float a use of a constructor --- wrapper to before its definition (which shouldn't really matter) --- because it doesn't see the constructor wrapper as free in the binding --- it is floating (because it's a GlobalId). --- Then the simplifier brings all top level Ids into scope at the --- beginning, and we don't want to lose the IdInfo on the constructor --- wrappers. It would also be Bad to clone it! -simplTopBinder subst bndr - | isLocalId bndr = Subst.simplLetId subst bndr - | otherwise = (subst, bndr) - simplBndrs simpl_bndr env bndrs = let (subst', bndrs') = mapAccumL simpl_bndr (getSubst env) bndrs @@ -561,9 +546,7 @@ tryEtaReduce bndrs body go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success! go _ _ = Nothing -- Failure! - ok_fun fun = not (fun `elem` bndrs) && not (hasNoBinding fun) - -- Note the awkward "hasNoBinding" test - -- Details with exprIsTrivial + ok_fun fun = not (fun `elem` bndrs) ok_arg b arg = varToCoreExpr b `cheapEqExpr` arg \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 09b8cb0..88e6348 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -14,7 +14,7 @@ import CmdLineOpts ( dopt, DynFlag(Opt_D_dump_inlinings), import SimplMonad import SimplUtils ( mkCase, mkLam, newId, simplBinder, simplBinders, simplLamBndrs, simplRecBndrs, simplLetBndr, - simplTopBndrs, SimplCont(..), DupFlag(..), LetRhsFlag(..), + SimplCont(..), DupFlag(..), LetRhsFlag(..), mkStop, mkBoringStop, pushContArgs, contResultType, countArgs, contIsDupable, contIsRhsOrArg, getContArgs, interestingCallContext, interestingArg, isStrictType @@ -24,8 +24,7 @@ import VarEnv import Id ( Id, idType, idInfo, idArity, isDataConId, idUnfolding, setIdUnfolding, isDeadBinder, idNewDemandInfo, setIdInfo, - setIdOccInfo, isLocalId, - zapLamIdInfo, setOneShotLambda, + setIdOccInfo, zapLamIdInfo, setOneShotLambda, ) import IdInfo ( OccInfo(..), isLoopBreaker, setArityInfo, @@ -38,9 +37,9 @@ import CoreSyn import PprCore ( pprParendExpr, pprCoreExpr ) import CoreUnfold ( mkOtherCon, mkUnfolding, otherCons, callSiteInline ) import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding, - exprIsConApp_maybe, mkPiType, findAlt, findDefault, + exprIsConApp_maybe, mkPiType, findAlt, exprType, coreAltsType, exprIsValue, - exprOkForSpeculation, exprArity, + exprOkForSpeculation, exprArity, findDefault, mkCoerce, mkSCC, mkInlineMe, mkAltExpr ) import Rules ( lookupRule ) @@ -54,7 +53,7 @@ import Subst ( mkSubst, substTy, substExpr, ) import TysPrim ( realWorldStatePrimTy ) import PrelInfo ( realWorldPrimId ) -import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, +import BasicTypes ( TopLevelFlag(..), isTopLevel, RecFlag(..), isNonRec ) import OrdList @@ -230,7 +229,7 @@ simplTopBinds env binds -- so that if a transformation rule has unexpectedly brought -- anything into scope, then we don't get a complaint about that. -- It's rather as if the top-level binders were imported. - simplTopBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> + simplRecBndrs env (bindersOfBinds binds) `thenSmpl` \ (env, bndrs') -> simpl_binds env binds bndrs' `thenSmpl` \ (floats, _) -> freeTick SimplifierDone `thenSmpl_` returnSmpl (floatBinds floats) @@ -442,11 +441,12 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- -- NB: does no harm for non-recursive bindings let + is_top_level = isTopLevel top_lvl bndr_ty' = idType bndr' bndr'' = simplIdInfo (getSubst rhs_se) (idInfo bndr) bndr' env1 = modifyInScope env bndr'' bndr'' rhs_env = setInScope rhs_se env1 - ok_float_unlifted = isNotTopLevel top_lvl && isNonRec is_rec + ok_float_unlifted = not is_top_level && isNonRec is_rec rhs_cont = mkStop bndr_ty' AnRhs in -- Simplify the RHS; note the mkStop, which tells @@ -481,7 +481,8 @@ simplLazyBind env top_lvl is_rec bndr bndr' rhs rhs_se -- Either we must be careful not to float demanded non-values, or -- we must use exprIsValue for the test, which ensures that the -- thing is non-strict. I think. The WARN below tests for this. - else if exprIsTrivial rhs2 || exprIsValue rhs2 then + else if is_top_level || exprIsTrivial rhs2 || exprIsValue rhs2 then + -- There's a subtlety here. There may be a binding (x* = e) in the -- floats, where the '*' means 'will be demanded'. So is it safe -- to float it out? Answer no, but it won't matter because diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index da043d0..c99c76f 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -176,7 +176,7 @@ coreTopBindToStg env body_fvs (NonRec id rhs) = let caf_info = hasCafRefs env rhs env' = extendVarEnv env id how_bound - how_bound = LetBound (TopLet caf_info) (predictArity rhs) + how_bound = LetBound (TopLet caf_info) (manifestArity rhs) (stg_rhs, fvs', lv_info) = initLne env ( @@ -187,7 +187,8 @@ coreTopBindToStg env body_fvs (NonRec id rhs) bind = StgNonRec (mkSRT lv_info) id stg_rhs in - ASSERT2(predictArity rhs == stgRhsArity stg_rhs, ppr id) + ASSERT2(isLocalId id || idArity id == manifestArity rhs, ppr id) + ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id) ASSERT2(consistent caf_info bind, ppr id) -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) @@ -205,7 +206,7 @@ coreTopBindToStg env body_fvs (Rec pairs) caf_info = hasCafRefss env1{-NB: not env'-} rhss env' = extendVarEnvList env - [ (b, LetBound (TopLet caf_info) (predictArity rhs)) + [ (b, LetBound (TopLet caf_info) (manifestArity rhs)) | (b,rhs) <- pairs ] (stg_rhss, fvs', lv_info) @@ -219,7 +220,8 @@ coreTopBindToStg env body_fvs (Rec pairs) bind = StgRec (mkSRT lv_info) (zip binders stg_rhss) in - ASSERT2(and [predictArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) + ASSERT2(and [isLocalId bndr || manifestArity rhs == idArity bndr | (bndr,rhs) <- pairs], ppr binders) + ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) ASSERT2(consistent caf_info bind, ppr binders) -- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) @@ -678,7 +680,7 @@ coreToStgLet let_no_escape bind body binders = bindersOf bind mk_binding bind_lv_info binder rhs - = (binder, LetBound (NestedLet live_vars) (predictArity rhs)) + = (binder, LetBound (NestedLet live_vars) (manifestArity rhs)) where live_vars | let_no_escape = addLiveVar bind_lv_info binder | otherwise = unitLiveVar binder @@ -734,28 +736,6 @@ is_join_var :: Id -> Bool is_join_var j = occNameUserString (getOccName j) == "$j" \end{code} -%************************************************************************ -%* * -\subsection{Arity prediction} -%* * -%************************************************************************ - -To avoid yet another knot, we predict the arity of each function from -its Core form, based on the number of visible top-level lambdas. -It should be the same as the arity of the STG RHS! - -\begin{code} -predictArity :: CoreExpr -> Int -predictArity (Lam x e) - | isTyVar x = predictArity e - | otherwise = 1 + predictArity e -predictArity (Note _ e) - -- Ignore coercions. Top level sccs are removed by the final - -- profiling pass, so we ignore those too. - = predictArity e -predictArity _ = 0 -\end{code} - %************************************************************************ %* * diff --git a/ghc/compiler/stranal/DmdAnal.lhs b/ghc/compiler/stranal/DmdAnal.lhs index 17775e7..11071d4 100644 --- a/ghc/compiler/stranal/DmdAnal.lhs +++ b/ghc/compiler/stranal/DmdAnal.lhs @@ -20,8 +20,8 @@ import PprCore import CoreUtils ( exprIsValue, exprArity ) import DataCon ( dataConTyCon ) import TyCon ( isProductTyCon, isRecursiveTyCon ) -import Id ( Id, idType, idDemandInfo, idArity, - isDataConId, isImplicitId, isGlobalId, +import Id ( Id, idType, idDemandInfo, + isDataConId, isGlobalId, idArity, idNewStrictness, idNewStrictness_maybe, getNewStrictness, setIdNewStrictness, idNewDemandInfo, setIdNewDemandInfo, newStrictnessFromOld ) import IdInfo ( newDemand ) @@ -78,9 +78,6 @@ dmdAnalTopBind :: SigEnv -> CoreBind -> (SigEnv, CoreBind) dmdAnalTopBind sigs (NonRec id rhs) - | isImplicitId id -- Don't touch the info on constructors, selectors etc - = (sigs, NonRec id rhs) -- It's pre-computed in MkId.lhs - | otherwise = let (sigs', _, (id', rhs')) = dmdAnalRhs TopLevel sigs (id, rhs) in @@ -161,7 +158,7 @@ dmdAnal sigs dmd (App fun (Type ty)) -- Lots of the other code is there to make this -- beautiful, compositional, application rule :-) -dmdAnal sigs dmd (App fun arg) -- Non-type arguments +dmdAnal sigs dmd e@(App fun arg) -- Non-type arguments = let -- [Type arg handled above] (fun_ty, fun') = dmdAnal sigs (Call dmd) fun (arg_ty, arg') = dmdAnal sigs arg_dmd arg @@ -475,7 +472,7 @@ splitDmdTy (DmdType fv (dmd:dmds) res_ty) = (dmd, DmdType fv dmds res_ty) splitDmdTy ty@(DmdType fv [] TopRes) = (Lazy, ty) splitDmdTy ty@(DmdType fv [] BotRes) = (Bot, ty) -- NB: Bot not Abs -splitDmdTy (DmdType fv [] RetCPR) = panic "splitDmdTy" +splitDmdTy ty@(DmdType fv [] RetCPR) = panic "splitDmdTy" -- We should not be applying a product as a function! \end{code} @@ -909,8 +906,7 @@ get_changes_bind (Rec pairs) = vcat (map get_changes_pr pairs) get_changes_bind (NonRec id rhs) = get_changes_pr (id,rhs) get_changes_pr (id,rhs) - | isImplicitId id = empty -- We don't look inside these - | otherwise = get_changes_var id $$ get_changes_expr rhs + = get_changes_var id $$ get_changes_expr rhs get_changes_var var | isId var = get_changes_str var $$ get_changes_dmd var diff --git a/ghc/compiler/typecheck/TcIfaceSig.lhs b/ghc/compiler/typecheck/TcIfaceSig.lhs index d6aefcd..cc7d9b6 100644 --- a/ghc/compiler/typecheck/TcIfaceSig.lhs +++ b/ghc/compiler/typecheck/TcIfaceSig.lhs @@ -88,8 +88,7 @@ tcIdInfo unf_env in_scope_vars name ty info_ins tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs) tcPrag info (HsArity arity) = - returnTc (info `setArityInfo` arity - `setCgArity` arity) + returnTc (info `setArityInfo` arity) tcPrag info (HsUnfold inline_prag expr) = tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' -> diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 53fff48..e799f09 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -61,7 +61,7 @@ import ErrUtils ( printErrorsAndWarnings, errorsFound, import Id ( Id, idType, idUnfolding ) import Module ( Module, moduleName ) import Name ( Name ) -import NameEnv ( nameEnvElts, lookupNameEnv ) +import NameEnv ( lookupNameEnv ) import TyCon ( tyConGenInfo ) import BasicTypes ( EP(..), Fixity, RecFlag(..) ) import SrcLoc ( noSrcLoc ) @@ -70,8 +70,8 @@ import IO ( stdout ) import HscTypes ( PersistentCompilerState(..), HomeSymbolTable, PackageTypeEnv, ModIface(..), ModDetails(..), DFunId, - TypeEnv, extendTypeEnvList, - TyThing(..), implicitTyThingIds, + TypeEnv, extendTypeEnvList, typeEnvTyCons, typeEnvElts, + TyThing(..), mkTypeEnv ) \end{code} @@ -447,17 +447,7 @@ tcModule pcs hst get_fixity this_mod decls zonkRules more_local_rules `thenNF_Tc` \ more_local_rules' -> - let local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv final_env)) - - -- Create any necessary "implicit" bindings (data constructors etc) - -- Should we create bindings for dictionary constructors? - -- They are always fully applied, and the bindings are just there - -- to support partial applications. But it's easier to let them through. - implicit_binds = andMonoBindList [ CoreMonoBind id (unfoldingTemplate unf) - | id <- implicitTyThingIds local_things - , let unf = idUnfolding id - , hasUnfolding unf - ] + let local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv final_env)) local_type_env :: TypeEnv local_type_env = mkTypeEnv local_things @@ -469,7 +459,7 @@ tcModule pcs hst get_fixity this_mod decls new_pcs, TcResults { tc_env = local_type_env, tc_insts = map iDFunId local_insts, - tc_binds = implicit_binds `AndMonoBinds` all_binds', + tc_binds = all_binds', tc_fords = foi_decls ++ foe_decls', tc_rules = all_local_rules } @@ -519,7 +509,7 @@ typecheckIface dflags pcs hst mod_iface decls deriv_binds, local_rules) -> ASSERT(nullBinds deriv_binds) let - local_things = filter (isLocalThing this_mod) (nameEnvElts (getTcGEnv env)) + local_things = filter (isLocalThing this_mod) (typeEnvElts (getTcGEnv env)) mod_details = ModDetails { md_types = mkTypeEnv local_things, md_insts = map iDFunId local_inst_info, @@ -587,7 +577,7 @@ tcImports unf_env pcs hst get_fixity this_mod decls tcGetEnv `thenTc` \ unf_env -> let - all_things = nameEnvElts (getTcGEnv unf_env) + all_things = typeEnvElts (getTcGEnv unf_env) -- sometimes we're compiling in the context of a package module -- (on the GHCi command line, for example). In this case, we @@ -722,7 +712,7 @@ dump_tc_iface dflags results ppr_rules (tc_rules results), if dopt Opt_Generics dflags then - ppr_gen_tycons [tc | ATyCon tc <- nameEnvElts (tc_env results)] + ppr_gen_tycons (typeEnvTyCons (tc_env results)) else empty ] -- 1.7.10.4