X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FsimplCore%2FSetLevels.lhs;h=270ce170950160db4b9aae9944277cf5e49c66ce;hp=4b4a3498aa83bbb20e5a4cdb41d5c38b38c0b89a;hb=e79c9ce01d0ce4412bd4bcd99c8c728a6a2ec569;hpb=eced5e4068f4cb5da397ca1fd4eeea462f197503 diff --git a/compiler/simplCore/SetLevels.lhs b/compiler/simplCore/SetLevels.lhs index 4b4a349..270ce17 100644 --- a/compiler/simplCore/SetLevels.lhs +++ b/compiler/simplCore/SetLevels.lhs @@ -358,7 +358,8 @@ lvlExpr ctxt_lvl env (_, AnnCase expr case_bndr ty alts) = do @lvlMFE@ is just like @lvlExpr@, except that it might let-bind the expression, so that it can itself be floated. -[NOTE: unlifted MFEs] +Note [Unlifted MFEs] +~~~~~~~~~~~~~~~~~~~~~ We don't float unlifted MFEs, which potentially loses big opportunites. For example: \x -> f (h y) @@ -375,9 +376,16 @@ lvlMFE :: Bool -- True <=> strict context [body of case or let] lvlMFE _ _ _ (_, AnnType ty) = return (Type ty) +-- No point in floating out an expression wrapped in a coercion; +-- If we do we'll transform lvl = e |> co +-- to lvl' = e; lvl = lvl' |> co +-- and then inline lvl. Better just to float out the payload. +lvlMFE strict_ctxt ctxt_lvl env (_, AnnCast e co) + = do { expr' <- lvlMFE strict_ctxt ctxt_lvl env e + ; return (Cast expr' co) } lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _) - | isUnLiftedType ty -- Can't let-bind it; see [NOTE: unlifted MFEs] + | isUnLiftedType ty -- Can't let-bind it; see Note [Unlifted MFEs] || isInlineCtxt ctxt_lvl -- Don't float out of an __inline__ context || exprIsTrivial expr -- Never float if it's trivial || not good_destination @@ -481,7 +489,9 @@ lvlBind :: TopLevelFlag -- Used solely to decide whether to clone -> LvlM (LevelledBind, LevelEnv) lvlBind top_lvl ctxt_lvl env (AnnNonRec bndr rhs@(rhs_fvs,_)) - | isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe + | isTyVar bndr -- Don't do anything for TyVar binders + -- (simplifier gets rid of them pronto) + || isInlineCtxt ctxt_lvl -- Don't do anything inside InlineMe = do rhs' <- lvlExpr ctxt_lvl env rhs return (NonRec (TB bndr ctxt_lvl) rhs', env) @@ -515,7 +525,7 @@ lvlBind top_lvl ctxt_lvl env (AnnRec pairs) new_rhss <- mapM (lvlExpr ctxt_lvl new_env) rhss return (Rec ([TB b dest_lvl | b <- new_bndrs] `zip` new_rhss), new_env) - | isSingleton pairs && count isId abs_vars > 1 + | isSingleton pairs && count isIdVar abs_vars > 1 = do -- Special case for self recursion where there are -- several variables carried around: build a local loop: -- poly_f = \abs_vars. \lam_vars . letrec f = \lam_vars. rhs in f lam_vars @@ -595,7 +605,7 @@ lvlLamBndrs lvl bndrs [] bndrs where go old_lvl bumped_major rev_lvld_bndrs (bndr:bndrs) - | isId bndr && -- Go to the next major level if this is a value binder, + | isIdVar bndr && -- Go to the next major level if this is a value binder, not bumped_major && -- and we havn't already gone to the next level (one jump per group) not (isOneShotLambda bndr) -- and it isn't a one-shot lambda = go new_lvl True (TB bndr new_lvl : rev_lvld_bndrs) bndrs @@ -637,7 +647,7 @@ isFunction :: CoreExprWithFVs -> Bool -- We may only want to do this if there are sufficiently few free -- variables. We certainly only want to do it for values, and not for -- constructors. So the simple thing is just to look for lambdas -isFunction (_, AnnLam b e) | isId b = True +isFunction (_, AnnLam b e) | isIdVar b = True | otherwise = isFunction e isFunction (_, AnnNote _ e) = isFunction e isFunction _ = False @@ -681,10 +691,10 @@ initialEnv :: FloatOutSwitches -> LevelEnv initialEnv float_lams = (float_lams, emptyVarEnv, emptySubst, emptyVarEnv) floatLams :: LevelEnv -> Bool -floatLams (FloatOutSw float_lams _, _, _, _) = float_lams +floatLams (fos, _, _, _) = floatOutLambdas fos floatConsts :: LevelEnv -> Bool -floatConsts (FloatOutSw _ float_consts, _, _, _) = float_consts +floatConsts (fos, _, _, _) = floatOutConstants fos extendLvlEnv :: LevelEnv -> [TaggedBndr Level] -> LevelEnv -- Used when *not* cloning @@ -755,10 +765,10 @@ maxIdLevel (_, lvl_env,_,id_env) var_set Nothing -> [in_var]) max_out out_var lvl - | isId out_var = case lookupVarEnv lvl_env out_var of + | isIdVar out_var = case lookupVarEnv lvl_env out_var of Just lvl' -> maxLvl lvl' lvl Nothing -> lvl - | otherwise = lvl -- Ignore tyvars in *maxIdLevel* + | otherwise = lvl -- Ignore tyvars in *maxIdLevel* lookupVar :: LevelEnv -> Id -> LevelledExpr lookupVar (_, _, _, id_env) v = case lookupVarEnv id_env v of @@ -798,7 +808,7 @@ abstractVars dest_lvl (_, lvl_env, _, id_env) fvs -- We are going to lambda-abstract, so nuke any IdInfo, -- and add the tyvars of the Id (if necessary) - zap v | isId v = WARN( workerExists (idWorkerInfo v) || + zap v | isIdVar v = WARN( workerExists (idWorkerInfo v) || not (isEmptySpecInfo (idSpecialisation v)), text "absVarsOf: discarding info on" <+> ppr v ) setIdInfo v vanillaIdInfo @@ -813,7 +823,7 @@ absVarsOf :: IdEnv ([Var], LevelledExpr) -> Var -> [Var] -- we must look in x's type -- And similarly if x is a coercion variable. absVarsOf id_env v - | isId v = [av2 | av1 <- lookup_avs v + | isIdVar v = [av2 | av1 <- lookup_avs v , av2 <- add_tyvars av1] | isCoVar v = add_tyvars v | otherwise = [v] @@ -861,7 +871,7 @@ cloneVar :: TopLevelFlag -> LevelEnv -> Id -> Level -> Level -> LvlM (LevelEnv, cloneVar TopLevel env v _ _ = return (env, v) -- Don't clone top level things cloneVar NotTopLevel env@(_,_,subst,_) v ctxt_lvl dest_lvl - = ASSERT( isId v ) do + = ASSERT( isIdVar v ) do us <- getUniqueSupplyM let (subst', v1) = cloneIdBndr subst us v @@ -873,7 +883,7 @@ cloneRecVars :: TopLevelFlag -> LevelEnv -> [Id] -> Level -> Level -> LvlM (Leve cloneRecVars TopLevel env vs _ _ = return (env, vs) -- Don't clone top level things cloneRecVars NotTopLevel env@(_,_,subst,_) vs ctxt_lvl dest_lvl - = ASSERT( all isId vs ) do + = ASSERT( all isIdVar vs ) do us <- getUniqueSupplyM let (subst', vs1) = cloneRecIdBndrs subst us vs