Commit 6af98b2f authored by simonpj@microsoft.com's avatar simonpj@microsoft.com

Two more wibbles to CorePrep (fixes HTTP package and DPH)

Ensuring that 
  a) lambdas show up only on the RHSs of binding after CorePrep
  b) the arity of a binding exactly matches the maifest lambdas
is surprisingly tricky.

I got it wrong (again) in my recent CorePrep shuffling, which broke
packages HTTP and DPH.  This patch fixes both.
parent 80ac93dd
......@@ -277,35 +277,59 @@ cpePair :: TopLevelFlag -> RecFlag -> RhsDemand
-> UniqSM (Floats, Id, CoreExpr)
-- Used for all bindings
cpePair top_lvl is_rec is_strict_or_unlifted env bndr rhs
= do { (floats, rhs') <- cpeRhs want_float (idArity bndr) env rhs
= do { (floats1, rhs1) <- cpeRhsE env rhs
; let (rhs1_bndrs, _) = collectBinders rhs1
; (floats2, rhs2)
<- if want_float floats1 rhs1
then return (floats1, rhs1)
else -- Non-empty floats will wrap rhs1
-- But: rhs1 might have lambdas, and we can't
-- put them inside a wrapBinds
if valBndrCount rhs1_bndrs <= arity
then -- Lambdas in rhs1 will be nuked by eta expansion
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
; let bndr' | exprIsHNF rhs' = bndr `setIdUnfolding` evaldUnfolding
| otherwise = bndr
; return (floats, bndr', rhs') }
; return (floats3, bndr', rhs') }
where
arity = idArity bndr -- We must match this arity
want_float floats rhs
| isTopLevel top_lvl = wantFloatTop bndr floats
| otherwise = wantFloatNested is_rec is_strict_or_unlifted floats rhs
{- Note [Silly extra arguments]
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
Suppose we had this
f{arity=1} = \x\y. e
We *must* match the arity on the Id, so we have to generate
f' = \x\y. e
f = \x. f' x
It's a bizarre case: why is the arity on the Id wrong? Reason
(in the days of __inline_me__):
f{arity=0} = __inline_me__ (let v = expensive in \xy. e)
When InlineMe notes go away this won't happen any more. But
it seems good for CorePrep to be robust.
-}
-- ---------------------------------------------------------------------------
-- CpeRhs: produces a result satisfying CpeRhs
-- ---------------------------------------------------------------------------
cpeRhs :: (Floats -> CpeRhs -> Bool) -- Float the floats out
-> Arity -- Guarantees an Rhs with this manifest arity
-> CorePrepEnv
-> CoreExpr -- Expression and its type
-> UniqSM (Floats, CpeRhs)
cpeRhs want_float arity env expr
= do { (floats, rhs) <- cpeRhsE env expr
; if want_float floats rhs
then return (floats, cpeEtaExpand arity rhs)
else return (emptyFloats, cpeEtaExpand arity (wrapBinds floats rhs)) }
cpeRhsE :: CorePrepEnv -> CoreExpr -> UniqSM (Floats, CpeRhs)
-- If
-- e ===> (bs, e')
......@@ -376,6 +400,11 @@ cpeBody env expr
; (floats2, body) <- rhsToBody rhs
; return (floats1 `appendFloats` floats2, body) }
--------
rhsToBodyNF :: CpeRhs -> UniqSM CpeBody
rhsToBodyNF rhs = do { (floats,body) <- rhsToBody rhs
; return (wrapBinds floats body) }
--------
rhsToBody :: CpeRhs -> UniqSM (Floats, CpeBody)
-- Remove top level lambdas by let-bindinig
......@@ -498,14 +527,21 @@ cpeApp env expr
cpeArg :: CorePrepEnv -> RhsDemand -> CoreArg -> Type
-> UniqSM (Floats, CpeTriv)
cpeArg env is_strict arg arg_ty
| cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument
= cpeBody env arg -- Must still do substitution though
| cpe_ExprIsTrivial arg -- Do not eta expand etc a trivial argument
= cpeBody env arg -- Must still do substitution though
| otherwise
= do { (floats, arg') <- cpeRhs want_float
(exprArity arg) env arg
= do { (floats1, arg1) <- cpeRhsE env arg -- arg1 can be a lambda
; (floats2, arg2) <- if want_float floats1 arg1
then return (floats1, arg1)
else do { body1 <- rhsToBodyNF arg1
; return (emptyFloats, wrapBinds floats1 body1) }
-- Else case: arg1 might have lambdas, and we can't
-- put them inside a wrapBinds
; v <- newVar arg_ty
; let arg_float = mkFloat is_strict is_unlifted v arg'
; return (addFloat floats arg_float, Var v) }
; let arg3 = cpeEtaExpand (exprArity arg2) arg2
arg_float = mkFloat is_strict is_unlifted v arg3
; return (addFloat floats2 arg_float, Var v) }
where
is_unlifted = isUnLiftedType arg_ty
want_float = wantFloatNested NonRecursive (is_strict || is_unlifted)
......@@ -748,6 +784,9 @@ mkFloat is_strict is_unlifted bndr rhs
emptyFloats :: Floats
emptyFloats = Floats OkToSpec nilOL
isEmptyFloats :: Floats -> Bool
isEmptyFloats (Floats _ bs) = isNilOL bs
wrapBinds :: Floats -> CoreExpr -> CoreExpr
wrapBinds (Floats _ binds) body
= foldrOL mk_bind body binds
......@@ -800,12 +839,14 @@ deFloatTop (Floats _ floats)
-------------------------------------------
wantFloatTop :: Id -> Floats -> Bool
-- Note [CafInfo and floating]
wantFloatTop bndr floats = mayHaveCafRefs (idCafInfo bndr)
&& allLazyTop floats
wantFloatTop bndr floats = isEmptyFloats floats
|| (mayHaveCafRefs (idCafInfo bndr)
&& allLazyTop floats)
wantFloatNested :: RecFlag -> Bool -> Floats -> CpeRhs -> Bool
wantFloatNested is_rec strict_or_unlifted floats rhs
= strict_or_unlifted
= isEmptyFloats floats
|| strict_or_unlifted
|| (allLazyNested is_rec floats && exprIsHNF rhs)
-- Why the test for allLazyNested?
-- v = f (x `divInt#` y)
......
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