Commit a84a227c authored by simonpj@microsoft.com's avatar simonpj@microsoft.com
Browse files

Correct the float-coercions-out-of-let patch

parent 95731e19
......@@ -604,7 +604,6 @@ seqExpr (Lit lit) = lit `seq` ()
seqExpr (App f a) = seqExpr f `seq` seqExpr a
seqExpr (Lam b e) = seqBndr b `seq` seqExpr e
seqExpr (Let b e) = seqBind b `seq` seqExpr e
-- gaw 2004
seqExpr (Case e b t as) = seqExpr e `seq` seqBndr b `seq` seqType t `seq` seqAlts as
seqExpr (Cast e co) = seqExpr e `seq` seqType co
seqExpr (Note n e) = seqNote n `seq` seqExpr e
......@@ -652,7 +651,6 @@ data AnnExpr' bndr annot
| AnnLit Literal
| AnnLam bndr (AnnExpr bndr annot)
| AnnApp (AnnExpr bndr annot) (AnnExpr bndr annot)
-- gaw 2004
| AnnCase (AnnExpr bndr annot) bndr Type [AnnAlt bndr annot]
| AnnLet (AnnBind bndr annot) (AnnExpr bndr annot)
| AnnCast (AnnExpr bndr annot) Coercion
......@@ -684,7 +682,6 @@ deAnnotate' (AnnLet bind body)
deAnnBind (AnnNonRec var rhs) = NonRec var (deAnnotate rhs)
deAnnBind (AnnRec pairs) = Rec [(v,deAnnotate rhs) | (v,rhs) <- pairs]
-- gaw 2004
deAnnotate' (AnnCase scrut v t alts)
= Case (deAnnotate scrut) v t (map deAnnAlt alts)
......
......@@ -1195,7 +1195,9 @@ mkAtomicArgsE :: SimplEnv
-> SimplM FloatsWithExpr
mkAtomicArgsE env is_strict (Cast rhs co) thing_inside
| not (exprIsTrivial rhs)
-- Note [Float coersions]
-- See also Note [Take care] below
= do { id <- newId FSLIT("a") (exprType rhs)
; completeNonRecX env False id id rhs $ \ env ->
thing_inside env (Cast (Var id) co) }
......@@ -1219,6 +1221,10 @@ mkAtomicArgsE env is_strict rhs thing_inside
= do { arg_id <- newId FSLIT("a") arg_ty
; completeNonRecX env False {- pessimistic -} arg_id arg_id arg $ \env ->
go env (App fun (Var arg_id)) args }
-- Note [Take care]:
-- This is sightly delicate. If completeNonRecX was to do a postInlineUnconditionally
-- (undoing the effect of introducing the let-binding), we'd find arg_id had
-- no binding. The exprIsTrivial is the only time that'll happen, though.
where
arg_ty = exprType arg
no_float_arg = not is_strict && (isUnLiftedType arg_ty) && not (exprOkForSpeculation arg)
......@@ -1233,6 +1239,7 @@ mkAtomicArgs :: Bool -- OK to float unlifted args
-- if the strict-binding flag is on
mkAtomicArgs ok_float_unlifted (Cast rhs co)
| not (exprIsTrivial rhs)
-- Note [Float coersions]
= do { id <- newId FSLIT("a") (exprType rhs)
; (binds, rhs') <- mkAtomicArgs ok_float_unlifted rhs
......
Supports Markdown
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment