Commit 525aeb93 authored by simonpj's avatar simonpj
Browse files

[project @ 2001-12-03 11:36:26 by simonpj]

------------------------------------
	Fix a tiresome and longstanding bug
	in typechecking of unlifted bindings
	------------------------------------

Consider

	data T = MkT Int# Int#

	f :: T -> Int#
	f t = a +# b
	    where
	      MkT a b = if ... then t else t

This should really be OK, but if the "..." includes
some constraints, the constraint simplifier was trying to
generate some d1=d2 bindings. This is Bad because the desugarer
treats unlifted bindings very specially (they are strict).

This commit fixes the problem, by ensuring we never get
local dictionary binding for an unlifted group.

This fixes the bug which has been making the Alpha port fall
over with a pattern-match failure in DsExpr.  Nothing to do
with Alpha; it's just that the word-size change gave rise
to a little more commoning-up of literals in the type checker
which in turn made the desugarer it fall over.
parent d1255b8f
...@@ -255,12 +255,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec ...@@ -255,12 +255,10 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
mapNF_Tc zonkId dict_ids `thenNF_Tc` \ zonked_dict_ids -> mapNF_Tc zonkId dict_ids `thenNF_Tc` \ zonked_dict_ids ->
mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids -> mapNF_Tc zonkId mono_ids `thenNF_Tc` \ zonked_mono_ids ->
-- CHECK FOR BOGUS UNLIFTED BINDINGS
checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids `thenTc_`
-- BUILD THE POLYMORPHIC RESULT IDs -- BUILD THE POLYMORPHIC RESULT IDs
let let
exports = zipWith mk_export binder_names zonked_mono_ids exports = zipWith mk_export binder_names zonked_mono_ids
poly_ids = [poly_id | (_, poly_id, _) <- exports]
dict_tys = map idType zonked_dict_ids dict_tys = map idType zonked_dict_ids
inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs] inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
...@@ -291,17 +289,28 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec ...@@ -291,17 +289,28 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
in in
traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds), traceTc (text "binding:" <+> ppr ((zonked_dict_ids, dict_binds),
exports, [idType poly_id | (_, poly_id, _) <- exports])) `thenTc_` exports, map idType poly_ids)) `thenTc_`
-- Check for an unlifted, non-overloaded group
-- In that case we must make extra checks
if any (isUnLiftedType . idType) zonked_mono_ids && null zonked_dict_ids
then -- Some bindings are unlifted
checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind `thenTc_`
returnTc (
AbsBinds [] [] exports inlines mbind',
lie_req, -- Do not generate even any x=y bindings
poly_ids
)
-- BUILD RESULTS else -- The normal case
returnTc ( returnTc (
AbsBinds real_tyvars_to_gen AbsBinds real_tyvars_to_gen
zonked_dict_ids zonked_dict_ids
exports exports
inlines inlines
(dict_binds `andMonoBinds` mbind'), (dict_binds `andMonoBinds` mbind'),
lie_free, lie_free, poly_ids
[poly_id | (_, poly_id, _) <- exports]
) )
attachNoInlinePrag no_inlines bndr attachNoInlinePrag no_inlines bndr
...@@ -309,7 +318,13 @@ attachNoInlinePrag no_inlines bndr ...@@ -309,7 +318,13 @@ attachNoInlinePrag no_inlines bndr
Just prag -> bndr `setInlinePragma` prag Just prag -> bndr `setInlinePragma` prag
Nothing -> bndr Nothing -> bndr
checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids -- Check that non-overloaded unlifted bindings are
-- a) non-recursive,
-- b) not top level,
-- c) non-polymorphic
-- d) not a multiple-binding group (more or less implied by (a))
checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind
= ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) ) = ASSERT( not (any ((eqKind unliftedTypeKind) . tyVarKind) real_tyvars_to_gen) )
-- The instCantBeGeneralised stuff in tcSimplify should have -- The instCantBeGeneralised stuff in tcSimplify should have
-- already raised an error if we're trying to generalise an -- already raised an error if we're trying to generalise an
...@@ -318,34 +333,19 @@ checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids ...@@ -318,34 +333,19 @@ checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind zonked_mono_ids
-- because we have more precise origin information. -- because we have more precise origin information.
-- That's why we just use an ASSERT here. -- That's why we just use an ASSERT here.
-- Check that pattern-bound variables are not unlifted checkTc (isNotTopLevel top_lvl)
(if or [ (idName id `elem` pat_binders) && isUnLiftedType (idType id) (unliftedBindErr "Top-level" mbind) `thenTc_`
| id <- zonked_mono_ids ] then checkTc (isNonRec is_rec)
addErrTc (unliftedBindErr "Pattern" mbind) (unliftedBindErr "Recursive" mbind) `thenTc_`
else checkTc (single_bind mbind)
returnTc () (unliftedBindErr "Multiple" mbind) `thenTc_`
) `thenTc_` checkTc (null real_tyvars_to_gen)
(unliftedBindErr "Polymorphic" mbind)
-- Unlifted bindings must be non-recursive,
-- not top level, non-polymorphic, and not pattern bound
if any (isUnLiftedType . idType) zonked_mono_ids then
checkTc (isNotTopLevel top_lvl)
(unliftedBindErr "Top-level" mbind) `thenTc_`
checkTc (isNonRec is_rec)
(unliftedBindErr "Recursive" mbind) `thenTc_`
checkTc (null real_tyvars_to_gen)
(unliftedBindErr "Polymorphic" mbind)
else
returnTc ()
where where
pat_binders :: [Name] single_bind (PatMonoBind _ _ _) = True
pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds) single_bind (FunMonoBind _ _ _ _) = True
single_bind other = False
justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
justPatBindings (AndMonoBinds b1 b2) binds =
justPatBindings b1 (justPatBindings b2 binds)
justPatBindings other_bind binds = binds
\end{code} \end{code}
......
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