- go subst (Var v) = lookupIdSubst subst v
- go subst (App e1 e2) = App (go subst e1) (go subst e2)
- go subst (Type ty) = Type (substTy subst ty)
- go _ (Lit lit) = Lit lit
- go subst (Note note e) = Note note (go subst e)
- go subst (Cast e co) = Cast (go subst e) (substTy subst co)
- go subst (Let bind body) = go_bind subst bind body
- go subst (Lam bndr body) = Lam bndr' (go subst' body)
- where
- (subst', bndr') = substBndr subst bndr
-
- go subst (Case e b ty as) = Case (go subst e) b'
- (substTy subst ty)
- (map (go_alt subst') as)
- where
- (subst', b') = substBndr subst b
-
-
- ----------------------
- go_alt subst (con, bndrs, rhs) = (con, bndrs', go subst' rhs)
- where
- (subst', bndrs') = substBndrs subst bndrs
-
- ----------------------
- go_bind subst (Rec prs) body = Let (Rec (bndrs' `zip` rhss'))
- (go subst' body)
- where
- (bndrs, rhss) = unzip prs
- (subst', bndrs') = substRecBndrs subst bndrs
- rhss' = map (go subst') rhss
-
- go_bind subst (NonRec b r) body = go_nonrec subst b (go subst r) body
-
- ----------------------
- go_nonrec subst b (Type ty') body
- | isTyVar b = go (extendTvSubst subst b ty') body
- -- let a::* = TYPE ty in <body>
- go_nonrec subst b r' body
- | isId b -- let x = e in <body>
- , exprIsTrivial r' || safe_to_inline (idOccInfo b)
- = go (extendIdSubst subst b r') body
- go_nonrec subst b r' body
- = Let (NonRec b' r') (go subst' body)
- where
- (subst', b') = substBndr subst b
-
- ----------------------
- -- Unconditionally safe to inline
- safe_to_inline :: OccInfo -> Bool
- safe_to_inline IAmDead = True
- safe_to_inline (OneOcc in_lam one_br _) = not in_lam && one_br
- safe_to_inline (IAmALoopBreaker {}) = False
- safe_to_inline NoOccInfo = False
-\end{code}
\ No newline at end of file
+ -- n is # value args to which the expression is applied
+ go (Lit {}) _ = ValueArg
+ go (Var v) n
+ | isConLikeId v = ValueArg -- Experimenting with 'conlike' rather that
+ -- data constructors here
+ | idArity v > n = ValueArg -- Catches (eg) primops with arity but no unfolding
+ | n > 0 = NonTrivArg -- Saturated or unknown call
+ | conlike_unfolding = ValueArg -- n==0; look for an interesting unfolding
+ -- See Note [Conlike is interesting]
+ | otherwise = TrivArg -- n==0, no useful unfolding
+ where
+ conlike_unfolding = isConLikeUnfolding (idUnfolding v)
+
+ go (Type _) _ = TrivArg
+ go (Coercion _) _ = TrivArg
+ go (App fn (Type _)) n = go fn n
+ go (App fn (Coercion _)) n = go fn n
+ go (App fn _) n = go fn (n+1)
+ go (Note _ a) n = go a n
+ go (Cast e _) n = go e n
+ go (Lam v e) n
+ | isTyVar v = go e n
+ | n>0 = go e (n-1)
+ | otherwise = ValueArg
+ go (Let _ e) n = case go e n of { ValueArg -> ValueArg; _ -> NonTrivArg }
+ go (Case {}) _ = NonTrivArg
+
+nonTriv :: ArgSummary -> Bool
+nonTriv TrivArg = False
+nonTriv _ = True
+\end{code}
+
+%************************************************************************
+%* *
+ exprIsConApp_maybe
+%* *
+%************************************************************************
+
+Note [exprIsConApp_maybe]
+~~~~~~~~~~~~~~~~~~~~~~~~~
+exprIsConApp_maybe is a very important function. There are two principal
+uses:
+ * case e of { .... }
+ * cls_op e, where cls_op is a class operation
+
+In both cases you want to know if e is of form (C e1..en) where C is
+a data constructor.
+
+However e might not *look* as if
+
+\begin{code}
+-- | Returns @Just (dc, [t1..tk], [x1..xn])@ if the argument expression is
+-- a *saturated* constructor application of the form @dc t1..tk x1 .. xn@,
+-- where t1..tk are the *universally-qantified* type args of 'dc'
+exprIsConApp_maybe :: IdUnfoldingFun -> CoreExpr -> Maybe (DataCon, [Type], [CoreExpr])
+
+exprIsConApp_maybe id_unf (Note note expr)
+ | notSccNote note
+ = exprIsConApp_maybe id_unf expr
+ -- We ignore all notes except SCCs. For example,
+ -- case _scc_ "foo" (C a b) of
+ -- C a b -> e
+ -- should not be optimised away, because we'll lose the
+ -- entry count on 'foo'; see Trac #4414
+
+exprIsConApp_maybe id_unf (Cast expr co)
+ = -- Here we do the KPush reduction rule as described in the FC paper
+ -- The transformation applies iff we have
+ -- (C e1 ... en) `cast` co
+ -- where co :: (T t1 .. tn) ~ to_ty
+ -- The left-hand one must be a T, because exprIsConApp returned True
+ -- but the right-hand one might not be. (Though it usually will.)
+
+ case exprIsConApp_maybe id_unf expr of {
+ Nothing -> Nothing ;
+ Just (dc, _dc_univ_args, dc_args) ->
+
+ let Pair _from_ty to_ty = coercionKind co
+ dc_tc = dataConTyCon dc
+ in
+ case splitTyConApp_maybe to_ty of {
+ Nothing -> Nothing ;
+ Just (to_tc, to_tc_arg_tys)
+ | dc_tc /= to_tc -> Nothing
+ -- These two Nothing cases are possible; we might see
+ -- (C x y) `cast` (g :: T a ~ S [a]),
+ -- where S is a type function. In fact, exprIsConApp
+ -- will probably not be called in such circumstances,
+ -- but there't nothing wrong with it
+
+ | otherwise ->
+ let
+ tc_arity = tyConArity dc_tc
+ dc_univ_tyvars = dataConUnivTyVars dc
+ dc_ex_tyvars = dataConExTyVars dc
+ arg_tys = dataConRepArgTys dc
+
+ (ex_args, val_args) = splitAtList dc_ex_tyvars dc_args
+
+ -- Make the "theta" from Fig 3 of the paper
+ gammas = decomposeCo tc_arity co
+ theta = zipOpenCvSubst (dc_univ_tyvars ++ dc_ex_tyvars)
+ (gammas ++ map mkReflCo (stripTypeArgs ex_args))
+
+ -- Cast the value arguments (which include dictionaries)
+ new_val_args = zipWith cast_arg arg_tys val_args
+ cast_arg arg_ty arg = mkCoerce (liftCoSubst theta arg_ty) arg
+ in
+#ifdef DEBUG
+ let dump_doc = vcat [ppr dc, ppr dc_univ_tyvars, ppr dc_ex_tyvars,
+ ppr arg_tys, ppr dc_args, ppr _dc_univ_args,
+ ppr ex_args, ppr val_args]
+ in
+ ASSERT2( eqType _from_ty (mkTyConApp dc_tc _dc_univ_args), dump_doc )
+ ASSERT2( all isTypeArg ex_args, dump_doc )
+ ASSERT2( equalLength val_args arg_tys, dump_doc )
+#endif
+
+ Just (dc, to_tc_arg_tys, ex_args ++ new_val_args)
+ }}
+
+exprIsConApp_maybe id_unf expr
+ = analyse expr []
+ where
+ analyse (App fun arg) args = analyse fun (arg:args)
+ analyse fun@(Lam {}) args = beta fun [] args
+
+ analyse (Var fun) args
+ | Just con <- isDataConWorkId_maybe fun
+ , count isValArg args == idArity fun
+ , let (univ_ty_args, rest_args) = splitAtList (dataConUnivTyVars con) args
+ = Just (con, stripTypeArgs univ_ty_args, rest_args)
+
+ -- Look through dictionary functions; see Note [Unfolding DFuns]
+ | DFunUnfolding dfun_nargs con ops <- unfolding
+ , let sat = length args == dfun_nargs -- See Note [DFun arity check]
+ in if sat then True else
+ pprTrace "Unsaturated dfun" (ppr fun <+> int dfun_nargs $$ ppr args) False
+ , let (dfun_tvs, _n_theta, _cls, dfun_res_tys) = tcSplitDFunTy (idType fun)
+ subst = zipOpenTvSubst dfun_tvs (stripTypeArgs (takeList dfun_tvs args))
+ mk_arg (DFunConstArg e) = e
+ mk_arg (DFunLamArg i) = args !! i
+ mk_arg (DFunPolyArg e) = mkApps e args
+ = Just (con, substTys subst dfun_res_tys, map mk_arg ops)
+
+ -- Look through unfoldings, but only cheap ones, because
+ -- we are effectively duplicating the unfolding
+ | Just rhs <- expandUnfolding_maybe unfolding
+ = -- pprTrace "expanding" (ppr fun $$ ppr rhs) $
+ analyse rhs args
+ where
+ unfolding = id_unf fun
+
+ analyse _ _ = Nothing
+
+ -----------
+ beta (Lam v body) pairs (arg : args)
+ | isTyCoArg arg
+ = beta body ((v,arg):pairs) args
+
+ beta (Lam {}) _ _ -- Un-saturated, or not a type lambda
+ = Nothing
+
+ beta fun pairs args
+ = analyse (substExpr (text "subst-expr-is-con-app") subst fun) args
+ where
+ subst = mkOpenSubst (mkInScopeSet (exprFreeVars fun)) pairs
+ -- doc = vcat [ppr fun, ppr expr, ppr pairs, ppr args]
+
+stripTypeArgs :: [CoreExpr] -> [Type]
+stripTypeArgs args = ASSERT2( all isTypeArg args, ppr args )
+ [ty | Type ty <- args]
+ -- We really do want isTypeArg here, not isTyCoArg!
+\end{code}
+
+Note [Unfolding DFuns]
+~~~~~~~~~~~~~~~~~~~~~~
+DFuns look like
+
+ df :: forall a b. (Eq a, Eq b) -> Eq (a,b)
+ df a b d_a d_b = MkEqD (a,b) ($c1 a b d_a d_b)
+ ($c2 a b d_a d_b)
+
+So to split it up we just need to apply the ops $c1, $c2 etc
+to the very same args as the dfun. It takes a little more work
+to compute the type arguments to the dictionary constructor.
+
+Note [DFun arity check]
+~~~~~~~~~~~~~~~~~~~~~~~
+Here we check that the total number of supplied arguments (inclding
+type args) matches what the dfun is expecting. This may be *less*
+than the ordinary arity of the dfun: see Note [DFun unfoldings] in CoreSyn