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

Fix an obscure but terrible bug in the simplifier (Trac #9567)

The issue was that contInputType simply gave the wrong answer
for type applications.

There was no way to fix contInputType; it just didn't have enough
information.  So I did this:

* Split the ApplyTo constructor of SimplUtils.SimplCont into
      ApplyToVal
      ApplyToTy
  I used record syntax for them; we should do this for some
  of the other constructors too.

* The latter carries a sc_hole_ty, which is the type of the
  continuation's "hole"

* Maintaining this type meant that I had do to something
  similar for SimplUtils.ArgSpec.

* I renamed contInputType to contHoleType for consistency.

* I did a bit of refactoring around the call to tryRules
  in Simplify, which was jolly confusing before.

The resulting code is quite nice now.  And it has the additional
merit that it works.

The tests are simply tc124 and T7891 with -O enabled.
parent 8c825633
This diff is collapsed.
...@@ -31,7 +31,7 @@ import DataCon ( DataCon, dataConWorkId, dataConRepStrictness ...@@ -31,7 +31,7 @@ import DataCon ( DataCon, dataConWorkId, dataConRepStrictness
import CoreMonad ( Tick(..), SimplifierMode(..) ) import CoreMonad ( Tick(..), SimplifierMode(..) )
import CoreSyn import CoreSyn
import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd ) import Demand ( StrictSig(..), dmdTypeDepth, isStrictDmd )
import PprCore ( pprParendExpr, pprCoreExpr ) import PprCore ( pprCoreExpr )
import CoreUnfold import CoreUnfold
import CoreUtils import CoreUtils
import CoreArity import CoreArity
...@@ -541,9 +541,9 @@ These strange casts can happen as a result of case-of-case ...@@ -541,9 +541,9 @@ These strange casts can happen as a result of case-of-case
-} -}
makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec) makeTrivialArg :: SimplEnv -> ArgSpec -> SimplM (SimplEnv, ArgSpec)
makeTrivialArg env (ValArg e) = do { (env', e') <- makeTrivial NotTopLevel env e makeTrivialArg env (ValArg e) = do { (env', e') <- makeTrivial NotTopLevel env e
; return (env', ValArg e') } ; return (env', ValArg e') }
makeTrivialArg env (CastBy co) = return (env, CastBy co) makeTrivialArg env arg = return (env, arg) -- CastBy, TyArg
makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr) makeTrivial :: TopLevelFlag -> SimplEnv -> OutExpr -> SimplM (SimplEnv, OutExpr)
-- Binds the expression to a variable, if it's not trivial, returning the variable -- Binds the expression to a variable, if it's not trivial, returning the variable
...@@ -925,8 +925,15 @@ simplExprF1 env (Cast body co) cont = simplCast env body co cont ...@@ -925,8 +925,15 @@ simplExprF1 env (Cast body co) cont = simplCast env body co cont
simplExprF1 env (Coercion co) cont = simplCoercionF env co cont simplExprF1 env (Coercion co) cont = simplCoercionF env co cont
simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont ) simplExprF1 env (Type ty) cont = ASSERT( contIsRhsOrArg cont )
rebuild env (Type (substTy env ty)) cont rebuild env (Type (substTy env ty)) cont
simplExprF1 env (App fun arg) cont = simplExprF env fun $
ApplyTo NoDup arg env cont simplExprF1 env (App fun arg) cont
= simplExprF env fun $
case arg of
Type ty -> ApplyToTy { sc_arg_ty = substTy env ty
, sc_hole_ty = substTy env (exprType fun)
, sc_cont = cont }
_ -> ApplyToVal { sc_arg = arg, sc_env = env
, sc_dup = NoDup, sc_cont = cont }
simplExprF1 env expr@(Lam {}) cont simplExprF1 env expr@(Lam {}) cont
= simplLam env zapped_bndrs body cont = simplLam env zapped_bndrs body cont
...@@ -1100,13 +1107,13 @@ simplTick env tickish expr cont ...@@ -1100,13 +1107,13 @@ simplTick env tickish expr cont
= Breakpoint n (map (getDoneId . substId env) ids) = Breakpoint n (map (getDoneId . substId env) ids)
| otherwise = tickish | otherwise = tickish
-- push type application and coercion inside a tick -- Push type application and coercion inside a tick
splitCont :: SimplCont -> (SimplCont, SimplCont) splitCont :: SimplCont -> (SimplCont, SimplCont)
splitCont (ApplyTo f (Type t) env c) = (ApplyTo f (Type t) env inc, outc) splitCont cont@(ApplyToTy { sc_cont = tail }) = (cont { sc_cont = inc }, outc)
where (inc,outc) = splitCont c where (inc,outc) = splitCont tail
splitCont (CoerceIt co c) = (CoerceIt co inc, outc) splitCont (CastIt co c) = (CastIt co inc, outc)
where (inc,outc) = splitCont c where (inc,outc) = splitCont c
splitCont other = (mkBoringStop (contInputType other), other) splitCont other = (mkBoringStop (contHoleType other), other)
getDoneId (DoneId id) = id getDoneId (DoneId id) = id
getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst getDoneId (DoneEx e) = getIdFromTrivialExpr e -- Note [substTickish] in CoreSubst
...@@ -1158,19 +1165,26 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr) ...@@ -1158,19 +1165,26 @@ rebuild :: SimplEnv -> OutExpr -> SimplCont -> SimplM (SimplEnv, OutExpr)
rebuild env expr cont rebuild env expr cont
= case cont of = case cont of
Stop {} -> return (env, expr) Stop {} -> return (env, expr)
CoerceIt co cont -> rebuild env (mkCast expr co) cont TickIt t cont -> rebuild env (mkTick t expr) cont
CastIt co cont -> rebuild env (mkCast expr co) cont
-- NB: mkCast implements the (Coercion co |> g) optimisation -- NB: mkCast implements the (Coercion co |> g) optimisation
Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont Select _ bndr alts se cont -> rebuildCase (se `setFloats` env) expr bndr alts cont
StrictArg info _ cont -> rebuildCall env (info `addArgTo` expr) cont StrictArg info _ cont -> rebuildCall env (info `addValArgTo` expr) cont
StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr StrictBind b bs body se cont -> do { env' <- simplNonRecX (se `setFloats` env) b expr
-- expr satisfies let/app since it started life -- expr satisfies let/app since it started life
-- in a call to simplNonRecE -- in a call to simplNonRecE
; simplLam env' bs body cont } ; simplLam env' bs body cont }
ApplyTo dup_flag arg se cont -- See Note [Avoid redundant simplification]
ApplyToTy { sc_arg_ty = ty, sc_cont = cont}
-> rebuild env (App expr (Type ty)) cont
ApplyToVal { sc_arg = arg, sc_env = se, sc_dup = dup_flag, sc_cont = cont}
-- See Note [Avoid redundant simplification]
| isSimplified dup_flag -> rebuild env (App expr arg) cont | isSimplified dup_flag -> rebuild env (App expr arg) cont
| otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg | otherwise -> do { arg' <- simplExpr (se `setInScope` env) arg
; rebuild env (App expr arg') cont } ; rebuild env (App expr arg') cont }
TickIt t cont -> rebuild env (mkTick t expr) cont
{- {-
************************************************************************ ************************************************************************
...@@ -1192,7 +1206,7 @@ simplCast env body co0 cont0 ...@@ -1192,7 +1206,7 @@ simplCast env body co0 cont0
add_coerce _co (Pair s1 k1) cont -- co :: ty~ty add_coerce _co (Pair s1 k1) cont -- co :: ty~ty
| s1 `eqType` k1 = cont -- is a no-op | s1 `eqType` k1 = cont -- is a no-op
add_coerce co1 (Pair s1 _k2) (CoerceIt co2 cont) add_coerce co1 (Pair s1 _k2) (CastIt co2 cont)
| (Pair _l1 t1) <- coercionKind co2 | (Pair _l1 t1) <- coercionKind co2
-- e |> (g1 :: S1~L) |> (g2 :: L~T1) -- e |> (g1 :: S1~L) |> (g2 :: L~T1)
-- ==> -- ==>
...@@ -1204,20 +1218,19 @@ simplCast env body co0 cont0 ...@@ -1204,20 +1218,19 @@ simplCast env body co0 cont0
-- and we'd like it to simplify to e[y/x] in one round -- and we'd like it to simplify to e[y/x] in one round
-- of simplification -- of simplification
, s1 `eqType` t1 = cont -- The coerces cancel out , s1 `eqType` t1 = cont -- The coerces cancel out
| otherwise = CoerceIt (mkTransCo co1 co2) cont | otherwise = CastIt (mkTransCo co1 co2) cont
add_coerce co (Pair s1s2 _t1t2) (ApplyTo dup (Type arg_ty) arg_se cont) add_coerce co (Pair s1s2 _t1t2) cont@(ApplyToTy { sc_arg_ty = arg_ty, sc_cont = tail })
-- (f |> g) ty ---> (f ty) |> (g @ ty) -- (f |> g) ty ---> (f ty) |> (g @ ty)
-- This implements the PushT rule from the paper -- This implements the PushT rule from the paper
| Just (tyvar,_) <- splitForAllTy_maybe s1s2 | Just (tyvar,_) <- splitForAllTy_maybe s1s2
= ASSERT( isTyVar tyvar ) = ASSERT( isTyVar tyvar )
ApplyTo Simplified (Type arg_ty') (zapSubstEnv arg_se) (addCoerce new_cast cont) cont { sc_cont = addCoerce new_cast tail }
where where
new_cast = mkInstCo co arg_ty' new_cast = mkInstCo co arg_ty
arg_ty' | isSimplified dup = arg_ty
| otherwise = substTy (arg_se `setInScope` env) arg_ty
add_coerce co (Pair s1s2 t1t2) (ApplyTo dup arg arg_se cont) add_coerce co (Pair s1s2 t1t2) (ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup, sc_cont = cont })
| isFunTy s1s2 -- This implements the Push rule from the paper | isFunTy s1s2 -- This implements the Push rule from the paper
, isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg , isFunTy t1t2 -- Check t1t2 to ensure 'arg' is a value arg
-- (e |> (g :: s1s2 ~ t1->t2)) f -- (e |> (g :: s1s2 ~ t1->t2)) f
...@@ -1234,17 +1247,19 @@ simplCast env body co0 cont0 ...@@ -1234,17 +1247,19 @@ simplCast env body co0 cont0
-- But it isn't a common case. -- But it isn't a common case.
-- --
-- Example of use: Trac #995 -- Example of use: Trac #995
= ApplyTo dup new_arg (zapSubstEnv arg_se) (addCoerce co2 cont) = ApplyToVal { sc_arg = mkCast arg' (mkSymCo co1)
, sc_env = zapSubstEnv arg_se
, sc_dup = dup
, sc_cont = addCoerce co2 cont }
where where
-- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and -- we split coercion t1->t2 ~ s1->s2 into t1 ~ s1 and
-- t2 ~ s2 with left and right on the curried form: -- t2 ~ s2 with left and right on the curried form:
-- (->) t1 t2 ~ (->) s1 s2 -- (->) t1 t2 ~ (->) s1 s2
[co1, co2] = decomposeCo 2 co [co1, co2] = decomposeCo 2 co
new_arg = mkCast arg' (mkSymCo co1)
arg' = substExpr (text "move-cast") arg_se' arg arg' = substExpr (text "move-cast") arg_se' arg
arg_se' = arg_se `setInScope` env arg_se' = arg_se `setInScope` env
add_coerce co _ cont = CoerceIt co cont add_coerce co _ cont = CastIt co cont
{- {-
************************************************************************ ************************************************************************
...@@ -1273,7 +1288,13 @@ simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont ...@@ -1273,7 +1288,13 @@ simplLam :: SimplEnv -> [InId] -> InExpr -> SimplCont
simplLam env [] body cont = simplExprF env body cont simplLam env [] body cont = simplExprF env body cont
-- Beta reduction -- Beta reduction
simplLam env (bndr:bndrs) body (ApplyTo _ arg arg_se cont)
simplLam env (bndr:bndrs) body (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
= do { tick (BetaReduction bndr)
; simplLam (extendTvSubst env bndr arg_ty) bndrs body cont }
simplLam env (bndr:bndrs) body (ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_cont = cont })
= do { tick (BetaReduction bndr) = do { tick (BetaReduction bndr)
; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont } ; simplNonRecE env (zap_unfolding bndr) (arg, arg_se) (bndrs, body) cont }
where where
...@@ -1441,19 +1462,18 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con ...@@ -1441,19 +1462,18 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_strs = [] }) con
res = argInfoExpr fun rev_args res = argInfoExpr fun rev_args
cont_ty = contResultType cont cont_ty = contResultType cont
rebuildCall env info (CoerceIt co cont) rebuildCall env info (CastIt co cont)
= rebuildCall env (addCastTo info co) cont = rebuildCall env (addCastTo info co) cont
rebuildCall env info (ApplyTo dup_flag (Type arg_ty) se cont) rebuildCall env info (ApplyToTy { sc_arg_ty = arg_ty, sc_cont = cont })
= do { arg_ty' <- if isSimplified dup_flag then return arg_ty = rebuildCall env (info `addTyArgTo` arg_ty) cont
else simplType (se `setInScope` env) arg_ty
; rebuildCall env (info `addArgTo` Type arg_ty') cont }
rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
, ai_strs = str:strs, ai_discs = disc:discs }) , ai_strs = str:strs, ai_discs = disc:discs })
(ApplyTo dup_flag arg arg_se cont) (ApplyToVal { sc_arg = arg, sc_env = arg_se
, sc_dup = dup_flag, sc_cont = cont })
| isSimplified dup_flag -- See Note [Avoid redundant simplification] | isSimplified dup_flag -- See Note [Avoid redundant simplification]
= rebuildCall env (addArgTo info' arg) cont = rebuildCall env (addValArgTo info' arg) cont
| str -- Strict argument | str -- Strict argument
= -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $ = -- pprTrace "Strict Arg" (ppr arg $$ ppr (seIdSubst env) $$ ppr (seInScope env)) $
...@@ -1468,7 +1488,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty ...@@ -1468,7 +1488,7 @@ rebuildCall env info@(ArgInfo { ai_encl = encl_rules, ai_type = fun_ty
-- floating a demanded let. -- floating a demanded let.
= do { arg' <- simplExprC (arg_se `setInScope` env) arg = do { arg' <- simplExprC (arg_se `setInScope` env) arg
(mkLazyArgStop (funArgTy fun_ty) cci) (mkLazyArgStop (funArgTy fun_ty) cci)
; rebuildCall env (addArgTo info' arg') cont } ; rebuildCall env (addValArgTo info' arg') cont }
where where
info' = info { ai_strs = strs, ai_discs = discs } info' = info { ai_strs = strs, ai_discs = discs }
cci | encl_rules = RuleArgCtxt cci | encl_rules = RuleArgCtxt
...@@ -1483,11 +1503,11 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules }) ...@@ -1483,11 +1503,11 @@ rebuildCall env (ArgInfo { ai_fun = fun, ai_args = rev_args, ai_rules = rules })
= do { -- We've accumulated a simplified call in <fun,rev_args> = do { -- We've accumulated a simplified call in <fun,rev_args>
-- so try rewrite rules; see Note [RULEs apply to simplified arguments] -- so try rewrite rules; see Note [RULEs apply to simplified arguments]
-- See also Note [Rules for recursive functions] -- See also Note [Rules for recursive functions]
; let env' = zapSubstEnv env ; let env' = zapSubstEnv env -- See Note [zapSubstEnv];
(args, cont') = argInfoValArgs env' rev_args cont -- and NB that 'rev_args' are all fully simplified
; mb_rule <- tryRules env' rules fun args cont' ; mb_rule <- tryRules env' rules fun (reverse rev_args) cont
; case mb_rule of { ; case mb_rule of {
Just (rule_rhs, cont'') -> simplExprF env' rule_rhs cont'' Just (rule_rhs, cont') -> simplExprF env' rule_rhs cont'
-- Rules don't match -- Rules don't match
; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules ; Nothing -> rebuild env (argInfoExpr fun rev_args) cont -- No rules
...@@ -1549,7 +1569,7 @@ all this at once is TOO HARD! ...@@ -1549,7 +1569,7 @@ all this at once is TOO HARD!
-} -}
tryRules :: SimplEnv -> [CoreRule] tryRules :: SimplEnv -> [CoreRule]
-> Id -> [OutExpr] -> SimplCont -> Id -> [ArgSpec] -> SimplCont
-> SimplM (Maybe (CoreExpr, SimplCont)) -> SimplM (Maybe (CoreExpr, SimplCont))
-- The SimplEnv already has zapSubstEnv applied to it -- The SimplEnv already has zapSubstEnv applied to it
...@@ -1580,22 +1600,22 @@ tryRules env rules fn args call_cont ...@@ -1580,22 +1600,22 @@ tryRules env rules fn args call_cont
| otherwise | otherwise
= do { dflags <- getDynFlags = do { dflags <- getDynFlags
; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env) ; case lookupRule dflags (getUnfoldingInRuleMatch env) (activeRule env)
fn args rules of { fn (argInfoAppArgs args) rules of {
Nothing -> return Nothing ; -- No rule matches Nothing -> return Nothing ; -- No rule matches
Just (rule, rule_rhs) -> Just (rule, rule_rhs) ->
do { checkedTick (RuleFired (ru_name rule)) do { checkedTick (RuleFired (ru_name rule))
; dump dflags rule rule_rhs
; let cont' = pushSimplifiedArgs env ; let cont' = pushSimplifiedArgs env
(drop (ruleArity rule) args) (drop (ruleArity rule) args)
call_cont call_cont
-- (ruleArity rule) says how many args the rule consumed -- (ruleArity rule) says how many args the rule consumed
; dump dflags rule rule_rhs
; return (Just (rule_rhs, cont')) }}} ; return (Just (rule_rhs, cont')) }}}
where where
dump dflags rule rule_rhs dump dflags rule rule_rhs
| dopt Opt_D_dump_rule_rewrites dflags | dopt Opt_D_dump_rule_rewrites dflags
= log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat = log_rule dflags Opt_D_dump_rule_rewrites "Rule fired" $ vcat
[ text "Rule:" <+> ftext (ru_name rule) [ text "Rule:" <+> ftext (ru_name rule)
, text "Before:" <+> hang (ppr fn) 2 (sep (map pprParendExpr args)) , text "Before:" <+> hang (ppr fn) 2 (sep (map ppr args))
, text "After: " <+> pprCoreExpr rule_rhs , text "After: " <+> pprCoreExpr rule_rhs
, text "Cont: " <+> ppr call_cont ] , text "Cont: " <+> ppr call_cont ]
...@@ -1904,8 +1924,12 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont ...@@ -1904,8 +1924,12 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
| is_plain_seq | is_plain_seq
= do { let rhs' = substExpr (text "rebuild-case") env rhs = do { let rhs' = substExpr (text "rebuild-case") env rhs
env' = zapSubstEnv env env' = zapSubstEnv env
out_args = [Type (substTy env (idType case_bndr)), scrut_ty = substTy env (idType case_bndr)
Type (exprType rhs'), scrut, rhs'] out_args = [ TyArg { as_arg_ty = scrut_ty
, as_hole_ty = seq_id_ty }
, TyArg { as_arg_ty = exprType rhs'
, as_hole_ty = applyTy seq_id_ty scrut_ty }
, ValArg scrut, ValArg rhs']
-- Lazily evaluated, so we don't do most of this -- Lazily evaluated, so we don't do most of this
; rule_base <- getSimplRules ; rule_base <- getSimplRules
...@@ -1917,6 +1941,7 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont ...@@ -1917,6 +1941,7 @@ rebuildCase env scrut case_bndr alts@[(_, bndrs, rhs)] cont
is_unlifted = isUnLiftedType (idType case_bndr) is_unlifted = isUnLiftedType (idType case_bndr)
all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId] all_dead_bndrs = all isDeadBinder bndrs -- bndrs are [InId]
is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect is_plain_seq = all_dead_bndrs && isDeadBinder case_bndr -- Evaluation *only* for effect
seq_id_ty = idType seqId
scrut_is_demanded_var :: CoreExpr -> Bool scrut_is_demanded_var :: CoreExpr -> Bool
-- See Note [Eliminating redundant seqs] -- See Note [Eliminating redundant seqs]
...@@ -2324,7 +2349,7 @@ prepareCaseCont :: SimplEnv ...@@ -2324,7 +2349,7 @@ prepareCaseCont :: SimplEnv
-- When case-of-case is off, just make the entire continuation non-dupable -- When case-of-case is off, just make the entire continuation non-dupable
prepareCaseCont env alts cont prepareCaseCont env alts cont
| not (sm_case_case (getMode env)) = return (env, mkBoringStop (contInputType cont), cont) | not (sm_case_case (getMode env)) = return (env, mkBoringStop (contHoleType cont), cont)
| not (many_alts alts) = return (env, cont, mkBoringStop (contResultType cont)) | not (many_alts alts) = return (env, cont, mkBoringStop (contResultType cont))
| otherwise = mkDupableCont env cont | otherwise = mkDupableCont env cont
where where
...@@ -2359,16 +2384,16 @@ mkDupableCont env cont ...@@ -2359,16 +2384,16 @@ mkDupableCont env cont
mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn mkDupableCont _ (Stop {}) = panic "mkDupableCont" -- Handled by previous eqn
mkDupableCont env (CoerceIt ty cont) mkDupableCont env (CastIt ty cont)
= do { (env', dup, nodup) <- mkDupableCont env cont = do { (env', dup, nodup) <- mkDupableCont env cont
; return (env', CoerceIt ty dup, nodup) } ; return (env', CastIt ty dup, nodup) }
-- Duplicating ticks for now, not sure if this is good or not -- Duplicating ticks for now, not sure if this is good or not
mkDupableCont env cont@(TickIt{}) mkDupableCont env cont@(TickIt{})
= return (env, mkBoringStop (contInputType cont), cont) = return (env, mkBoringStop (contHoleType cont), cont)
mkDupableCont env cont@(StrictBind {}) mkDupableCont env cont@(StrictBind {})
= return (env, mkBoringStop (contInputType cont), cont) = return (env, mkBoringStop (contHoleType cont), cont)
-- See Note [Duplicating StrictBind] -- See Note [Duplicating StrictBind]
mkDupableCont env (StrictArg info cci cont) mkDupableCont env (StrictArg info cci cont)
...@@ -2377,7 +2402,11 @@ mkDupableCont env (StrictArg info cci cont) ...@@ -2377,7 +2402,11 @@ mkDupableCont env (StrictArg info cci cont)
; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info) ; (env'', args') <- mapAccumLM makeTrivialArg env' (ai_args info)
; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) } ; return (env'', StrictArg (info { ai_args = args' }) cci dup, nodup) }
mkDupableCont env (ApplyTo _ arg se cont) mkDupableCont env cont@(ApplyToTy { sc_cont = tail })
= do { (env', dup_cont, nodup_cont) <- mkDupableCont env tail
; return (env', cont { sc_cont = dup_cont }, nodup_cont ) }
mkDupableCont env (ApplyToVal { sc_arg = arg, sc_env = se, sc_cont = cont })
= -- e.g. [...hole...] (...arg...) = -- e.g. [...hole...] (...arg...)
-- ==> -- ==>
-- let a = ...arg... -- let a = ...arg...
...@@ -2385,7 +2414,8 @@ mkDupableCont env (ApplyTo _ arg se cont) ...@@ -2385,7 +2414,8 @@ mkDupableCont env (ApplyTo _ arg se cont)
do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont do { (env', dup_cont, nodup_cont) <- mkDupableCont env cont
; arg' <- simplExpr (se `setInScope` env') arg ; arg' <- simplExpr (se `setInScope` env') arg
; (env'', arg'') <- makeTrivial NotTopLevel env' arg' ; (env'', arg'') <- makeTrivial NotTopLevel env' arg'
; let app_cont = ApplyTo OkToDup arg'' (zapSubstEnv env'') dup_cont ; let app_cont = ApplyToVal { sc_arg = arg'', sc_env = zapSubstEnv env''
, sc_dup = OkToDup, sc_cont = dup_cont }
; return (env'', app_cont, nodup_cont) } ; return (env'', app_cont, nodup_cont) }
mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _) mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
...@@ -2395,7 +2425,7 @@ mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _) ...@@ -2395,7 +2425,7 @@ mkDupableCont env cont@(Select _ case_bndr [(_, bs, _rhs)] _ _)
| all isDeadBinder bs -- InIds | all isDeadBinder bs -- InIds
&& not (isUnLiftedType (idType case_bndr)) && not (isUnLiftedType (idType case_bndr))
-- Note [Single-alternative-unlifted] -- Note [Single-alternative-unlifted]
= return (env, mkBoringStop (contInputType cont), cont) = return (env, mkBoringStop (contHoleType cont), cont)
mkDupableCont env (Select _ case_bndr alts se cont) mkDupableCont env (Select _ case_bndr alts se cont)
= -- e.g. (case [...hole...] of { pi -> ei }) = -- e.g. (case [...hole...] of { pi -> ei })
...@@ -2430,7 +2460,7 @@ mkDupableCont env (Select _ case_bndr alts se cont) ...@@ -2430,7 +2460,7 @@ mkDupableCont env (Select _ case_bndr alts se cont)
; (env'', alts'') <- mkDupableAlts env' case_bndr' alts' ; (env'', alts'') <- mkDupableAlts env' case_bndr' alts'
; return (env'', -- Note [Duplicated env] ; return (env'', -- Note [Duplicated env]
Select OkToDup case_bndr' alts'' (zapSubstEnv env'') Select OkToDup case_bndr' alts'' (zapSubstEnv env'')
(mkBoringStop (contInputType nodup_cont)), (mkBoringStop (contHoleType nodup_cont)),
nodup_cont) } nodup_cont) }
...@@ -2710,7 +2740,7 @@ Much better! ...@@ -2710,7 +2740,7 @@ Much better!
Notice that Notice that
* Arguments to f *after* the strict one are handled by * Arguments to f *after* the strict one are handled by
the ApplyTo case of mkDupableCont. Eg the ApplyToVal case of mkDupableCont. Eg
f [..hole..] E f [..hole..] E
* We can only do the let-binding of E because the function * We can only do the let-binding of E because the function
......
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -O #-} -- -O casused a Lint error in the simplifier, so I'm putting that in
-- all the time, so we don't miss it in a fast validate
module T7891 where module T7891 where
......
{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RankNTypes #-}
{-# OPTIONS_GHC -O #-} -- -O casused a Lint error in the simplifier, so I'm putting that in
-- !!! Rank 2 polymorphism -- all the time, so we don't miss it in a fast validate
-- Both f and g are rejected by Hugs [April 2001]
-- !!! Rank 2 polymorphism
module Foo where -- Both f and g are rejected by Hugs [April 2001]
data T = T { t1 :: forall a. a -> a , t2 :: forall a b. a->b->b } module Foo where
-- Test pattern bindings for polymorphic fields data T = T { t1 :: forall a. a -> a , t2 :: forall a b. a->b->b }
f :: T -> (Int,Char)
f t = let T { t1 = my_t1 } = t -- Test pattern bindings for polymorphic fields
in f :: T -> (Int,Char)
(my_t1 3, my_t1 'c') f t = let T { t1 = my_t1 } = t
in
-- Test record update with polymorphic fields (my_t1 3, my_t1 'c')
g :: T -> T
g t = t { t2 = \x y -> y } -- Test record update with polymorphic fields
g :: T -> T
g t = t { t2 = \x y -> 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