From 8295d9ca0f3e72e545b35c43a4a2e1e4ec582fb6 Mon Sep 17 00:00:00 2001 From: simonpj Date: Tue, 22 Dec 1998 16:31:39 +0000 Subject: [PATCH] [project @ 1998-12-22 16:31:28 by simonpj] 1. Add primOpStrictness to PrimOp.lhs, and use it in - the strictness analyser - the simplifier to deal correctly with PrimOps that are non-strict. ToDo: use this new facility to clean up SeqOp, ParOp. 2. Fix the instance-decl-import bug, but printing de-synonym'd types in interface files. 3. Make the simplifier treat applications with an unlifted-type arg in the same way it would if the function was strict (in rebuild_strict) --- ghc/compiler/basicTypes/OccName.lhs | 6 +- ghc/compiler/main/MkIface.lhs | 13 +- ghc/compiler/prelude/PrimOp.lhs | 29 ++- ghc/compiler/simplCore/SimplCore.lhs | 9 +- ghc/compiler/simplCore/Simplify.lhs | 324 +++++++++++++++++----------------- ghc/compiler/stranal/SaAbsInt.lhs | 18 +- ghc/compiler/types/TyCon.lhs | 4 +- ghc/compiler/types/Type.lhs | 40 ++++- ghc/compiler/utils/Util.lhs | 2 +- 9 files changed, 256 insertions(+), 189 deletions(-) diff --git a/ghc/compiler/basicTypes/OccName.lhs b/ghc/compiler/basicTypes/OccName.lhs index 11244fb..4a0901f 100644 --- a/ghc/compiler/basicTypes/OccName.lhs +++ b/ghc/compiler/basicTypes/OccName.lhs @@ -460,7 +460,11 @@ initTidyOccEnv = foldl (\env (OccName _ fs _ _) -> addToFM env fs 1) emptyTidyOc tidyOccName :: TidyOccEnv -> OccName -> (TidyOccEnv, OccName) tidyOccName in_scope occ@(OccName occ_sp real _ _) - | not (real `elemFM` in_scope) + | not (real `elemFM` in_scope) && + not (isLexCon real) -- Hack alert! Specialised versions of overloaded + -- constructors end up as ordinary Ids, but we don't + -- want them as ConIds in interface files. + = (addToFM in_scope real 1, occ) -- First occurrence | otherwise -- Already occurs diff --git a/ghc/compiler/main/MkIface.lhs b/ghc/compiler/main/MkIface.lhs index 065ae63..dbc8f08 100644 --- a/ghc/compiler/main/MkIface.lhs +++ b/ghc/compiler/main/MkIface.lhs @@ -53,7 +53,7 @@ import TyCon ( TyCon, getSynTyConDefn, isSynTyCon, isNewTyCon, isAlgTyCon, import Class ( Class, classBigSig ) import SpecEnv ( specEnvToList ) import FieldLabel ( fieldLabelName, fieldLabelType ) -import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, +import Type ( mkSigmaTy, splitSigmaTy, mkDictTy, tidyTopType, deNoteType, Type, ThetaType ) @@ -227,7 +227,16 @@ ifaceInstances if_hdl inst_infos ------- pp_inst (InstInfo clas tvs tys theta dfun_id _ _ _) = let - forall_ty = mkSigmaTy tvs theta (mkDictTy clas tys) + -- The deNoteType is very important. It removes all type + -- synonyms from the instance type in interface files. + -- That in turn makes sure that when reading in instance decls + -- from interface files that the 'gating' mechanism works properly. + -- Otherwise you could have + -- type Tibble = T Int + -- instance Foo Tibble where ... + -- and this instance decl wouldn't get imported into a module + -- that mentioned T but not Tibble. + forall_ty = mkSigmaTy tvs theta (deNoteType (mkDictTy clas tys)) renumbered_ty = tidyTopType forall_ty in hcat [ptext SLIT("instance "), pprType renumbered_ty, diff --git a/ghc/compiler/prelude/PrimOp.lhs b/ghc/compiler/prelude/PrimOp.lhs index b8f5521..3570e60 100644 --- a/ghc/compiler/prelude/PrimOp.lhs +++ b/ghc/compiler/prelude/PrimOp.lhs @@ -12,7 +12,7 @@ module PrimOp ( commutableOp, - primOpOutOfLine, primOpNeedsWrapper, + primOpOutOfLine, primOpNeedsWrapper, primOpStrictness, primOpOkForSpeculation, primOpIsCheap, primOpHasSideEffects, @@ -27,6 +27,7 @@ import PrimRep -- most of it import TysPrim import TysWiredIn +import Demand ( Demand, wwLazy, wwPrim, wwStrict ) import Var ( TyVar ) import CallConv ( CallConv, pprCallConv ) import PprType ( pprParendType ) @@ -841,6 +842,32 @@ integerCompare name = mkGenPrimOp name [] two_Integer_tys intPrimTy %************************************************************************ %* * +\subsubsection{Strictness} +%* * +%************************************************************************ + +Not all primops are strict! + +\begin{code} +primOpStrictness :: PrimOp -> ([Demand], Bool) + -- See IdInfo.StrictnessInfo for discussion of what the results + -- **NB** as a cheap hack, to avoid having to look up the PrimOp's arity, + -- the list of demands may be infinite! + -- Use only the ones you ned. + +primOpStrictness SeqOp = ([wwLazy], False) +primOpStrictness WriteArrayOp = ([wwPrim, wwPrim, wwLazy, wwPrim], False) +primOpStrictness WriteMutVarOp = ([wwPrim, wwLazy, wwPrim], False) +primOpStrictness PutMVarOp = ([wwPrim, wwLazy, wwPrim], False) +primOpStrictness CatchOp = ([wwLazy, wwLazy], False) +primOpStrictness RaiseOp = ([wwLazy], True) -- NB: True => result is bottom +primOpStrictness MkWeakOp = ([wwLazy, wwLazy, wwLazy, wwPrim], False) +primOpStrictness MakeStablePtrOp = ([wwLazy, wwPrim], False) +primOpStrictness other = (repeat wwPrim, False) +\end{code} + +%************************************************************************ +%* * \subsubsection[PrimOp-comparison]{PrimOpInfo basic comparison ops} %* * %************************************************************************ diff --git a/ghc/compiler/simplCore/SimplCore.lhs b/ghc/compiler/simplCore/SimplCore.lhs index e89e36b..be827a8 100644 --- a/ghc/compiler/simplCore/SimplCore.lhs +++ b/ghc/compiler/simplCore/SimplCore.lhs @@ -195,10 +195,11 @@ simplifyPgm sw_chkr us binds (us1, us2) = splitUniqSupply us -simplTopBinds [] = returnSmpl [] -simplTopBinds (bind1 : binds) = (simplBind bind1 $ - simplTopBinds binds) `thenSmpl` \ (binds1', binds') -> - returnSmpl (binds1' ++ binds') +simplTopBinds binds = go binds `thenSmpl` \ (binds', _) -> + returnSmpl binds' + where + go [] = returnSmpl ([], ()) + go (bind1 : binds) = simplBind bind1 (go binds) \end{code} diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 2c72f3f..aa443a1 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -34,7 +34,7 @@ import IdInfo ( InlinePragInfo(..), OccInfo(..), StrictnessInfo(..), import Demand ( Demand, isStrict, wwLazy ) import Const ( isWHNFCon, conOkForAlt ) import ConFold ( tryPrimOp ) -import PrimOp ( PrimOp ) +import PrimOp ( PrimOp, primOpStrictness ) import DataCon ( DataCon, dataConNumInstArgs, dataConStrictMarks, dataConSig, dataConArgTys ) import Const ( Con(..) ) import MagicUFs ( applyMagicUnfoldingFun ) @@ -53,7 +53,7 @@ import SpecEnv ( lookupSpecEnv, isEmptySpecEnv, substSpecEnv ) import CostCentre ( isSubsumedCCS, currentCCS, isEmptyCC ) import Type ( Type, mkTyVarTy, mkTyVarTys, isUnLiftedType, fullSubstTy, mkFunTy, splitFunTys, splitTyConApp_maybe, splitFunTy_maybe, - applyTy, applyTys, funResultTy + applyTy, applyTys, funResultTy, isDictTy, isDataType ) import TyCon ( isDataTyCon, tyConDataCons, tyConClass_maybe, tyConArity, isDataTyCon ) import TysPrim ( realWorldStatePrimTy ) @@ -141,16 +141,24 @@ simplExprB expr@(Con (PrimOp op) args) cont getInScope `thenSmpl` \ in_scope -> getSubstEnv `thenSmpl` \ se -> let + (val_arg_demands, _) = primOpStrictness op + -- Main game plan: loop through the arguments, simplifying -- each of them with an ArgOf continuation. Getting the right -- cont_ty in the ArgOf continuation is a bit of a nuisance. - go [] args' = rebuild_primop (reverse args') - go (arg:args) args' = setSubstEnv se (simplExprB arg (mk_cont args args')) + go [] ds args' = rebuild_primop (reverse args') + go (arg:args) ds args' + | isTypeArg arg = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> + go args ds (arg':args') + go (arg:args) (d:ds) args' + | not (isStrict d) = setSubstEnv se (simplArg arg) `thenSmpl` \ arg' -> + go args ds (arg':args') + | otherwise = setSubstEnv se (simplExprB arg (mk_cont args ds args')) cont_ty = contResultType in_scope expr_ty cont - mk_cont args args' = ArgOf NoDup (\ arg' -> go args (arg':args')) cont_ty + mk_cont args ds args' = ArgOf NoDup (\ arg' -> go args ds (arg':args')) cont_ty in - go args [] + go args val_arg_demands [] where rebuild_primop args' @@ -196,14 +204,13 @@ simplExprB (Note note e) cont = simplExpr e Stop `thenSmpl` \ e' -> rebuild (mkNote note e') cont --- Let to case, but only if the RHS isn't a WHNF +-- A non-recursive let is dealt with by simplBeta simplExprB (Let (NonRec bndr rhs) body) cont = getSubstEnv `thenSmpl` \ se -> simplBeta bndr rhs se body cont -simplExprB (Let bind body) cont - = simplBind bind (simplExprB body cont) `thenSmpl` \ (binds, stuff) -> - returnSmpl (addBinds binds stuff) +simplExprB (Let (Rec pairs) body) cont + = simplRecBind pairs (simplExprB body cont) -- Type-beta reduction simplExprB expr@(Lam bndr body) cont@(ApplyTo _ (Type ty_arg) arg_se body_cont) @@ -478,36 +485,36 @@ costCentreOk ccs_encl cc_rhs %************************************************************************ \begin{code} -simplBind :: CoreBind -> SimplM a -> SimplM ([CoreBind], a) +simplBind :: InBind -> SimplM (OutStuff a) -> SimplM (OutStuff a) simplBind (NonRec bndr rhs) thing_inside = simplTopRhs bndr rhs `thenSmpl` \ (binds, in_scope, rhs', arity) -> setInScope in_scope $ - completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ (maybe_bind, res) -> - let - binds' = case maybe_bind of - Just bind -> binds ++ [bind] - Nothing -> binds - in - returnSmpl (binds', res) + completeBindNonRec (bndr `setIdArity` arity) rhs' thing_inside `thenSmpl` \ stuff -> + returnSmpl (addBinds binds stuff) simplBind (Rec pairs) thing_inside + = simplRecBind pairs thing_inside + -- The assymetry between the two cases is a bit unclean + +simplRecBind :: [(InId, InExpr)] -> SimplM (OutStuff a) -> SimplM (OutStuff a) +simplRecBind pairs thing_inside = simplIds (map fst pairs) $ \ bndrs' -> -- NB: bndrs' don't have unfoldings or spec-envs -- We add them as we go down, using simplPrags - go (pairs `zip` bndrs') `thenSmpl` \ (pairs', thing') -> - returnSmpl ([Rec pairs'], thing') + go (pairs `zip` bndrs') `thenSmpl` \ (pairs', stuff) -> + returnSmpl (addBind (Rec pairs') stuff) where - go [] = thing_inside `thenSmpl` \ res -> - returnSmpl ([], res) + go [] = thing_inside `thenSmpl` \ stuff -> + returnSmpl ([], stuff) go (((bndr, rhs), bndr') : pairs) = simplTopRhs bndr rhs `thenSmpl` \ (rhs_binds, in_scope, rhs', arity) -> setInScope in_scope $ completeBindRec bndr (bndr' `setIdArity` arity) - rhs' (go pairs) `thenSmpl` \ (pairs', res) -> - returnSmpl (flatten rhs_binds pairs', res) + rhs' (go pairs) `thenSmpl` \ (pairs', stuff) -> + returnSmpl (flatten rhs_binds pairs', stuff) flatten (NonRec b r : binds) prs = (b,r) : flatten binds prs flatten (Rec prs1 : binds) prs2 = prs1 ++ flatten binds prs2 @@ -569,11 +576,11 @@ simplRhs bndr bndr_se rhs mkRhsTyLam rhs `thenSmpl` \ rhs' -> -- Simplify the swizzled RHS - simplRhs2 bndr bndr_se rhs `thenSmpl` \ stuff@(floats, in_scope, rhs', arity) -> + simplRhs2 bndr bndr_se rhs `thenSmpl` \ (floats, (in_scope, rhs', arity)) -> if not (null floats) && exprIsWHNF rhs' then -- Do the float tick LetFloatFromLet `thenSmpl_` - returnSmpl stuff + returnSmpl (floats, in_scope, rhs', arity) else -- Don't do it getInScope `thenSmpl` \ in_scope -> returnSmpl ([], in_scope, mkLetBinds floats rhs', arity) @@ -588,10 +595,7 @@ from simplExpr for an applied lambda). The binder needs to \begin{code} simplRhs2 bndr bndr_se (Let bind body) - = simplBind bind ( - simplRhs2 bndr bndr_se body - ) `thenSmpl` \ (binds1, (binds2, in_scope, rhs', arity)) -> - returnSmpl (binds1 ++ binds2, in_scope, rhs', arity) + = simplBind bind (simplRhs2 bndr bndr_se body) simplRhs2 bndr bndr_se rhs | null ids -- Prevent eta expansion for both thunks @@ -604,7 +608,7 @@ simplRhs2 bndr bndr_se rhs -- Also if there isn't a lambda at the top we use -- simplExprB so that we can do (more) let-floating = simplExprB rhs Stop `thenSmpl` \ (binds, (in_scope, rhs')) -> - returnSmpl (binds, in_scope, rhs', unknownArity) + returnSmpl (binds, (in_scope, rhs', unknownArity)) | otherwise -- Consider eta expansion = getSwitchChecker `thenSmpl` \ sw_chkr -> @@ -620,17 +624,22 @@ simplRhs2 bndr bndr_se rhs `thenSmpl` \ extra_arg_tys' -> newIds extra_arg_tys' $ \ extra_bndrs' -> simplExpr body (mk_cont extra_bndrs') `thenSmpl` \ body' -> - returnSmpl ( [], in_scope, - mkLams tyvars' - $ mkLams ids' - $ mkLams extra_bndrs' body', - atLeastArity (no_of_ids + no_of_extras)) + let + expanded_rhs = mkLams tyvars' + $ mkLams ids' + $ mkLams extra_bndrs' body' + expanded_arity = atLeastArity (no_of_ids + no_of_extras) + in + returnSmpl ([], (in_scope, expanded_rhs, expanded_arity)) + else simplExpr body Stop `thenSmpl` \ body' -> - returnSmpl ( [], in_scope, - mkLams tyvars' - $ mkLams ids' body', - atLeastArity no_of_ids) + let + unexpanded_rhs = mkLams tyvars' + $ mkLams ids' body' + unexpanded_arity = atLeastArity no_of_ids + in + returnSmpl ([], (in_scope, unexpanded_rhs, unexpanded_arity)) where (tyvars, ids, body) = collectTyAndValBinders rhs @@ -682,8 +691,8 @@ simplBeta bndr rhs rhs_se body cont #endif simplBeta bndr rhs rhs_se body cont - | (isStrict (getIdDemandInfo bndr) || is_dict bndr) - && not (exprIsWHNF rhs) + | isUnLiftedType bndr_ty + || (isStrict (getIdDemandInfo bndr) || is_dict bndr) && not (exprIsWHNF rhs) = tick Let2Case `thenSmpl_` getSubstEnv `thenSmpl` \ body_se -> setSubstEnv rhs_se $ @@ -700,53 +709,48 @@ simplBeta bndr rhs rhs_se body cont setSubstEnv rhs_se (simplRhs bndr bndr_se rhs) `thenSmpl` \ (floats, in_scope, rhs', arity) -> setInScope in_scope $ - completeBindNonRecE (bndr `setIdArity` arity) rhs' ( + completeBindNonRec (bndr `setIdArity` arity) rhs' ( simplExprB body cont - ) `thenSmpl` \ res -> - returnSmpl (addBinds floats res) + ) `thenSmpl` \ stuff -> + returnSmpl (addBinds floats stuff) where -- Return true only for dictionary types where the dictionary -- has more than one component (else we risk poking on the component -- of a newtype dictionary) - is_dict bndr - | not opt_DictsStrict = False - | otherwise - = case splitTyConApp_maybe (idType bndr) of - Nothing -> False - Just (tycon,tys) -> maybeToBool (tyConClass_maybe tycon) && - length tys == tyConArity tycon && - isDataTyCon tycon + is_dict bndr = opt_DictsStrict && isDictTy bndr_ty && isDataType bndr_ty + bndr_ty = idType bndr \end{code} -The completeBindNonRec family +completeBindNonRec - deals only with Ids, not TyVars - take an already-simplified RHS - always produce let bindings -They do *not* attempt to do let-to-case. Why? Because -they are used for top-level bindings, and in many situations where -the "rhs" is known to be a WHNF (so let-to-case is inappropriate). +It does *not* attempt to do let-to-case. Why? Because they are used for + + - top-level bindings + (when let-to-case is impossible) + + - many situations where the "rhs" is known to be a WHNF + (so let-to-case is inappropriate). \begin{code} -completeBindNonRec :: InId -- Binder - -> OutExpr -- Simplified RHS - -> SimplM a -- Thing inside - -> SimplM (Maybe OutBind, a) +completeBindNonRec :: InId -- Binder + -> OutExpr -- Simplified RHS + -> SimplM (OutStuff a) -- Thing inside + -> SimplM (OutStuff a) completeBindNonRec bndr rhs thing_inside | isDeadBinder bndr -- This happens; for example, the case_bndr during case of -- known constructor: case (a,b) of x { (p,q) -> ... } -- Here x isn't mentioned in the RHS, so we don't want to -- create the (dead) let-binding let x = (a,b) in ... - = thing_inside `thenSmpl` \ res -> - returnSmpl (Nothing,res) + = thing_inside | postInlineUnconditionally bndr etad_rhs = tick PostInlineUnconditionally `thenSmpl_` - extendIdSubst bndr (Done etad_rhs) ( - thing_inside `thenSmpl` \ res -> - returnSmpl (Nothing,res) - ) + extendIdSubst bndr (Done etad_rhs) + thing_inside | otherwise -- Note that we use etad_rhs here -- This gives maximum chance for a remaining binding @@ -754,20 +758,11 @@ completeBindNonRec bndr rhs thing_inside = simplBinder bndr $ \ bndr' -> simplPrags bndr bndr' etad_rhs `thenSmpl` \ bndr'' -> modifyInScope bndr'' $ - thing_inside `thenSmpl` \ res -> - returnSmpl (Just (NonRec bndr' etad_rhs), res) + thing_inside `thenSmpl` \ stuff -> + returnSmpl (addBind (NonRec bndr' etad_rhs) stuff) where etad_rhs = etaCoreExpr rhs -completeBindNonRecE :: InId -> OutExpr - -> SimplM (OutStuff a) - -> SimplM (OutStuff a) -completeBindNonRecE bndr rhs thing_inside - = completeBindNonRec bndr rhs thing_inside `thenSmpl` \ (maybe_bind, stuff) -> - case maybe_bind of - Nothing -> returnSmpl stuff - Just bind -> returnSmpl (addBind bind stuff) - -- (simplPrags old_bndr new_bndr new_rhs) does two things -- (a) it attaches the new unfolding to new_bndr -- (b) it grabs the SpecEnv from old_bndr, applies the current @@ -1078,6 +1073,7 @@ do_rebuild expr@(Con con args) cont@(Select _ _ _ _ _) --------------------------------------------------------- + -- Case of other value (e.g. a partial application or lambda) -- Turn it back into a let @@ -1086,7 +1082,7 @@ do_rebuild expr (Select _ bndr ((DEFAULT, bs, rhs):alts) se cont) = ASSERT( null bs && null alts ) tick Case2Let `thenSmpl_` setSubstEnv se ( - completeBindNonRecE bndr expr $ + completeBindNonRec bndr expr $ simplExprB rhs cont ) @@ -1116,10 +1112,88 @@ do_rebuild scrut (Select _ bndr alts se cont) where (rhs1:other_rhss) = [rhs | (_,_,rhs) <- alts] binders_unused (_, bndrs, _) = all isDeadBinder bndrs +\end{code} + +Case elimination [see the code above] +~~~~~~~~~~~~~~~~ +Start with a simple situation: + + case x# of ===> e[x#/y#] + y# -> e + +(when x#, y# are of primitive type, of course). We can't (in general) +do this for algebraic cases, because we might turn bottom into +non-bottom! + +Actually, we generalise this idea to look for a case where we're +scrutinising a variable, and we know that only the default case can +match. For example: +\begin{verbatim} + case x of + 0# -> ... + other -> ...(case x of + 0# -> ... + other -> ...) ... +\end{code} +Here the inner case can be eliminated. This really only shows up in +eliminating error-checking code. +We also make sure that we deal with this very common case: + case e of + x -> ...x... + +Here we are using the case as a strict let; if x is used only once +then we want to inline it. We have to be careful that this doesn't +make the program terminate when it would have diverged before, so we +check that + - x is used strictly, or + - e is already evaluated (it may so if e is a variable) + +Lastly, we generalise the transformation to handle this: + + case e of ===> r + True -> r + False -> r + +We only do this for very cheaply compared r's (constructors, literals +and variables). If pedantic bottoms is on, we only do it when the +scrutinee is a PrimOp which can't fail. + +We do it *here*, looking at un-simplified alternatives, because we +have to check that r doesn't mention the variables bound by the +pattern in each alternative, so the binder-info is rather useful. + +So the case-elimination algorithm is: + + 1. Eliminate alternatives which can't match + + 2. Check whether all the remaining alternatives + (a) do not mention in their rhs any of the variables bound in their pattern + and (b) have equal rhss + + 3. Check we can safely ditch the case: + * PedanticBottoms is off, + or * the scrutinee is an already-evaluated variable + or * the scrutinee is a primop which is ok for speculation + -- ie we want to preserve divide-by-zero errors, and + -- calls to error itself! + + or * [Prim cases] the scrutinee is a primitive variable + + or * [Alg cases] the scrutinee is a variable and + either * the rhs is the same variable + (eg case x of C a b -> x ===> x) + or * there is only one alternative, the default alternative, + and the binder is used strictly in its scope. + [NB this is helped by the "use default binder where + possible" transformation; see below.] +If so, then we can replace the case with one of the rhss. + + +\begin{code} --------------------------------------------------------- -- Rebuiling a function with strictness info @@ -1138,16 +1212,17 @@ rebuild_strict ds result_bot fun fun_ty (ApplyTo _ (Type ty_arg) se cont) (applyTy fun_ty ty_arg') cont rebuild_strict (d:ds) result_bot fun fun_ty (ApplyTo _ val_arg se cont) - | not (isStrict d) -- Lazy value argument - = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' -> - rebuild_strict ds result_bot (App fun val_arg') res_ty cont - - | otherwise -- Strict value argument + | isStrict d || isUnLiftedType arg_ty -- Strict value argument = getInScope `thenSmpl` \ in_scope -> let cont_ty = contResultType in_scope res_ty cont in setSubstEnv se (simplExprB val_arg (ArgOf NoDup cont_fn cont_ty)) + + | otherwise -- Lazy value argument + = setSubstEnv se (simplArg val_arg) `thenSmpl` \ val_arg' -> + cont_fn val_arg' + where Just (arg_ty, res_ty) = splitFunTy_maybe fun_ty cont_fn arg' = rebuild_strict ds result_bot @@ -1226,7 +1301,7 @@ knownCon expr con args (Select _ bndr alts se cont) setSubstEnv se ( case findAlt con alts of (DEFAULT, bs, rhs) -> ASSERT( null bs ) - completeBindNonRecE bndr expr $ + completeBindNonRec bndr expr $ simplExprB rhs cont (Literal lit, bs, rhs) -> ASSERT( null bs ) @@ -1237,7 +1312,7 @@ knownCon expr con args (Select _ bndr alts se cont) -- case patterns. simplExprB rhs cont - (DataCon dc, bs, rhs) -> completeBindNonRecE bndr expr $ + (DataCon dc, bs, rhs) -> completeBindNonRec bndr expr $ extend bs real_args $ simplExprB rhs cont where @@ -1394,83 +1469,6 @@ simplAlts zap_occ_info scrut_cons case_bndr'' alts cont' \end{code} -Case elimination [see the code above] -~~~~~~~~~~~~~~~~ -Start with a simple situation: - - case x# of ===> e[x#/y#] - y# -> e - -(when x#, y# are of primitive type, of course). We can't (in general) -do this for algebraic cases, because we might turn bottom into -non-bottom! - -Actually, we generalise this idea to look for a case where we're -scrutinising a variable, and we know that only the default case can -match. For example: -\begin{verbatim} - case x of - 0# -> ... - other -> ...(case x of - 0# -> ... - other -> ...) ... -\end{code} -Here the inner case can be eliminated. This really only shows up in -eliminating error-checking code. - -We also make sure that we deal with this very common case: - - case e of - x -> ...x... - -Here we are using the case as a strict let; if x is used only once -then we want to inline it. We have to be careful that this doesn't -make the program terminate when it would have diverged before, so we -check that - - x is used strictly, or - - e is already evaluated (it may so if e is a variable) - -Lastly, we generalise the transformation to handle this: - - case e of ===> r - True -> r - False -> r - -We only do this for very cheaply compared r's (constructors, literals -and variables). If pedantic bottoms is on, we only do it when the -scrutinee is a PrimOp which can't fail. - -We do it *here*, looking at un-simplified alternatives, because we -have to check that r doesn't mention the variables bound by the -pattern in each alternative, so the binder-info is rather useful. - -So the case-elimination algorithm is: - - 1. Eliminate alternatives which can't match - - 2. Check whether all the remaining alternatives - (a) do not mention in their rhs any of the variables bound in their pattern - and (b) have equal rhss - - 3. Check we can safely ditch the case: - * PedanticBottoms is off, - or * the scrutinee is an already-evaluated variable - or * the scrutinee is a primop which is ok for speculation - -- ie we want to preserve divide-by-zero errors, and - -- calls to error itself! - - or * [Prim cases] the scrutinee is a primitive variable - - or * [Alg cases] the scrutinee is a variable and - either * the rhs is the same variable - (eg case x of C a b -> x ===> x) - or * there is only one alternative, the default alternative, - and the binder is used strictly in its scope. - [NB this is helped by the "use default binder where - possible" transformation; see below.] - - -If so, then we can replace the case with one of the rhss. %************************************************************************ diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 96a51a9..d2a8b3d 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -18,6 +18,7 @@ module SaAbsInt ( import CmdLineOpts ( opt_AllStrict, opt_NumbersStrict ) import CoreSyn import CoreUnfold ( Unfolding(..) ) +import PrimOp ( primOpStrictness ) import Id ( Id, idType, getIdStrictness, getIdUnfolding ) import Const ( Con(..) ) import DataCon ( dataConTyCon, dataConArgTys ) @@ -418,14 +419,19 @@ absEval anal (Con (Literal _) args) env = -- Literals terminate (strictness) and are not poison (absence) AbsTop -absEval anal (Con (PrimOp _) args) env - = -- PrimOps evaluate all their arguments - if any (what_bot anal) [absEval anal arg env | arg <- args] +absEval anal (Con (PrimOp op) args) env + = -- Not all PrimOps evaluate all their arguments + if or (zipWith (check_arg anal) + [absEval anal arg env | arg <- args] + arg_demands) then AbsBot - else AbsTop + else case anal of + StrAnal | result_bot -> AbsBot + other -> AbsTop where - what_bot StrAnal = isBot -- Primops are strict - what_bot AbsAnal = anyBot -- Look for poison anywhere + (arg_demands, result_bot) = primOpStrictness op + check_arg StrAnal arg dmd = evalStrictness dmd arg + check_arg AbsAnal arg dmd = evalAbsence dmd arg absEval anal (Con (DataCon con) args) env | isProductTyCon (dataConTyCon con) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index efd7d02..189b0da 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -248,11 +248,11 @@ isAlgTyCon (AlgTyCon {}) = True isAlgTyCon (TupleTyCon {}) = True isAlgTyCon other = False --- isDataTyCon returns False for @newtype@. +-- isDataTyCon returns False for @newtype@ and for unboxed tuples isDataTyCon (AlgTyCon {algTyConFlavour = new_or_data}) = case new_or_data of NewType -> False other -> True -isDataTyCon (TupleTyCon {}) = True -- is an unboxed tuple a datatype? +isDataTyCon (TupleTyCon {tyConBoxed = True}) = True isDataTyCon other = False isNewTyCon (AlgTyCon {algTyConFlavour = NewType}) = True diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index 859ace5..3078d8d 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -27,7 +27,7 @@ module Type ( splitAlgTyConApp_maybe, splitAlgTyConApp, mkDictTy, splitDictTy_maybe, isDictTy, - mkSynTy, isSynTy, + mkSynTy, isSynTy, deNoteType, mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys, applyTy, applyTys, isForAllTy, @@ -39,7 +39,7 @@ module Type ( mkSigmaTy, splitSigmaTy, -- Lifting and boxity - isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, + isUnLiftedType, isUnboxedType, isUnboxedTupleType, isAlgType, isDataType, typePrimRep, -- Free variables @@ -78,7 +78,7 @@ import Class ( classTyCon, Class ) import TyCon ( TyCon, KindCon, mkFunTyCon, mkKindCon, mkSuperKindCon, matchesTyCon, isUnboxedTupleTyCon, isUnLiftedTyCon, - isFunTyCon, + isFunTyCon, isDataTyCon, isAlgTyCon, isSynTyCon, tyConArity, tyConKind, tyConDataCons, getSynTyConDefn, tyConPrimRep, tyConClass_maybe @@ -115,11 +115,15 @@ A type is can be entered. (NOTE: previously "pointed"). - *algebraic* A type with one or more constructors. An algebraic - type is one that can be deconstructed with a case - expression. *NOT* the same as lifted types, - because we also include unboxed tuples in this - classification. + *algebraic* A type with one or more constructors, whether declared + with "data" or "newtype". + An algebraic type is one that can be deconstructed + with a case expression. + + *NOT* the same as lifted types, because we also + include unboxed tuples in this classification. + + *data* A type declared with "data". Also boxed tuples. *primitive* iff it is a built-in type that can't be expressed in Haskell. @@ -523,6 +527,15 @@ mkSynTy syn_tycon tys isSynTy (NoteTy (SynNote _) _) = True isSynTy other = False + +deNoteType :: Type -> Type + -- Sorry for the cute name +deNoteType ty@(TyVarTy tyvar) = ty +deNoteType (TyConApp tycon tys) = TyConApp tycon (map deNoteType tys) +deNoteType (NoteTy _ ty) = deNoteType ty +deNoteType (AppTy fun arg) = AppTy (deNoteType fun) (deNoteType arg) +deNoteType (FunTy fun arg) = FunTy (deNoteType fun) (deNoteType arg) +deNoteType (ForAllTy tv ty) = ForAllTy tv (deNoteType ty) \end{code} Notes on type synonyms @@ -899,9 +912,18 @@ isUnboxedTupleType ty = case splitTyConApp_maybe ty of Just (tc, ty_args) -> isUnboxedTupleTyCon tc other -> False +-- Should only be applied to *types*; hence the assert isAlgType :: Type -> Bool isAlgType ty = case splitTyConApp_maybe ty of - Just (tc, ty_args) -> isAlgTyCon tc + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isAlgTyCon tc + other -> False + +-- Should only be applied to *types*; hence the assert +isDataType :: Type -> Bool +isDataType ty = case splitTyConApp_maybe ty of + Just (tc, ty_args) -> ASSERT( length ty_args == tyConArity tc ) + isDataTyCon tc other -> False typePrimRep :: Type -> PrimRep diff --git a/ghc/compiler/utils/Util.lhs b/ghc/compiler/utils/Util.lhs index fb9cf79..1165334 100644 --- a/ghc/compiler/utils/Util.lhs +++ b/ghc/compiler/utils/Util.lhs @@ -159,7 +159,7 @@ stretchZipEqual :: (a -> b -> Maybe a) -> [a] -> [b] -> [a] stretchZipEqual f [] [] = [] stretchZipEqual f (x:xs) (y:ys) = case f x y of Just x' -> x' : stretchZipEqual f xs ys - Nothing -> x : stretchZipEqual f xs (y:ys) + Nothing -> x : stretchZipEqual f xs (y:ys) \end{code} -- 1.7.10.4