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

Fix a bug in CorePrep that meant output invariants not satisfied

In cpePair I did things in the wrong order so that something that
should have been a CprRhs wasn't.  Result: a crash in CoreToStg.
Fix is easy, and I added more informative type signatures too.
parent a90dc390
...@@ -276,31 +276,28 @@ cpeBind top_lvl env (Rec pairs) ...@@ -276,31 +276,28 @@ cpeBind top_lvl env (Rec pairs)
--------------- ---------------
cpePair :: TopLevelFlag -> RecFlag -> RhsDemand cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
-> CorePrepEnv -> Id -> CoreExpr -> CorePrepEnv -> Id -> CoreExpr
-> UniqSM (Floats, Id, CoreExpr) -> UniqSM (Floats, Id, CpeRhs)
-- Used for all bindings -- Used for all bindings
cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
= do { (floats1, rhs1) <- cpeRhsE env rhs = do { (floats1, rhs1) <- cpeRhsE env rhs
; let (rhs1_bndrs, _) = collectBinders rhs1
; (floats2, rhs2) ; (floats2, rhs2)
<- if want_float floats1 rhs1 <- if manifestArity rhs1 <= arity
then return (floats1, rhs1) then return (floats1, cpeEtaExpand arity rhs1)
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
-- Note [Silly extra arguments]
(do { v <- newVar (idType bndr)
; let float = mkFloat False False v rhs1
; return (addFloat floats1 float, cpeEtaExpand arity (Var v)) })
; (floats3, rhs')
<- if want_float floats2 rhs2
then return (floats2, rhs2)
else -- Non-empty floats will wrap rhs1 else -- Non-empty floats will wrap rhs1
-- But: rhs1 might have lambdas, and we can't -- But: rhs1 might have lambdas, and we can't
-- put them inside a wrapBinds -- put them inside a wrapBinds
if valBndrCount rhs1_bndrs <= arity do { body2 <- rhsToBodyNF rhs2
then -- Lambdas in rhs1 will be nuked by eta expansion ; return (emptyFloats, wrapBinds floats2 body2) }
return (emptyFloats, wrapBinds floats1 rhs1)
else do { body1 <- rhsToBodyNF rhs1
; return (emptyFloats, wrapBinds floats1 body1) }
; (floats3, rhs') -- Note [Silly extra arguments]
<- if manifestArity rhs2 <= arity
then return (floats2, cpeEtaExpand arity rhs2)
else WARN(True, text "CorePrep: silly extra arguments:" <+> ppr bndr)
(do { v <- newVar (idType bndr)
; let float = mkFloat False False v rhs2
; return (addFloat floats2 float, cpeEtaExpand arity (Var v)) })
-- Record if the binder is evaluated -- Record if the binder is evaluated
; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding ; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
...@@ -697,7 +694,7 @@ Instead CoreArity.etaExpand gives ...@@ -697,7 +694,7 @@ Instead CoreArity.etaExpand gives
f = /\a -> \y -> let s = h 3 in g s y f = /\a -> \y -> let s = h 3 in g s y
\begin{code} \begin{code}
cpeEtaExpand :: Arity -> CoreExpr -> CoreExpr cpeEtaExpand :: Arity -> CpeRhs -> CpeRhs
cpeEtaExpand arity expr cpeEtaExpand arity expr
| arity == 0 = expr | arity == 0 = expr
| otherwise = etaExpand arity expr | otherwise = etaExpand arity expr
...@@ -793,7 +790,7 @@ emptyFloats = Floats OkToSpec nilOL ...@@ -793,7 +790,7 @@ emptyFloats = Floats OkToSpec nilOL
isEmptyFloats :: Floats -> Bool isEmptyFloats :: Floats -> Bool
isEmptyFloats (Floats _ bs) = isNilOL bs isEmptyFloats (Floats _ bs) = isNilOL bs
wrapBinds :: Floats -> CoreExpr -> CoreExpr wrapBinds :: Floats -> CpeBody -> CpeBody
wrapBinds (Floats _ binds) body wrapBinds (Floats _ binds) body
= foldrOL mk_bind body binds = foldrOL mk_bind body binds
where where
......
Markdown is supported
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