X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;h=e5165f0ebe98ed34e3aa052a04f5b7d167d58c65;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=925a51f6acf03d0c5f660d5f7dfbe774dc816766;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 925a51f..e5165f0 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -10,22 +10,24 @@ module CorePrep ( #include "HsVersions.h" -import CoreUtils( exprType, exprIsValue, etaExpand, exprArity, exprOkForSpeculation ) +import CoreUtils( exprType, exprIsHNF, etaExpand, exprArity, exprOkForSpeculation ) import CoreFVs ( exprFreeVars ) import CoreLint ( endPass ) import CoreSyn import Type ( Type, applyTy, splitFunTy_maybe, isUnLiftedType, isUnboxedTupleType, seqType ) +import TyCon ( TyCon, tyConDataCons ) import NewDemand ( Demand, isStrictDmd, lazyDmd, StrictSig(..), DmdType(..) ) import Var ( Var, Id, setVarUnique ) import VarSet import VarEnv -import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, - isFCallId, isGlobalId, isImplicitId, +import Id ( mkSysLocal, idType, idNewDemandInfo, idArity, setIdUnfolding, setIdType, + isFCallId, isGlobalId, isLocalId, hasNoBinding, idNewStrictness, - idUnfolding, isDataConWorkId_maybe + isPrimOpId_maybe ) -import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) ) +import DataCon ( isVanillaDataCon, dataConWorkId ) +import PrimOp ( PrimOp( DataToTagOp ) ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -33,7 +35,7 @@ import UniqSupply import Maybes import OrdList import ErrUtils -import CmdLineOpts +import DynFlags import Util ( listLengthCmp ) import Outputable \end{code} @@ -96,12 +98,12 @@ any trivial or useless bindings. -- ----------------------------------------------------------------------------- \begin{code} -corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind] -corePrepPgm dflags binds types +corePrepPgm :: DynFlags -> [CoreBind] -> [TyCon] -> IO [CoreBind] +corePrepPgm dflags binds data_tycons = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let implicit_binds = mkImplicitBinds types + let implicit_binds = mkDataConWorkers data_tycons -- NB: we must feed mkImplicitBinds through corePrep too -- so that they are suitably cloned and eta-expanded @@ -118,7 +120,7 @@ corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr corePrepExpr dflags expr = do showPass dflags "CorePrep" us <- mkSplitUniqSupply 's' - let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr) + let new_expr = initUs_ us (corePrepAnExpr emptyCorePrepEnv expr) dumpIfSet_dyn dflags Opt_D_dump_prep "CorePrep" (ppr new_expr) return new_expr @@ -128,16 +130,8 @@ corePrepExpr dflags expr -- 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 +Create any necessary "implicit" bindings for data con workers. We +create the rather strange (non-recursive!) binding $wC = \x y -> $wC x y @@ -152,20 +146,11 @@ 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) - | AnId id <- typeEnvElts type_env, isImplicitId id ] - -- The type environment already contains all the implicit Ids, - -- so we just filter them out - -- - -- 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 - -get_unfolding id -- See notes above - | Just data_con <- isDataConWorkId_maybe id = Var id -- The ice is thin here, but it works - -- CorePrep will eta-expand it - | otherwise = unfoldingTemplate (idUnfolding id) +mkDataConWorkers data_tycons + = [ NonRec id (Var id) -- The ice is thin here, but it works + | tycon <- data_tycons, -- CorePrep will eta-expand it + data_con <- tyConDataCons tycon, + let id = dataConWorkId data_con ] \end{code} @@ -224,8 +209,6 @@ instance Outputable FloatingBind where ppr (FloatLet bind) = text "FloatLet" <+> ppr bind ppr (FloatCase b rhs spec) = text "FloatCase" <+> ppr b <+> ppr spec <+> equals <+> ppr rhs -type CloneEnv = IdEnv Id -- Clone local Ids - deFloatTop :: Floats -> [CoreBind] -- For top level only; we don't expect any FloatCases deFloatTop (Floats _ floats) @@ -237,7 +220,7 @@ deFloatTop (Floats _ floats) allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool allLazy top_lvl is_rec (Floats ok_to_spec _) = case ok_to_spec of - OkToSpec -> True + OkToSpec -> True NotOkToSpec -> False IfUnboxedOk -> isNotTopLevel top_lvl && isNonRec is_rec @@ -247,7 +230,7 @@ allLazy top_lvl is_rec (Floats ok_to_spec _) corePrepTopBinds :: [CoreBind] -> UniqSM Floats corePrepTopBinds binds - = go emptyVarEnv binds + = go emptyCorePrepEnv binds where go env [] = returnUs emptyFloats go env (bind : binds) = corePrepTopBind env bind `thenUs` \ (env', bind') -> @@ -282,7 +265,7 @@ corePrepTopBinds binds -- it looks difficult. -------------------------------- -corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats) +corePrepTopBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) corePrepTopBind env (NonRec bndr rhs) = cloneBndr env bndr `thenUs` \ (env', bndr') -> corePrepRhs TopLevel NonRecursive env (bndr, rhs) `thenUs` \ (floats, rhs') -> @@ -291,21 +274,23 @@ corePrepTopBind env (NonRec bndr rhs) corePrepTopBind env (Rec pairs) = corePrepRecPairs TopLevel env pairs -------------------------------- -corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, Floats) +corePrepBind :: CorePrepEnv -> CoreBind -> UniqSM (CorePrepEnv, Floats) -- This one is used for *local* bindings corePrepBind env (NonRec bndr rhs) = etaExpandRhs bndr rhs `thenUs` \ rhs1 -> corePrepExprFloat env rhs1 `thenUs` \ (floats, rhs2) -> - cloneBndr env bndr `thenUs` \ (env', bndr') -> - mkLocalNonRec bndr' (bdrDem bndr') floats rhs2 `thenUs` \ floats' -> - returnUs (env', floats') + cloneBndr env bndr `thenUs` \ (_, bndr') -> + mkLocalNonRec bndr' (bdrDem bndr) floats rhs2 `thenUs` \ (floats', bndr'') -> + -- We want bndr'' in the envt, because it records + -- the evaluated-ness of the binder + returnUs (extendCorePrepEnv env bndr bndr'', floats') corePrepBind env (Rec pairs) = corePrepRecPairs NotTopLevel env pairs -------------------------------- -corePrepRecPairs :: TopLevelFlag -> CloneEnv +corePrepRecPairs :: TopLevelFlag -> CorePrepEnv -> [(Id,CoreExpr)] -- Recursive bindings - -> UniqSM (CloneEnv, Floats) + -> UniqSM (CorePrepEnv, Floats) -- Used for all recursive bindings, top level and otherwise corePrepRecPairs lvl env pairs = cloneBndrs env (map fst pairs) `thenUs` \ (env', bndrs') -> @@ -318,10 +303,11 @@ corePrepRecPairs lvl env pairs get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 + get b prs2 = pprPanic "corePrepRecPairs" (ppr b) -------------------------------- corePrepRhs :: TopLevelFlag -> RecFlag - -> CloneEnv -> (Id, CoreExpr) + -> CorePrepEnv -> (Id, CoreExpr) -> UniqSM (Floats, CoreExpr) -- Used for top-level bindings, and local recursive bindings corePrepRhs top_lvl is_rec env (bndr, rhs) @@ -335,15 +321,15 @@ corePrepRhs top_lvl is_rec env (bndr, rhs) -- --------------------------------------------------------------------------- -- This is where we arrange that a non-trivial argument is let-bound -corePrepArg :: CloneEnv -> CoreArg -> RhsDemand +corePrepArg :: CorePrepEnv -> CoreArg -> RhsDemand -> UniqSM (Floats, CoreArg) corePrepArg env arg dem = corePrepExprFloat env arg `thenUs` \ (floats, arg') -> if exprIsTrivial arg' then returnUs (floats, arg') else newVar (exprType arg') `thenUs` \ v -> - mkLocalNonRec v dem floats arg' `thenUs` \ floats' -> - returnUs (floats', Var v) + mkLocalNonRec v dem floats arg' `thenUs` \ (floats', v') -> + returnUs (floats', Var v') -- version that doesn't consider an scc annotation to be trivial. exprIsTrivial (Var v) = True @@ -359,13 +345,13 @@ exprIsTrivial other = False -- Dealing with expressions -- --------------------------------------------------------------------------- -corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr +corePrepAnExpr :: CorePrepEnv -> CoreExpr -> UniqSM CoreExpr corePrepAnExpr env expr = corePrepExprFloat env expr `thenUs` \ (floats, expr) -> mkBinds floats expr -corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (Floats, CoreExpr) +corePrepExprFloat :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CoreExpr) -- If -- e ===> (bs, e') -- then @@ -376,9 +362,10 @@ corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (Floats, CoreExpr) corePrepExprFloat env (Var v) = fiddleCCall v `thenUs` \ v1 -> - let v2 = lookupVarEnv env v1 `orElse` v1 in - maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app -> - returnUs (emptyFloats, app) + let + v2 = lookupCorePrepEnv env v1 + in + maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2) corePrepExprFloat env expr@(Type _) = returnUs (emptyFloats, expr) @@ -407,18 +394,23 @@ corePrepExprFloat env expr@(Lam _ _) where (bndrs,body) = collectBinders expr --- gaw 2004 corePrepExprFloat env (Case scrut bndr ty alts) = corePrepExprFloat env scrut `thenUs` \ (floats1, scrut1) -> deLamFloat scrut1 `thenUs` \ (floats2, scrut2) -> - cloneBndr env bndr `thenUs` \ (env', bndr') -> + let + bndr1 = bndr `setIdUnfolding` evaldUnfolding + -- Record that the case binder is evaluated in the alternatives + in + cloneBndr env bndr1 `thenUs` \ (env', bndr2) -> mapUs (sat_alt env') alts `thenUs` \ alts' -> --- gaw 2004 - returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr' ty alts') + returnUs (floats1 `appendFloats` floats2 , Case scrut2 bndr2 ty alts') where sat_alt env (con, bs, rhs) - = cloneBndrs env bs `thenUs` \ (env', bs') -> - corePrepAnExpr env' rhs `thenUs` \ rhs1 -> + = let + env1 = setGadt env con + in + cloneBndrs env1 bs `thenUs` \ (env2, bs') -> + corePrepAnExpr env2 rhs `thenUs` \ rhs1 -> deLam rhs1 `thenUs` \ rhs2 -> returnUs (con, bs', rhs2) @@ -428,9 +420,7 @@ corePrepExprFloat env expr@(App _ _) -- Now deal with the function case head of - Var fn_id -> maybeSaturate fn_id app depth ty `thenUs` \ app' -> - returnUs (floats, app') - + Var fn_id -> maybeSaturate fn_id app depth floats ty _other -> returnUs (floats, app) where @@ -469,7 +459,9 @@ corePrepExprFloat env expr@(App _ _) collect_args (Var v) depth = fiddleCCall v `thenUs` \ v1 -> - let v2 = lookupVarEnv env v1 `orElse` v1 in + let + v2 = lookupCorePrepEnv env v1 + in returnUs (Var v2, (Var v2, depth), idType v2, emptyFloats, stricts) where stricts = case idNewStrictness v of @@ -489,18 +481,19 @@ corePrepExprFloat env expr@(App _ _) returnUs (Note (Coerce ty1 ty2) fun', hd, ty1, floats, ss) collect_args (Note note fun) depth - | ignore_note note + | ignore_note note -- Drop these notes altogether + -- They aren't used by the code generator = collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) -> - returnUs (Note note fun', hd, fun_ty, floats, ss) + returnUs (fun', hd, fun_ty, floats, ss) - -- non-variable fun, better let-bind it + -- N-variable fun, better let-bind it -- ToDo: perhaps we can case-bind rather than let-bind this closure, -- since it is sure to be evaluated. collect_args fun depth = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun') -> newVar ty `thenUs` \ fn_id -> - mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ floats -> - returnUs (Var fn_id, (Var fn_id, depth), ty, floats, []) + mkLocalNonRec fn_id onceDem fun_floats fun' `thenUs` \ (floats, fn_id') -> + returnUs (Var fn_id', (Var fn_id', depth), ty, floats, []) where ty = exprType fun @@ -516,15 +509,58 @@ corePrepExprFloat env expr@(App _ _) -- maybeSaturate deals with saturating primops and constructors -- The type is the type of the entire application -maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr -maybeSaturate fn expr n_args ty - | hasNoBinding fn = saturate_it - | otherwise = returnUs expr +maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr) +maybeSaturate fn expr n_args floats ty + | Just DataToTagOp <- isPrimOpId_maybe fn -- DataToTag must have an evaluated arg + -- A gruesome special case + = saturate_it `thenUs` \ sat_expr -> + + -- OK, now ensure that the arg is evaluated. + -- But (sigh) take into account the lambdas we've now introduced + let + (eta_bndrs, eta_body) = collectBinders sat_expr + in + eval_data2tag_arg eta_body `thenUs` \ (eta_floats, eta_body') -> + if null eta_bndrs then + returnUs (floats `appendFloats` eta_floats, eta_body') + else + mkBinds eta_floats eta_body' `thenUs` \ eta_body'' -> + returnUs (floats, mkLams eta_bndrs eta_body'') + + | hasNoBinding fn = saturate_it `thenUs` \ sat_expr -> + returnUs (floats, sat_expr) + + | otherwise = returnUs (floats, expr) + where fn_arity = idArity fn excess_arity = fn_arity - n_args - saturate_it = getUniquesUs `thenUs` \ us -> - returnUs (etaExpand excess_arity us expr ty) + + saturate_it :: UniqSM CoreExpr + saturate_it | excess_arity == 0 = returnUs expr + | otherwise = getUniquesUs `thenUs` \ us -> + returnUs (etaExpand excess_arity us expr ty) + + -- Ensure that the argument of DataToTagOp is evaluated + eval_data2tag_arg :: CoreExpr -> UniqSM (Floats, CoreExpr) + eval_data2tag_arg app@(fun `App` arg) + | exprIsHNF arg -- Includes nullary constructors + = returnUs (emptyFloats, app) -- The arg is evaluated + | otherwise -- Arg not evaluated, so evaluate it + = newVar (exprType arg) `thenUs` \ arg_id -> + let + arg_id1 = setIdUnfolding arg_id evaldUnfolding + in + returnUs (unitFloat (FloatCase arg_id1 arg False ), + fun `App` Var arg_id1) + + eval_data2tag_arg (Note note app) -- Scc notes can appear + = eval_data2tag_arg app `thenUs` \ (floats, app') -> + returnUs (floats, Note note app') + + eval_data2tag_arg other -- Should not happen + = pprPanic "eval_data2tag" (ppr other) + -- --------------------------------------------------------------------------- -- Precipitating the floating bindings @@ -537,14 +573,12 @@ floatRhs :: TopLevelFlag -> RecFlag CoreExpr) -- Final Rhs floatRhs top_lvl is_rec bndr (floats, rhs) - | isTopLevel top_lvl || exprIsValue rhs, -- Float to expose value or + | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or allLazy top_lvl is_rec floats -- at top level = -- Why the test for allLazy? -- v = f (x `divInt#` y) -- we don't want to float the case, even if f has arity 2, -- because floating the case would make it evaluated too early - -- - -- Finally, eta-expand the RHS, for the benefit of the code gen returnUs (floats, rhs) | otherwise @@ -555,7 +589,8 @@ floatRhs top_lvl is_rec bndr (floats, rhs) -- mkLocalNonRec is used only for *nested*, *non-recursive* bindings mkLocalNonRec :: Id -> RhsDemand -- Lhs: id with demand -> Floats -> CoreExpr -- Rhs: let binds in body - -> UniqSM Floats + -> UniqSM (Floats, Id) -- The new Id may have an evaldUnfolding, + -- to record that it's been evaluated mkLocalNonRec bndr dem floats rhs | isUnLiftedType (idType bndr) @@ -564,30 +599,35 @@ mkLocalNonRec bndr dem floats rhs let float = FloatCase bndr rhs (exprOkForSpeculation rhs) in - returnUs (addFloat floats float) + returnUs (addFloat floats float, evald_bndr) | isStrict dem -- It's a strict let so we definitely float all the bindings = let -- Don't make a case for a value binding, -- even if it's strict. Otherwise we get -- case (\x -> e) of ...! - float | exprIsValue rhs = FloatLet (NonRec bndr rhs) + float | exprIsHNF rhs = FloatLet (NonRec bndr rhs) | otherwise = FloatCase bndr rhs (exprOkForSpeculation rhs) in - returnUs (addFloat floats float) + returnUs (addFloat floats float, evald_bndr) | otherwise = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') -> - returnUs (addFloat floats' (FloatLet (NonRec bndr rhs'))) + returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')), + if exprIsHNF rhs' then evald_bndr else bndr) + + where + evald_bndr = bndr `setIdUnfolding` evaldUnfolding + -- Record if the binder is evaluated mkBinds :: Floats -> CoreExpr -> UniqSM CoreExpr mkBinds (Floats _ binds) body | isNilOL binds = returnUs body | otherwise = deLam body `thenUs` \ body' -> + -- Lambdas are not allowed as the body of a 'let' returnUs (foldrOL mk_bind body' binds) where --- gaw 2004 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] mk_bind (FloatLet bind) body = Let bind body @@ -736,21 +776,59 @@ onceDem = RhsDemand False True -- used at most once %************************************************************************ \begin{code} +-- --------------------------------------------------------------------------- +-- The environment +-- --------------------------------------------------------------------------- + +data CorePrepEnv = CPE (IdEnv Id) -- Clone local Ids + Bool -- True <=> inside a GADT case; see Note [GADT] + +-- Note [GADT] +-- +-- Be careful with cloning inside GADTs. For example, +-- /\a. \f::a. \x::T a. case x of { T -> f True; ... } +-- The case on x may refine the type of f to be a function type. +-- Without this type refinement, exprType (f True) may simply fail, +-- which is bad. +-- +-- Solution: remember when we are inside a potentially-type-refining case, +-- and in that situation use the type from the old occurrence +-- when looking up occurrences + +emptyCorePrepEnv :: CorePrepEnv +emptyCorePrepEnv = CPE emptyVarEnv False + +extendCorePrepEnv :: CorePrepEnv -> Id -> Id -> CorePrepEnv +extendCorePrepEnv (CPE env gadt) id id' = CPE (extendVarEnv env id id') gadt + +lookupCorePrepEnv :: CorePrepEnv -> Id -> Id +-- See Note [GADT] above +lookupCorePrepEnv (CPE env gadt) id + = case lookupVarEnv env id of + Nothing -> id + Just id' | gadt -> setIdType id' (idType id) + | otherwise -> id' + +setGadt :: CorePrepEnv -> AltCon -> CorePrepEnv +setGadt env@(CPE id_env _) (DataAlt data_con) | not (isVanillaDataCon data_con) = CPE id_env True +setGadt env other = env + + ------------------------------------------------------------------------------ -- Cloning binders -- --------------------------------------------------------------------------- -cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var]) +cloneBndrs :: CorePrepEnv -> [Var] -> UniqSM (CorePrepEnv, [Var]) cloneBndrs env bs = mapAccumLUs cloneBndr env bs -cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var) +cloneBndr :: CorePrepEnv -> Var -> UniqSM (CorePrepEnv, Var) cloneBndr env bndr | isLocalId bndr = getUniqueUs `thenUs` \ uniq -> let bndr' = setVarUnique bndr uniq in - returnUs (extendVarEnv env bndr bndr', bndr') + returnUs (extendCorePrepEnv env bndr bndr', bndr') | otherwise -- Top level things, which we don't want -- to clone, have become GlobalIds by now