X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcoreSyn%2FCorePrep.lhs;h=e5165f0ebe98ed34e3aa052a04f5b7d167d58c65;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=9daa46d01c67af5fe138a1c142d877ff3bec88bb;hpb=f25b9225f77ca8aa097a9acb4b5be27daea94891;p=ghc-hetmet.git diff --git a/ghc/compiler/coreSyn/CorePrep.lhs b/ghc/compiler/coreSyn/CorePrep.lhs index 9daa46d..e5165f0 100644 --- a/ghc/compiler/coreSyn/CorePrep.lhs +++ b/ghc/compiler/coreSyn/CorePrep.lhs @@ -10,24 +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, setIdUnfolding, setIdType, - isFCallId, isGlobalId, isImplicitId, + isFCallId, isGlobalId, isLocalId, hasNoBinding, idNewStrictness, - idUnfolding, isDataConWorkId_maybe, isPrimOpId_maybe + isPrimOpId_maybe ) -import DataCon ( isVanillaDataCon ) +import DataCon ( isVanillaDataCon, dataConWorkId ) import PrimOp ( PrimOp( DataToTagOp ) ) -import HscTypes ( TypeEnv, typeEnvElts, TyThing( AnId ) ) import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel, RecFlag(..), isNonRec ) @@ -35,7 +35,7 @@ import UniqSupply import Maybes import OrdList import ErrUtils -import CmdLineOpts +import DynFlags import Util ( listLengthCmp ) import Outputable \end{code} @@ -98,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 @@ -130,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 @@ -154,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} @@ -320,6 +303,7 @@ 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 @@ -497,9 +481,10 @@ 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) -- N-variable fun, better let-bind it -- ToDo: perhaps we can case-bind rather than let-bind this closure, @@ -526,29 +511,55 @@ corePrepExprFloat env expr@(App _ _) -- The type is the type of the entire application maybeSaturate :: Id -> CoreExpr -> Int -> Floats -> Type -> UniqSM (Floats, CoreExpr) maybeSaturate fn expr n_args floats ty - | hasNoBinding fn = saturate_it + | 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 -> - let expr' = etaExpand excess_arity us expr ty in - case isPrimOpId_maybe fn of - Just DataToTagOp -> hack_data2tag expr' - other -> returnUs (floats, expr') + + 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 - hack_data2tag app@(Var _fn `App` _ty `App` Var arg_id) - | isEvaldUnfolding (idUnfolding arg_id) -- Includes nullary constructors - = returnUs (floats, app) -- The arg is evaluated - hack_data2tag app@(Var fn `App` Type ty `App` arg) + 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 ty `thenUs` \ arg_id1 -> - let arg_id2 = setIdUnfolding arg_id1 evaldUnfolding - new_float = FloatCase arg_id2 arg False + = newVar (exprType arg) `thenUs` \ arg_id -> + let + arg_id1 = setIdUnfolding arg_id evaldUnfolding in - returnUs (addFloat floats new_float, - Var fn `App` Type ty `App` Var arg_id2) + 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) -- --------------------------------------------------------------------------- @@ -562,7 +573,7 @@ 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) @@ -595,7 +606,7 @@ mkLocalNonRec bndr dem floats rhs = 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, evald_bndr) @@ -603,7 +614,7 @@ mkLocalNonRec bndr dem floats rhs | otherwise = floatRhs NotTopLevel NonRecursive bndr (floats, rhs) `thenUs` \ (floats', rhs') -> returnUs (addFloat floats' (FloatLet (NonRec bndr rhs')), - if exprIsValue rhs' then evald_bndr else bndr) + if exprIsHNF rhs' then evald_bndr else bndr) where evald_bndr = bndr `setIdUnfolding` evaldUnfolding @@ -614,6 +625,7 @@ 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 mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)]