diff options
| author | Simon Peyton Jones <simonpj@microsoft.com> | 2013-01-02 16:39:54 +0000 |
|---|---|---|
| committer | Simon Peyton Jones <simonpj@microsoft.com> | 2013-01-02 16:39:54 +0000 |
| commit | 6761dc2509de8b7f6b9f6f847d1e22f7a1849a79 (patch) | |
| tree | 167c2109fd30d8a0c181d82ead83ea3edd94dff0 /compiler/simplCore/Simplify.lhs | |
| parent | 948c1d312b79986eb12299f7d4876c9ca4fc5a7f (diff) | |
| download | haskell-6761dc2509de8b7f6b9f6f847d1e22f7a1849a79.tar.gz | |
Add an extra error check in DEBUG mode for ill-typed unfoldings
Diffstat (limited to 'compiler/simplCore/Simplify.lhs')
| -rw-r--r-- | compiler/simplCore/Simplify.lhs | 12 |
1 files changed, 9 insertions, 3 deletions
diff --git a/compiler/simplCore/Simplify.lhs b/compiler/simplCore/Simplify.lhs index af93f58ec4..88f46f4342 100644 --- a/compiler/simplCore/Simplify.lhs +++ b/compiler/simplCore/Simplify.lhs @@ -2069,16 +2069,22 @@ addAltUnfoldings env scrut case_bndr con_app -- See Note [Add unfolding for scrutinee] env2 = case scrut of - Just (Var v) -> addBinderUnfolding env1 v con_app_unf - Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ + Just (Var v) -> addBinderUnfolding env1 v con_app_unf + Just (Cast (Var v) co) -> addBinderUnfolding env1 v $ mkSimpleUnfolding dflags (Cast con_app (mkSymCo co)) - _ -> env1 + _ -> env1 ; traceSmpl "addAltUnf" (vcat [ppr case_bndr <+> ppr scrut, ppr con_app]) ; return env2 } addBinderUnfolding :: SimplEnv -> Id -> Unfolding -> SimplEnv addBinderUnfolding env bndr unf + | debugIsOn, Just tmpl <- maybeUnfoldingTemplate unf + = WARN( not (eqType (idType bndr) (exprType tmpl)), + ppr bndr $$ ppr (idType bndr) $$ ppr tmpl $$ ppr (exprType tmpl) ) + modifyInScope env (bndr `setIdUnfolding` unf) + + | otherwise = modifyInScope env (bndr `setIdUnfolding` unf) zapBndrOccInfo :: Bool -> Id -> Id |