X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplCore%2FSimplUtils.lhs;h=b57b4b14265f7ae15e415e539cbb8cbdc100a841;hb=07d4332263895cabac09db76e21ad9c4071011a8;hp=6a1034f0111a0910cef215285c498b626e171353;hpb=87a229b84c8b4958d57cb37e92c27fe18f4bc28a;p=ghc-hetmet.git diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index 6a1034f..b57b4b1 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -25,25 +25,27 @@ import CmdLineOpts ( SimplifierSwitch(..), opt_SimplCaseMerge, opt_UF_UpdateInPlace ) import CoreSyn -import CoreUtils ( cheapEqExpr, exprType, - etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce, +import CoreFVs ( exprFreeVars ) +import CoreUtils ( cheapEqExpr, exprType, exprIsTrivial, + etaExpand, exprEtaExpandArity, bindNonRec, mkCoerce2, findDefault, exprOkForSpeculation, exprIsValue ) import qualified Subst ( simplBndrs, simplBndr, simplLetId, simplLamBndr ) -import Id ( Id, idType, idInfo, +import Id ( Id, idType, idInfo, isDataConWorkId, mkSysLocal, isDeadBinder, idNewDemandInfo, idUnfolding, idNewStrictness ) import NewDemand ( isStrictDmd, isBotRes, splitStrictSig ) import SimplMonad -import Type ( Type, seqType, splitRepFunTys, isStrictType, +import Type ( Type, seqType, splitFunTys, dropForAlls, isStrictType, splitTyConApp_maybe, tyConAppArgs, mkTyVarTys ) import TcType ( isDictTy ) -import OccName ( UserFS ) +import OccName ( EncodedFS ) import TyCon ( tyConDataCons_maybe, isAlgTyCon, isNewTyCon ) -import DataCon ( dataConRepArity, dataConSig, dataConArgTys ) +import DataCon ( dataConRepArity, dataConExistentialTyVars, dataConArgTys ) import Var ( mkSysTyVar, tyVarKind ) +import VarSet import Util ( lengthExceeds, mapAccumL ) import Outputable \end{code} @@ -222,6 +224,9 @@ getContArgs chkr fun orig_cont -- * (error "Hello") arg -- * f (error "Hello") where f is strict -- etc + -- Then, especially in the first of these cases, we'd like to discard + -- the continuation, leaving just the bottoming expression. But the + -- type might not be right, so we may have to add a coerce. go acc ss inl cont | null ss && discardableCont cont = (reverse acc, discardCont cont, inl) | otherwise = (reverse acc, cont, inl) @@ -232,14 +237,14 @@ getContArgs chkr fun orig_cont computed_stricts = zipWith (||) fun_stricts arg_stricts ---------------------------- - (val_arg_tys, _) = splitRepFunTys (idType fun) + (val_arg_tys, _) = splitFunTys (dropForAlls (idType fun)) arg_stricts = map isStrictType val_arg_tys ++ repeat False -- These argument types are used as a cheap and cheerful way to find -- unboxed arguments, which must be strict. But it's an InType -- and so there might be a type variable where we expect a function -- type (the substitution hasn't happened yet). And we don't bother -- doing the type applications for a polymorphic function. - -- Hence the split*Rep*FunTys + -- Hence the splitFunTys*IgnoringForAlls* ---------------------------- -- If fun_stricts is finite, it means the function returns bottom @@ -273,6 +278,9 @@ interestingArg :: OutExpr -> Bool interestingArg (Var v) = hasSomeUnfolding (idUnfolding v) -- Was: isValueUnfolding (idUnfolding v') -- But that seems over-pessimistic + || isDataConWorkId v + -- This accounts for an argument like + -- () or [], which is definitely interesting interestingArg (Type _) = False interestingArg (App fn (Type _)) = interestingArg fn interestingArg (Note _ a) = interestingArg a @@ -471,7 +479,7 @@ seqBndr b | isTyVar b = b `seq` () \begin{code} -newId :: UserFS -> Type -> SimplM Id +newId :: EncodedFS -> Type -> SimplM Id newId fs ty = getUniqueSmpl `thenSmpl` \ uniq -> returnSmpl (mkSysLocal fs uniq ty) \end{code} @@ -540,17 +548,17 @@ tryEtaReduce bndrs body -- efficient here: -- (a) we already have the binders -- (b) we can do the triviality test before computing the free vars - -- [in fact I take the simple path and look for just a variable] = go (reverse bndrs) body where go (b : bs) (App fun arg) | ok_arg b arg = go bs fun -- Loop round - go [] (Var fun) | ok_fun fun = Just (Var fun) -- Success! + go [] fun | ok_fun fun = Just fun -- Success! go _ _ = Nothing -- Failure! - ok_fun fun = not (fun `elem` bndrs) && - (isEvaldUnfolding (idUnfolding fun) || all ok_lam bndrs) + ok_fun fun = exprIsTrivial fun + && not (any (`elemVarSet` (exprFreeVars fun)) bndrs) + && (exprIsValue fun || all ok_lam bndrs) ok_lam v = isTyVar v || isDictTy (idType v) - -- The isEvaldUnfolding is because eta reduction is not + -- The exprIsValue is because eta reduction is not -- valid in general: \x. bot /= bot -- So we need to be sure that the "fun" is a value. -- @@ -861,6 +869,16 @@ prepareDefault case_bndr handled_cons (Just rhs) -- case x of { DEFAULT -> e } -- and we don't want to fill in a default for them! Just all_cons <- tyConDataCons_maybe tycon, + not (null all_cons), -- This is a tricky corner case. If the data type has no constructors, + -- which GHC allows, then the case expression will have at most a default + -- alternative. We don't want to eliminate that alternative, because the + -- invariant is that there's always one alternative. It's more convenient + -- to leave + -- case x of { DEFAULT -> e } + -- as it is, rather than transform it to + -- error "case cant match" + -- which would be quite legitmate. But it's a really obscure corner, and + -- not worth wasting code on. let handled_data_cons = [data_con | DataAlt data_con <- handled_cons], let missing_cons = [con | con <- all_cons, not (con `elem` handled_data_cons)] @@ -885,11 +903,11 @@ mk_args missing_con inst_tys = getUniquesSmpl `thenSmpl` \ tv_uniqs -> getUniquesSmpl `thenSmpl` \ id_uniqs -> let - (_,_,ex_tyvars,_,_,_) = dataConSig missing_con + ex_tyvars = dataConExistentialTyVars missing_con ex_tyvars' = zipWith mk tv_uniqs ex_tyvars mk uniq tv = mkSysTyVar uniq (tyVarKind tv) arg_tys = dataConArgTys missing_con (inst_tys ++ mkTyVarTys ex_tyvars') - arg_ids = zipWith (mkSysLocal SLIT("a")) id_uniqs arg_tys + arg_ids = zipWith (mkSysLocal FSLIT("a")) id_uniqs arg_tys in returnSmpl (ex_tyvars' ++ arg_ids) \end{code} @@ -1170,6 +1188,16 @@ I don't really know how to improve this situation. \begin{code} -------------------------------------------------- +-- 0. Check for empty alternatives +-------------------------------------------------- + +#ifdef DEBUG +mkCase1 scrut case_bndr [] + = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $ + returnSmpl scrut +#endif + +-------------------------------------------------- -- 1. Eliminate the case altogether if poss -------------------------------------------------- @@ -1215,12 +1243,6 @@ mkCase1 scrut case_bndr [(con,bndrs,rhs)] -- 2. Identity case -------------------------------------------------- -#ifdef DEBUG -mkCase1 scrut case_bndr [] - = pprTrace "mkCase1: null alts" (ppr case_bndr <+> ppr scrut) $ - returnSmpl scrut -#endif - mkCase1 scrut case_bndr alts -- Identity case | all identity_alt alts = tick (CaseIdentity case_bndr) `thenSmpl_` @@ -1244,7 +1266,7 @@ mkCase1 scrut case_bndr alts -- Identity case -- re_note wraps a coerce if it might be necessary re_note scrut = case head alts of - (_,_,rhs1@(Note _ _)) -> mkCoerce (exprType rhs1) (idType case_bndr) scrut + (_,_,rhs1@(Note _ _)) -> mkCoerce2 (exprType rhs1) (idType case_bndr) scrut other -> scrut