exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsValue,
exprOkForSpeculation, exprArity,
- mkCoerce, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
+ mkCoerce, mkCoerce2, mkSCC, mkInlineMe, mkAltExpr, applyTypeToArg
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
drop_bs (NonRec _ _) (_ : bs) = bs
drop_bs (Rec prs) bs = drop (length prs) bs
- simpl_bind env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
- simpl_bind env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
+ simpl_bind env bind bs
+ = getDOptsSmpl `thenSmpl` \ dflags ->
+ if dopt Opt_D_dump_inlinings dflags then
+ pprTrace "SimplBind" (ppr (bindersOf bind)) $ simpl_bind1 env bind bs
+ else
+ simpl_bind1 env bind bs
+
+ simpl_bind1 env (NonRec b r) (b':_) = simplRecOrTopPair env TopLevel b b' r
+ simpl_bind1 env (Rec pairs) bs' = simplRecBind env TopLevel pairs bs'
\end{code}
-- the inner one is redundant
addCoerce t1t2 s1s2 (ApplyTo dup arg arg_se cont)
- | Just (s1, s2) <- splitFunTy_maybe s1s2
+ | not (isTypeArg arg), -- This whole case only works for value args
+ -- Could upgrade to have equiv thing for type apps too
+ Just (s1, s2) <- splitFunTy_maybe s1s2
-- (coerce (T1->T2) (S1->S2) F) E
-- ===>
-- coerce T2 S2 (F (coerce S1 T1 E))
--
- -- t1t2 must be a function type, T1->T2
+ -- t1t2 must be a function type, T1->T2, because it's applied to something
-- but s1s2 might conceivably not be
--
-- When we build the ApplyTo we can't mix the out-types
-- But it isn't a common case.
= let
(t1,t2) = splitFunTy t1t2
- new_arg = mkCoerce s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
+ new_arg = mkCoerce2 s1 t1 (substExpr (mkSubst in_scope (getSubstEnv arg_se)) arg)
in
ApplyTo dup new_arg (zapSubstEnv env) (addCoerce t2 s2 cont)
tick (RuleFired rule_name) `thenSmpl_`
(if dopt Opt_D_dump_inlinings dflags then
pprTrace "Rule fired" (vcat [
- text "Rule:" <+> ptext rule_name,
+ text "Rule:" <+> ftext rule_name,
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
text "After: " <+> pprCoreExpr rule_rhs,
text "Cont: " <+> ppr call_cont])
rebuild env expr (Stop _ _ _) = rebuildDone env expr
rebuild env expr (ArgOf _ _ _ cont_fn) = cont_fn env expr
-rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty (exprType expr) expr) cont
+rebuild env expr (CoerceIt to_ty cont) = rebuild env (mkCoerce to_ty expr) cont
rebuild env expr (InlinePlease cont) = rebuild env (Note InlineCall expr) cont
rebuild env expr (Select _ bndr alts se cont) = rebuildCase (setInScope se env) expr bndr alts cont
rebuild env expr (ApplyTo _ arg se cont) = rebuildApp (setInScope se env) expr arg cont
| otherwise
= prepareAlts scrut case_bndr alts `thenSmpl` \ (better_alts, handled_cons) ->
-
+
-- Deal with the case binder, and prepare the continuation;
-- The new subst_env is in place
prepareCaseCont env better_alts cont `thenSmpl` \ (floats, (dup_cont, nondup_cont)) ->
) `thenSmpl` \ (final_bndrs', final_args) ->
-- See comment about "$j" name above
- newId (encodeFS SLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
+ newId (encodeFS FSLIT("$j")) (mkPiTypes final_bndrs' rhs_ty') `thenSmpl` \ join_bndr ->
-- Notice the funky mkPiTypes. If the contructor has existentials
-- it's possible that the join point will be abstracted over
-- type varaibles as well as term variables.