prepareRhs :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Adds new floats to the env iff that allows us to return a good RHS
prepareRhs env (Cast rhs co) -- Note [Float coercions]
+ | (ty1, ty2) <- coercionKind co -- Do *not* do this if rhs has an unlifted type
+ , not (isUnLiftedType ty1) -- see Note [Float coercions (unlifted)]
= do { (env', rhs') <- makeTrivial env rhs
; return (env', Cast rhs' co) }
go n = case x of { T m -> go (n-m) }
-- This case should optimise
+Note [Float coercions (unlifted)]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+BUT don't do [Float coercions] if 'e' has an unlifted type.
+This *can* happen:
+
+ foo :: Int = (error (# Int,Int #) "urk")
+ `cast` CoUnsafe (# Int,Int #) Int
+
+If do the makeTrivial thing to the error call, we'll get
+ foo = case error (# Int,Int #) "urk" of v -> v `cast` ...
+But 'v' isn't in scope!
+
+These strange casts can happen as a result of case-of-case
+ bar = case (case x of { T -> (# 2,3 #); F -> error "urk" }) of
+ (# p,q #) -> p+q
+
\begin{code}
makeTrivial :: SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
Just unfolding -- There is an inlining!
-> do { tick (UnfoldingDone var)
; (if dopt Opt_D_dump_inlinings dflags then
- pprTrace "Inlining done" (vcat [
+ pprTrace ("Inlining done" ++ showSDoc (ppr var)) (vcat [
text "Before:" <+> ppr var <+> sep (map pprParendExpr args),
text "Inlined fn: " <+> nest 2 (ppr unfolding),
text "Cont: " <+> ppr call_cont])
; env <- simplNonRecX env bndr bndr_rhs
; -- pprTrace "knownCon2" (ppr bs $$ ppr rhs $$ ppr (seIdSubst env)) $
simplExprF env rhs cont }
-
--- Ugh!
-bind_args env dead_bndr [] _ = return env
-
-bind_args env dead_bndr (b:bs) (Type ty : args)
- = ASSERT( isTyVar b )
- bind_args (extendTvSubst env b ty) dead_bndr bs args
-
-bind_args env dead_bndr (b:bs) (arg : args)
- = ASSERT( isId b )
- do { let b' = if dead_bndr then b else zapOccInfo b
- -- Note that the binder might be "dead", because it doesn't occur
- -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
- -- Nevertheless we must keep it if the case-binder is alive, because it may
- -- be used in the con_app. See Note [zapOccInfo]
- ; env <- simplNonRecX env b' arg
- ; bind_args env dead_bndr bs args }
-
-bind_args _ _ _ _ = panic "bind_args"
+ where
+ -- Ugh!
+ bind_args env dead_bndr [] _ = return env
+
+ bind_args env dead_bndr (b:bs) (Type ty : args)
+ = ASSERT( isTyVar b )
+ bind_args (extendTvSubst env b ty) dead_bndr bs args
+
+ bind_args env dead_bndr (b:bs) (arg : args)
+ = ASSERT( isId b )
+ do { let b' = if dead_bndr then b else zapOccInfo b
+ -- Note that the binder might be "dead", because it doesn't occur
+ -- in the RHS; and simplNonRecX may therefore discard it via postInlineUnconditionally
+ -- Nevertheless we must keep it if the case-binder is alive, because it may
+ -- be used in the con_app. See Note [zapOccInfo]
+ ; env <- simplNonRecX env b' arg
+ ; bind_args env dead_bndr bs args }
+
+ bind_args _ _ _ _ =
+ pprPanic "bind_args" $ ppr dc $$ ppr bs $$ ppr args $$
+ text "scrut:" <+> ppr scrut
\end{code}