Commit ef44a429 authored by Simon Peyton Jones's avatar Simon Peyton Jones
Browse files

Make SetLevels do substitution properly (fixes Trac #8714)

Nowadays SetLevels floats case expressions as well as let-bindings,
and case expressions bind type variables.  We need to clone all such
floated binders, to avoid accidental name capture.  But I'd forgotten
to substitute for the cloned type variables, causing #8714.  (In the
olden days only Ids were cloned, from let-bindings.)

This patch fixes the bug and does quite a bit of clean-up refactoring
as well, by putting the context level in the LvlEnv.

There is no effect on performance, except that nofib 'rewrite' improves
allocations by 3%.  On investigation I think it was a fluke to do with
loop-cutting in big letrec nests.  But at least it's a fluke in the
right direction.

        Program           Size    Allocs   Runtime   Elapsed  TotalMem
--------------------------------------------------------------------------------
            Min          -0.4%     -3.0%    -19.4%    -19.4%    -26.7%
            Max          -0.0%     +0.0%    +17.9%    +17.9%      0.0%
 Geometric Mean          -0.1%     -0.0%     -0.7%     -0.7%     -0.4%
parent a10ed3e6
......@@ -23,7 +23,7 @@ module CoreSubst (
substTy, substCo, substExpr, substExprSC, substBind, substBindSC,
substUnfolding, substUnfoldingSC,
lookupIdSubst, lookupTvSubst, lookupCvSubst, substIdOcc,
substTickish,
substTickish, substVarSet,
-- ** Operations on substitutions
emptySubst, mkEmptySubst, mkSubst, mkOpenSubst, substInScope, isEmptySubst,
......
......@@ -18,7 +18,7 @@ module CoreSyn (
-- * Main data types
Expr(..), Alt, Bind(..), AltCon(..), Arg, Tickish(..),
CoreProgram, CoreExpr, CoreAlt, CoreBind, CoreArg, CoreBndr,
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..),
TaggedExpr, TaggedAlt, TaggedBind, TaggedArg, TaggedBndr(..), deTagExpr,
-- ** 'Expr' construction
mkLets, mkLams,
......@@ -1106,6 +1106,25 @@ instance Outputable b => OutputableBndr (TaggedBndr b) where
pprBndr _ b = ppr b -- Simple
pprInfixOcc b = ppr b
pprPrefixOcc b = ppr b
deTagExpr :: TaggedExpr t -> CoreExpr
deTagExpr (Var v) = Var v
deTagExpr (Lit l) = Lit l
deTagExpr (Type ty) = Type ty
deTagExpr (Coercion co) = Coercion co
deTagExpr (App e1 e2) = App (deTagExpr e1) (deTagExpr e2)
deTagExpr (Lam (TB b _) e) = Lam b (deTagExpr e)
deTagExpr (Let bind body) = Let (deTagBind bind) (deTagExpr body)
deTagExpr (Case e (TB b _) ty alts) = Case (deTagExpr e) b ty (map deTagAlt alts)
deTagExpr (Tick t e) = Tick t (deTagExpr e)
deTagExpr (Cast e co) = Cast (deTagExpr e) co
deTagBind :: TaggedBind t -> CoreBind
deTagBind (NonRec (TB b _) rhs) = NonRec b (deTagExpr rhs)
deTagBind (Rec prs) = Rec [(b, deTagExpr rhs) | (TB b _, rhs) <- prs]
deTagAlt :: TaggedAlt t -> CoreAlt
deTagAlt (con, bndrs, rhs) = (con, [b | TB b _ <- bndrs], deTagExpr rhs)
\end{code}
......
This diff is collapsed.
{-# LANGUAGE ExistentialQuantification #-}
module T8714 where
data HLState = forall a. HLState (a -> a) !a
data BufferImpl = FBufferData !HLState
focusAst :: BufferImpl -> HLState
focusAst (FBufferData (HLState f x)) = HLState f (f x)
......@@ -198,3 +198,4 @@ test('T5996',
run_command,
['$MAKE -s --no-print-directory T5996'])
test('T8537', normal, compile, [''])
test('T8714', normal, compile, [''])
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