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
mapNF_Tc zonkId dict_ids `thenNF_Tc` \ zonked_dict_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
let
exports = zipWith mk_export binder_names zonked_mono_ids
poly_ids = [poly_id | (_, poly_id, _) <- exports]
dict_tys = map idType zonked_dict_ids
inlines = mkNameSet [name | InlineSig True name _ loc <- inline_sigs]
......@@ -291,17 +289,28 @@ tcBindWithSigs top_lvl mbind tc_ty_sigs inline_sigs is_rec
in
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 (
AbsBinds real_tyvars_to_gen
zonked_dict_ids
exports
inlines
(dict_binds `andMonoBinds` mbind'),
lie_free,
[poly_id | (_, poly_id, _) <- exports]
lie_free, poly_ids
)
attachNoInlinePrag no_inlines bndr
......@@ -309,7 +318,13 @@ attachNoInlinePrag no_inlines bndr
Just prag -> bndr `setInlinePragma` prag
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) )
-- The instCantBeGeneralised stuff in tcSimplify should have
-- 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
-- because we have more precise origin information.
-- That's why we just use an ASSERT here.
-- Check that pattern-bound variables are not unlifted
(if or [ (idName id `elem` pat_binders) && isUnLiftedType (idType id)
| id <- zonked_mono_ids ] then
addErrTc (unliftedBindErr "Pattern" mbind)
else
returnTc ()
) `thenTc_`
-- 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 (single_bind mbind)
(unliftedBindErr "Multiple" mbind) `thenTc_`
checkTc (null real_tyvars_to_gen)
(unliftedBindErr "Polymorphic" mbind)
else
returnTc ()
where
pat_binders :: [Name]
pat_binders = collectMonoBinders (justPatBindings mbind EmptyMonoBinds)
justPatBindings bind@(PatMonoBind _ _ _) binds = bind `andMonoBinds` binds
justPatBindings (AndMonoBinds b1 b2) binds =
justPatBindings b1 (justPatBindings b2 binds)
justPatBindings other_bind binds = binds
single_bind (PatMonoBind _ _ _) = True
single_bind (FunMonoBind _ _ _ _) = True
single_bind other = False
\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