projects
/
ghc-hetmet.git
/ blobdiff
commit
grep
author
committer
pickaxe
?
search:
re
summary
|
shortlog
|
log
|
commit
|
commitdiff
|
tree
raw
|
inline
| side by side
Fix problem with selectors for GADT records with unboxed fields
[ghc-hetmet.git]
/
compiler
/
simplCore
/
Simplify.lhs
diff --git
a/compiler/simplCore/Simplify.lhs
b/compiler/simplCore/Simplify.lhs
index
36e723d
..
f477038
100644
(file)
--- a/
compiler/simplCore/Simplify.lhs
+++ b/
compiler/simplCore/Simplify.lhs
@@
-44,7
+44,8
@@
import CoreUtils ( exprIsDupable, exprIsTrivial, needsCaseBinding,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsHNF, findDefault, mergeAlts,
exprOkForSpeculation, exprArity,
exprIsConApp_maybe, mkPiTypes, findAlt,
exprType, exprIsHNF, findDefault, mergeAlts,
exprOkForSpeculation, exprArity,
- mkCoerce, mkSCC, mkInlineMe, applyTypeToArg
+ mkCoerce, mkSCC, mkInlineMe, applyTypeToArg,
+ dataConRepInstPat
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
)
import Rules ( lookupRule )
import BasicTypes ( isMarkedStrict )
@@
-611,7
+612,6
@@
completeLazyBind env top_lvl old_bndr new_bndr new_rhs
-- means that we can avoid tests in exprIsConApp, for example.
-- This is important: if exprIsConApp says 'yes' for a recursive
-- thing, then we can get into an infinite loop
-- means that we can avoid tests in exprIsConApp, for example.
-- This is important: if exprIsConApp says 'yes' for a recursive
-- thing, then we can get into an infinite loop
-
-- If the unfolding is a value, the demand info may
-- go pear-shaped, so we nuke it. Example:
-- let x = (a,b) in
-- If the unfolding is a value, the demand info may
-- go pear-shaped, so we nuke it. Example:
-- let x = (a,b) in
@@
-814,9
+814,12
@@
simplCast env body co cont
-- t2 :=: s2 with left and right on the curried form:
-- (->) t1 t2 :=: (->) s1 s2
[co1, co2] = decomposeCo 2 co
-- t2 :=: s2 with left and right on the curried form:
-- (->) t1 t2 :=: (->) s1 s2
[co1, co2] = decomposeCo 2 co
- new_arg = mkCoerce (mkSymCoercion co1) (substExpr arg_env arg)
- arg_env = setInScope arg_se env
- result = ApplyTo dup new_arg (zapSubstEnv env) (addCoerce co2 cont)
+ new_arg = mkCoerce (mkSymCoercion co1) arg'
+ arg' = case arg_se of
+ Nothing -> arg
+ Just arg_se -> substExpr (setInScope arg_se env) arg
+ result = ApplyTo dup new_arg (Just $ zapSubstEnv env)
+ (addCoerce co2 cont)
addCoerce co cont = CoerceIt co cont
in
simplType env co `thenSmpl` \ co' ->
addCoerce co cont = CoerceIt co cont
in
simplType env co `thenSmpl` \ co' ->
@@
-1517,6
+1520,7
@@
simplDefault :: SimplEnv
simplDefault env case_bndr' imposs_cons cont Nothing
= return [] -- No default branch
simplDefault env case_bndr' imposs_cons cont Nothing
= return [] -- No default branch
+
simplDefault env case_bndr' imposs_cons cont (Just rhs)
| -- This branch handles the case where we are
-- scrutinisng an algebraic data type
simplDefault env case_bndr' imposs_cons cont (Just rhs)
| -- This branch handles the case where we are
-- scrutinisng an algebraic data type
@@
-1549,7
+1553,10
@@
simplDefault env case_bndr' imposs_cons cont (Just rhs)
[con] -> -- It matches exactly one constructor, so fill it in
do { tick (FillInCaseDefault case_bndr')
[con] -> -- It matches exactly one constructor, so fill it in
do { tick (FillInCaseDefault case_bndr')
- ; con_alt <- mkDataConAlt con inst_tys rhs
+ ; us <- getUniquesSmpl
+ ; let (ex_tvs, co_tvs, arg_ids) =
+ dataConRepInstPat us con inst_tys
+ ; let con_alt = (DataAlt con, ex_tvs ++ co_tvs ++ arg_ids, rhs)
; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
-- The simplAlt must succeed with Just because we have
-- already filtered out construtors that can't match
; Just (_, alt') <- simplAlt env [] case_bndr' cont con_alt
-- The simplAlt must succeed with Just because we have
-- already filtered out construtors that can't match
@@
-1557,7
+1564,7
@@
simplDefault env case_bndr' imposs_cons cont (Just rhs)
two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
two_or_more -> simplify_default (map DataAlt gadt_imposs ++ imposs_cons)
- | otherwise
+ | otherwise
= simplify_default imposs_cons
where
cant_match tys data_con = not (dataConCanMatch data_con tys)
= simplify_default imposs_cons
where
cant_match tys data_con = not (dataConCanMatch data_con tys)
@@
-1693,7
+1700,7
@@
knownCon env scrut con args bndr alts cont
simplExprF env rhs cont
(DataAlt dc, bs, rhs)
simplExprF env rhs cont
(DataAlt dc, bs, rhs)
- -> ASSERT( n_drop_tys + length bs == length args )
+ -> -- ASSERT( n_drop_tys + length bs == length args )
bind_args env dead_bndr bs (drop n_drop_tys args) $ \ env ->
let
-- It's useful to bind bndr to scrut, rather than to a fresh
bind_args env dead_bndr bs (drop n_drop_tys args) $ \ env ->
let
-- It's useful to bind bndr to scrut, rather than to a fresh
@@
-1713,6
+1720,7
@@
knownCon env scrut con args bndr alts cont
simplNonRecX env bndr bndr_rhs $ \ env ->
simplExprF env rhs cont
where
simplNonRecX env bndr bndr_rhs $ \ env ->
simplExprF env rhs cont
where
+ dead_bndr = isDeadBinder bndr
n_drop_tys = tyConArity (dataConTyCon dc)
-- Ugh!
n_drop_tys = tyConArity (dataConTyCon dc)
-- Ugh!