\section[Simplify]{The main module of the simplifier}
\begin{code}
-#include "HsVersions.h"
-
module Simplify ( simplTopBinds, simplExpr, simplBind ) where
-IMPORT_1_3(List(partition))
-
-IMP_Ubiq(){-uitous-}
-#if defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ <= 201
-IMPORT_DELOOPER(SmplLoop) -- paranoia checking
-#endif
+#include "HsVersions.h"
import BinderInfo
import CmdLineOpts ( SimplifierSwitch(..) )
import Literal ( isNoRepLit )
import Maybes ( maybeToBool )
import PprType ( GenType{-instance Outputable-}, GenTyVar{- instance Outputable -} )
-#if __GLASGOW_HASKELL__ <= 30
-import PprCore ( GenCoreArg, GenCoreExpr )
-#endif
-import TyVar ( GenTyVar {- instance Eq -} )
-import Pretty --( ($$) )
import PrimOp ( primOpOkForSpeculation, PrimOp(..) )
import SimplCase ( simplCase, bindLargeRhs )
import SimplEnv
import SimplVar ( completeVar )
import Unique ( Unique )
import SimplUtils
-import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, mkFunTys, maybeAppDataTyCon,
- splitFunTy, splitFunTyExpandingDicts, getFunTy_maybe, eqTy
+import Type ( mkTyVarTy, mkTyVarTys, mkAppTy, applyTy, applyTys,
+ mkFunTys, splitAlgTyConApp_maybe,
+ splitFunTys, splitFunTy_maybe, isUnpointedType
+ )
+import TysPrim ( realWorldStatePrimTy )
+import Util ( Eager, appEager, returnEager, runEager, mapEager,
+ isSingleton, zipEqual, zipWithEqual, mapAndUnzip
)
-import TysWiredIn ( realWorldStateTy )
-import Outputable ( PprStyle(..), Outputable(..) )
-import Util ( SYN_IE(Eager), appEager, returnEager, runEager, mapEager,
- isSingleton, zipEqual, zipWithEqual, mapAndUnzip, panic, pprPanic, assertPanic, pprTrace )
+import Outputable
\end{code}
The controlling flags, and what they do
\begin{code}
simplExpr env (Lam (TyBinder tyvar) body) (TyArg ty : args) result_ty
- = -- ASSERT(not (isPrimType ty))
- tick TyBetaReduction `thenSmpl_`
+ = tick TyBetaReduction `thenSmpl_`
simplExpr (extendTyEnv env tyvar ty) body args result_ty
\end{code}
\begin{code}
simplExpr env (SCC cc1 (SCC cc2 expr)) args result_ty
- | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ_ -> True; _ -> False }
+ | not (isSccCountCostCentre cc2) && case cmpCostCentre cc1 cc2 of { EQ -> True; _ -> False }
-- eliminate inner scc if no call counts and same cc as outer
= simplExpr env (SCC cc1 expr) args result_ty
\begin{code}
simplRhsExpr env binder@(id,occ_info) rhs new_id
- | maybeToBool (maybeAppDataTyCon rhs_ty)
+ | maybeToBool (splitAlgTyConApp_maybe rhs_ty)
-- Deal with the data type case, in which case the elaborate
-- eta-expansion nonsense is really quite a waste of time.
= simplExpr rhs_env rhs [] rhs_ty `thenSmpl` \ rhs' ->
| otherwise -- OK, use the big hammer
= -- Deal with the big lambda part
- ASSERT( null uvars ) -- For now
-
mapSmpl cloneTyVarSmpl tyvars `thenSmpl` \ tyvars' ->
let
new_tys = mkTyVarTys tyvars'
- body_ty = foldl applyTy rhs_ty new_tys
+ body_ty = applyTys rhs_ty new_tys
lam_env = extendTyEnvList rhs_env (zipEqual "simplRhsExpr" tyvars new_tys)
in
-- Deal with the little lambda part
env1 | costsAreSubsumed current_cc = setEnclosingCC env useCurrentCostCentre
| otherwise = env
- (uvars, tyvars, body) = collectUsageAndTyBinders rhs
+ (tyvars, body) = collectTyBinders rhs
\end{code}
| otherwise -- Eta expansion possible
= -- A SSERT( no_of_extra_binders <= length potential_extra_binder_tys )
(if not ( no_of_extra_binders <= length potential_extra_binder_tys ) then
- pprTrace "simplValLam" (vcat [ppr PprDebug expr,
- ppr PprDebug expr_ty,
- ppr PprDebug binders,
+ pprTrace "simplValLam" (vcat [ppr expr,
+ ppr expr_ty,
+ ppr binders,
int no_of_extra_binders,
- ppr PprDebug potential_extra_binder_tys])
+ ppr potential_extra_binder_tys])
else \x -> x) $
tick EtaExpansion `thenSmpl_`
where
(binders,body) = collectValBinders expr
no_of_binders = length binders
- (arg_tys, res_ty) = splitFunTyExpandingDicts expr_ty
+ (arg_tys, res_ty) = splitFunTys expr_ty
potential_extra_binder_tys = (if not (no_of_binders <= length arg_tys) then
- pprTrace "simplValLam" (vcat [ppr PprDebug expr,
- ppr PprDebug expr_ty,
- ppr PprDebug binders])
+ pprTrace "simplValLam" (vcat [ppr expr,
+ ppr expr_ty,
+ ppr binders])
else \x->x) $
drop no_of_binders arg_tys
body_ty = mkFunTys potential_extra_binder_tys res_ty
-- but usually doesn't
`max`
case potential_extra_binder_tys of
- [ty] | ty `eqTy` realWorldStateTy -> 1
+ [ty] | ty == realWorldStatePrimTy -> 1
other -> 0
\end{code}
| idWantsToBeINLINEd id
= complete_bind env rhs -- Don't mess about with floating or let-to-case on
-- INLINE things
- | otherwise
- = simpl_bind env rhs
- where
- -- Try let-to-case; see notes below about let-to-case
- simpl_bind env rhs | try_let_to_case &&
- will_be_demanded &&
- (rhs_is_bot ||
- not rhs_is_whnf &&
- singleConstructorType rhs_ty
- -- Only do let-to-case for single constructor types.
- -- For other types we defer doing it until the tidy-up phase at
- -- the end of simplification.
- )
- = tick Let2Case `thenSmpl_`
- simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
- (\env rhs -> complete_bind env rhs) body_ty
+
+ -- Do let-to-case right away for unpointed types
+ -- These shouldn't occur much, but do occur right after desugaring,
+ -- because we havn't done dependency analysis at that point, so
+ -- we can't trivially do let-to-case (because there may be some unboxed
+ -- things bound in letrecs that aren't really recursive).
+ | isUnpointedType rhs_ty && not rhs_is_whnf
+ = simplCase env rhs (PrimAlts [] (BindDefault binder (Var id)))
+ (\env rhs -> complete_bind env rhs) body_ty
+
+ -- Try let-to-case; see notes below about let-to-case
+ | try_let_to_case &&
+ will_be_demanded &&
+ ( rhs_is_bot
+ || (not rhs_is_whnf && singleConstructorType rhs_ty)
+ -- Don't do let-to-case if the RHS is a constructor application.
+ -- Even then only do it for single constructor types.
+ -- For other types we defer doing it until the tidy-up phase at
+ -- the end of simplification.
+ )
+ = tick Let2Case `thenSmpl_`
+ simplCase env rhs (AlgAlts [] (BindDefault binder (Var id)))
+ (\env rhs -> complete_bind env rhs) body_ty
-- OLD COMMENT: [now the new RHS is only "x" so there's less worry]
-- NB: it's tidier to call complete_bind not simpl_bind, else
-- we nearly end up in a loop. Consider:
-- Now, the inner let is a let-to-case target again! Actually, since
-- the RHS is in WHNF it won't happen, but it's a close thing!
+ | otherwise
+ = simpl_bind env rhs
+ where
-- Try let-from-let
simpl_bind env (Let bind rhs) | let_floating_ok
= tick LetFloatFromLet `thenSmpl_`
- simplBind env (fix_up_demandedness will_be_demanded bind)
+ simplBind env (if will_be_demanded then bind
+ else un_demandify_bind bind)
(\env -> simpl_bind env rhs) body_ty
-- Try case-from-let; this deals with a strict let of error too
returnSmpl binds'
where
- (binds', _, n_extras) = fltBind bind
+ binds' = fltBind bind
+ n_extras = sum (map no_of_binds binds') - no_of_binds bind
float_lets = switchIsSet env SimplFloatLetsExposingWHNF
always_float_let_from_let = switchIsSet env SimplAlwaysFloatLetsFromLets
-- fltBind guarantees not to return leaky floats
-- and all the binders of the floats have had their demand-info zapped
fltBind (NonRec bndr rhs)
- = (binds ++ [NonRec (un_demandify bndr) rhs'],
- leakFree bndr rhs',
- length binds)
+ = binds ++ [NonRec bndr rhs']
where
(binds, rhs') = fltRhs rhs
fltBind (Rec pairs)
- = ([Rec (extras
- ++
- binders `zip` rhss')],
- and (zipWith leakFree binders rhss'),
- length extras
- )
-
+ = [Rec pairs']
where
- (binders, rhss) = unzip pairs
- (binds_s, rhss') = mapAndUnzip fltRhs rhss
- extras = concat (map get_pairs (concat binds_s))
-
- get_pairs (NonRec bndr rhs) = [(bndr,rhs)]
- get_pairs (Rec pairs) = pairs
+ pairs' = concat [ let
+ (binds, rhs') = fltRhs rhs
+ in
+ foldr get_pairs [(bndr, rhs')] binds
+ | (bndr, rhs) <- pairs
+ ]
+
+ get_pairs (NonRec bndr rhs) rest = (bndr,rhs) : rest
+ get_pairs (Rec pairs) rest = pairs ++ rest
-- fltRhs has same invariant as fltBind
fltRhs rhs
-- fltExpr guarantees not to return leaky floats
= (binds' ++ body_binds, body')
where
- (body_binds, body') = fltExpr body
- (binds', binds_wont_leak, _) = fltBind bind
+ binds_wont_leak = all leakFreeBind binds'
+ (body_binds, body') = fltExpr body
+ binds' = fltBind (un_demandify_bind bind)
fltExpr expr = ([], expr)
-- Crude but effective
+no_of_binds (NonRec _ _) = 1
+no_of_binds (Rec pairs) = length pairs
+
+leakFreeBind (NonRec bndr rhs) = leakFree bndr rhs
+leakFreeBind (Rec pairs) = and [leakFree bndr rhs | (bndr, rhs) <- pairs]
+
leakFree (id,_) rhs = case getIdArity id of
ArityAtLeast n | n > 0 -> True
ArityExactly n | n > 0 -> True
\begin{code}
--- fix_up_demandedness switches off the willBeDemanded Info field
+-- un_demandify_bind switches off the willBeDemanded Info field
-- for bindings floated out of a non-demanded let
-fix_up_demandedness True {- Will be demanded -} bind
- = bind -- Simple; no change to demand info needed
-fix_up_demandedness False {- May not be demanded -} (NonRec binder rhs)
- = NonRec (un_demandify binder) rhs
-fix_up_demandedness False {- May not be demanded -} (Rec pairs)
- = Rec [(un_demandify binder, rhs) | (binder,rhs) <- pairs]
+un_demandify_bind (NonRec binder rhs)
+ = NonRec (un_demandify_bndr binder) rhs
+un_demandify_bind (Rec pairs)
+ = Rec [(un_demandify_bndr binder, rhs) | (binder,rhs) <- pairs]
-un_demandify (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
+un_demandify_bndr (id, occ_info) = (id `addIdDemandInfo` noDemandInfo, occ_info)
is_cheap_prim_app (Prim op _) = primOpOkForSpeculation op
is_cheap_prim_app other = False
let
go ty [] = ty
go ty (TyArg ty_arg : args) = go (mkAppTy ty ty_arg) args
- go ty (a:args) | isValArg a = case (getFunTy_maybe ty) of
+ go ty (a:args) | isValArg a = case (splitFunTy_maybe ty) of
Just (_, res_ty) -> go res_ty args
Nothing ->
pprPanic "computeResultType" (vcat [
- ppr PprDebug (a:args),
- ppr PprDebug orig_args,
- ppr PprDebug expr_ty',
- ppr PprDebug ty])
+ ppr (a:args),
+ ppr orig_args,
+ ppr expr_ty',
+ ppr ty])
in
go expr_ty' orig_args
projects / ghc-hetmet.git / blobdiff