X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FcoreSyn%2FCorePrep.lhs;h=e90a12a505e830149a68cf19e04c7e8bc1535a8a;hb=db9c51c958c211ddd5056b5a31be0d72f40bde97;hp=eb0b40251628f589aa7e5750facdd9fd58436859;hpb=c070382857319b6f66b9bd98669b5fe56f54f757;p=ghc-hetmet.git diff --git a/compiler/coreSyn/CorePrep.lhs b/compiler/coreSyn/CorePrep.lhs index eb0b402..e90a12a 100644 --- a/compiler/coreSyn/CorePrep.lhs +++ b/compiler/coreSyn/CorePrep.lhs @@ -5,13 +5,6 @@ Core pass to saturate constructors and PrimOps \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module CorePrep ( corePrepPgm, corePrepExpr ) where @@ -42,6 +35,7 @@ import DynFlags import Util import Outputable import MonadUtils +import FastString \end{code} -- --------------------------------------------------------------------------- @@ -149,6 +143,7 @@ always fully applied, and the bindings are just there to support partial applications. But it's easier to let them through. \begin{code} +mkDataConWorkers :: [TyCon] -> [CoreBind] mkDataConWorkers data_tycons = [ NonRec id (Var id) -- The ice is thin here, but it works | tycon <- data_tycons, -- CorePrep will eta-expand it @@ -202,6 +197,7 @@ appendFloats (Floats spec1 floats1) (Floats spec2 floats2) concatFloats :: [Floats] -> Floats concatFloats = foldr appendFloats emptyFloats +combine :: OkToSpec -> OkToSpec -> OkToSpec combine NotOkToSpec _ = NotOkToSpec combine _ NotOkToSpec = NotOkToSpec combine IfUnboxedOk _ = IfUnboxedOk @@ -218,7 +214,7 @@ deFloatTop (Floats _ floats) = foldrOL get [] floats where get (FloatLet b) bs = b:bs - get b bs = pprPanic "corePrepPgm" (ppr b) + get b _ = pprPanic "corePrepPgm" (ppr b) allLazy :: TopLevelFlag -> RecFlag -> Floats -> Bool allLazy top_lvl is_rec (Floats ok_to_spec _) @@ -235,7 +231,7 @@ corePrepTopBinds :: [CoreBind] -> UniqSM Floats corePrepTopBinds binds = go emptyCorePrepEnv binds where - go env [] = return emptyFloats + go _ [] = return emptyFloats go env (bind : binds) = do (env', bind') <- corePrepTopBind env bind binds' <- go env' binds return (bind' `appendFloats` binds') @@ -306,7 +302,7 @@ corePrepRecPairs lvl env pairs = do get (FloatLet (NonRec b r)) prs2 = (b,r) : prs2 get (FloatLet (Rec prs1)) prs2 = prs1 ++ prs2 - get b prs2 = pprPanic "corePrepRecPairs" (ppr b) + get b _ = pprPanic "corePrepRecPairs" (ppr b) -------------------------------- corePrepRhs :: TopLevelFlag -> RecFlag @@ -335,15 +331,16 @@ corePrepArg env arg dem = do return (floats', Var v') -- version that doesn't consider an scc annotation to be trivial. -exprIsTrivial (Var v) = True +exprIsTrivial :: CoreExpr -> Bool +exprIsTrivial (Var _) = True exprIsTrivial (Type _) = True -exprIsTrivial (Lit lit) = True +exprIsTrivial (Lit _) = True exprIsTrivial (App e arg) = isTypeArg arg && exprIsTrivial e -exprIsTrivial (Note (SCC _) e) = False +exprIsTrivial (Note (SCC _) _) = False exprIsTrivial (Note _ e) = exprIsTrivial e -exprIsTrivial (Cast e co) = exprIsTrivial e +exprIsTrivial (Cast e _) = exprIsTrivial e exprIsTrivial (Lam b body) | isTyVar b = exprIsTrivial body -exprIsTrivial other = False +exprIsTrivial _ = False -- --------------------------------------------------------------------------- -- Dealing with expressions @@ -370,10 +367,10 @@ corePrepExprFloat env (Var v) = do v2 = lookupCorePrepEnv env v1 maybeSaturate v2 (Var v2) 0 emptyFloats (idType v2) -corePrepExprFloat env expr@(Type _) +corePrepExprFloat _env expr@(Type _) = return (emptyFloats, expr) -corePrepExprFloat env expr@(Lit lit) +corePrepExprFloat _env expr@(Lit _) = return (emptyFloats, expr) corePrepExprFloat env (Let bind body) = do @@ -484,7 +481,7 @@ corePrepExprFloat env expr@(App _ _) = do collect_args (Cast fun co) depth = do let (_ty1,ty2) = coercionKind co - (fun', hd, fun_ty, floats, ss) <- collect_args fun depth + (fun', hd, _, floats, ss) <- collect_args fun depth return (Cast fun' co, hd, ty2, floats, ss) collect_args (Note note fun) depth @@ -575,7 +572,7 @@ floatRhs :: TopLevelFlag -> RecFlag -> UniqSM (Floats, -- Floats out of this bind CoreExpr) -- Final Rhs -floatRhs top_lvl is_rec bndr (floats, rhs) +floatRhs top_lvl is_rec _bndr (floats, rhs) | isTopLevel top_lvl || exprIsHNF rhs, -- Float to expose value or allLazy top_lvl is_rec floats -- at top level = -- Why the test for allLazy? @@ -634,9 +631,10 @@ mkBinds (Floats _ binds) body mk_bind (FloatCase bndr rhs _) body = Case rhs bndr (exprType body) [(DEFAULT, [], body)] mk_bind (FloatLet bind) body = Let bind body +etaExpandRhs :: CoreBndr -> CoreExpr -> UniqSM CoreExpr etaExpandRhs bndr rhs = do -- Eta expand to match the arity claimed by the binder - -- Remember, after CorePrep we must not change arity + -- Remember, CorePrep must not change arity -- -- Eta expansion might not have happened already, -- because it is done by the simplifier only when @@ -665,7 +663,12 @@ etaExpandRhs bndr rhs = do -- f = /\a -> \y -> let s = h 3 in g s y -- us <- getUniquesM - return (etaExpand arity us rhs (idType bndr)) + let eta_rhs = etaExpand arity us rhs (idType bndr) + + ASSERT2( manifestArity eta_rhs == arity, (ppr bndr <+> ppr arity <+> ppr (exprArity rhs)) + $$ ppr rhs $$ ppr eta_rhs ) + -- Assertion checks that eta expansion was successful + return eta_rhs where -- For a GlobalId, take the Arity from the Id. -- It was set in CoreTidy and must not change @@ -717,6 +720,7 @@ deLamFloat expr -- get to a partial application: -- \xs. map f xs ==> map f +tryEta :: [CoreBndr] -> CoreExpr -> Maybe CoreExpr tryEta bndrs expr@(App _ _) | ok_to_eta_reduce f && n_remaining >= 0 && @@ -731,13 +735,13 @@ tryEta bndrs expr@(App _ _) n_remaining = length args - length bndrs ok bndr (Var arg) = bndr == arg - ok bndr other = False + ok _ _ = False -- we can't eta reduce something which must be saturated. ok_to_eta_reduce (Var f) = not (hasNoBinding f) ok_to_eta_reduce _ = False --safe. ToDo: generalise -tryEta bndrs (Let bind@(NonRec b r) body) +tryEta bndrs (Let bind@(NonRec _ r) body) | not (any (`elemVarSet` fvs) bndrs) = case tryEta bndrs body of Just e -> Just (Let bind e) @@ -745,7 +749,7 @@ tryEta bndrs (Let bind@(NonRec b r) body) where fvs = exprFreeVars r -tryEta bndrs _ = Nothing +tryEta _ _ = Nothing \end{code} @@ -755,16 +759,16 @@ tryEta bndrs _ = Nothing \begin{code} data RhsDemand - = RhsDemand { isStrict :: Bool, -- True => used at least once - isOnceDem :: Bool -- True => used at most once + = RhsDemand { isStrict :: Bool, -- True => used at least once + _isOnceDem :: Bool -- True => used at most once } mkDem :: Demand -> Bool -> RhsDemand mkDem strict once = RhsDemand (isStrictDmd strict) once mkDemTy :: Demand -> Type -> RhsDemand -mkDemTy strict ty = RhsDemand (isStrictDmd strict) - False {- For now -} +mkDemTy strict _ty = RhsDemand (isStrictDmd strict) + False {- For now -} bdrDem :: Id -> RhsDemand bdrDem id = mkDem (idNewDemandInfo id) @@ -842,5 +846,5 @@ newVar :: Type -> UniqSM Id newVar ty = seqType ty `seq` do uniq <- getUniqueM - return (mkSysLocal FSLIT("sat") uniq ty) + return (mkSysLocal (fsLit "sat") uniq ty) \end{code}