Commit a27f7c87 authored by simonpj's avatar simonpj
Browse files

[project @ 2005-01-04 16:26:55 by simonpj]

------------------
          Fix an mdo bug
  	------------------

Embarassingly, this bug makes GHC either panic (for some programs) or
go into a loop (on others) in a recursive mdo that involves a
polymorphic function.  Urk!

The fix is twofold:
  a) add a missing bindInstsOfLocalFuns to tcStmtAndThen (RecStmt case)
  b) bind the correct set of variables in dsRecStmt

I added some explanatory comments about RecStmt in HsExpr too.

The tests is mdo/should_compile/mdo006
parent f3cdd93b
......@@ -34,8 +34,8 @@ import TcHsSyn ( hsPatType )
-- Sigh. This is a pain.
import TcType ( tcSplitAppTy, tcSplitFunTys, tcTyConAppTyCon, tcTyConAppArgs,
tcTyConAppArgs, isUnLiftedType, Type, mkAppTy )
import Type ( mkFunTys, funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
tcTyConAppArgs, isUnLiftedType, Type, mkAppTy, tcEqType )
import Type ( funArgTy, splitFunTys, isUnboxedTupleType, mkFunTy )
import CoreSyn
import CoreUtils ( exprType, mkIfThenElse, bindNonRec )
......@@ -640,32 +640,57 @@ dsRecStmt :: Type -- Monad type constructor :: * -> *
-> [Id] -> [Id] -> [LHsExpr Id]
-> Stmt Id
dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets
= ASSERT( length vars == length rets )
BindStmt tup_pat mfix_app
= ASSERT( length rec_vars > 0 )
ASSERT( length rec_vars == length rec_rets )
BindStmt (mk_tup_pat later_pats) mfix_app
where
vars@(var1:rest) = later_vars ++ rec_vars -- Always at least one
rets@(ret1:_) = map nlHsVar later_vars ++ rec_rets
one_var = null rest
-- Remove any vars from later_vars that already in rec_vars
-- NB that having the same name is not enough; they must have
-- the same type. See Note [RecStmt] in HsExpr.
trimmed_laters = filter not_in_rec later_vars
not_in_rec lv = null [ v | let lv_type = idType lv
, v <- rec_vars
, v == lv
, lv_type `tcEqType` idType v ]
mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [tup_pat] body]
mfix_arg = noLoc $ HsLam (MatchGroup [mkSimpleMatch [mfix_pat] body]
(mkFunTy tup_ty body_ty))
tup_expr | one_var = ret1
| otherwise = noLoc $ ExplicitTuple rets Boxed
var_tys = map idType vars
tup_ty = mkCoreTupTy var_tys -- Deals with singleton case
tup_pat | one_var = nlVarPat var1
| otherwise = noLoc $ LazyPat (noLoc $ TuplePat (map nlVarPat vars) Boxed)
body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt])
[(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack
body_ty
-- The rec_tup_pat must bind the rec_vars only; remember that the
-- trimmed_laters may share the same Names
-- Meanwhile, the later_pats must bind the later_vars
rec_tup_pats = map mk_wild_pat trimmed_laters ++ map nlVarPat rec_vars
later_pats = map nlVarPat trimmed_laters ++ map mk_later_pat rec_vars
rets = map nlHsVar trimmed_laters ++ rec_rets
mfix_pat = noLoc $ LazyPat $ mk_tup_pat rec_tup_pats
body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt])
[(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack
body_ty
body_ty = mkAppTy m_ty tup_ty
tup_ty = mkCoreTupTy (map idType (trimmed_laters ++ rec_vars))
-- mkCoreTupTy deals with singleton case
Var return_id = lookupReboundName ds_meths returnMName
Var mfix_id = lookupReboundName ds_meths mfixName
return_stmt = noLoc $ ResultStmt return_app
return_app = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty]) tup_expr
return_app = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty])
(mk_ret_tup rets)
mk_wild_pat :: Id -> LPat Id
mk_wild_pat v = noLoc $ WildPat $ idType v
mk_later_pat :: Id -> LPat Id
mk_later_pat v | v `elem` trimmed_laters = mk_wild_pat v
| otherwise = nlVarPat v
mk_tup_pat :: [LPat Id] -> LPat Id
mk_tup_pat [p] = p
mk_tup_pat ps = noLoc $ TuplePat ps Boxed
mk_ret_tup :: [LHsExpr Id] -> LHsExpr Id
mk_ret_tup [r] = r
mk_ret_tup rs = noLoc $ ExplicitTuple rs Boxed
\end{code}
......@@ -701,7 +701,7 @@ data Stmt id
| ParStmt [([LStmt id], [id])] -- After remaing, the ids are the binders
-- bound by the stmts and used subsequently
-- Recursive statement
-- Recursive statement (see Note [RecStmt] below)
| RecStmt [LStmt id]
--- The next two fields are only valid after renaming
[id] -- The ids are a subset of the variables bound by the stmts
......@@ -756,6 +756,30 @@ depends on the context. Consider the following contexts:
Array comprehensions are handled like list comprehensions -=chak
Note [RecStmt]
~~~~~~~~~~~~~~
Example:
HsDo [ BindStmt x ex
, RecStmt [a::forall a. a -> a, b]
[a::Int -> Int, c]
[ BindStmt b (return x)
, LetStmt a = ea
, BindStmt c ec ]
, return (a b) ]
Here, the RecStmt binds a,b,c; but
- Only a,b are used in the stmts *following* the RecStmt,
This 'a' is *polymorphic'
- Only a,c are used in the stmts *inside* the RecStmt
*before* their bindings
This 'a' is monomorphic
Nota Bene: the two a's have different types, even though they
have the same Name.
\begin{code}
instance OutputableBndr id => Outputable (Stmt id) where
ppr stmt = pprStmt stmt
......
......@@ -18,7 +18,7 @@ import {-# SOURCE #-} TcExpr( tcCheckRho, tcInferRho, tcMonoExpr )
import HsSyn ( HsExpr(..), LHsExpr, MatchGroup(..),
Match(..), LMatch, GRHSs(..), GRHS(..),
Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..),
ReboundNames, LPat,
ReboundNames, LPat, HsBindGroup(..),
pprMatch, isDoExpr,
pprMatchContext, pprStmtContext, pprStmtResultContext,
collectPatsBinders, glueBindsOnGRHSs
......@@ -40,11 +40,13 @@ import TcUnify ( Expected(..), zapExpectedType, readExpectedType,
unifyTauTy, subFunTys, unifyListTy, unifyTyConApp,
checkSigTyVarsWrt, zapExpectedBranches, tcSubExp, tcGen,
unifyAppTy )
import TcSimplify ( bindInstsOfLocalFuns )
import Name ( Name )
import TysWiredIn ( boolTy, parrTyCon, listTyCon )
import Id ( idType, mkLocalId )
import CoreFVs ( idFreeTyVars )
import VarSet
import BasicTypes ( RecFlag(..) )
import Util ( isSingleton, notNull )
import Outputable
import SrcLoc ( Located(..), noLoc )
......@@ -486,7 +488,6 @@ tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside
-- RecStmt
tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside
-- gaw 2004
= newTyFlexiVarTys (length recNames) liftedTypeKind `thenM` \ recTys ->
let
rec_ids = zipWith mkLocalId recNames recTys
......@@ -500,10 +501,15 @@ tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thi
tcExtendIdEnv later_ids $
-- NB: The rec_ids for the recursive things
-- already scope over this part
thing_inside `thenM` \ thing ->
-- already scope over this part. This binding may shadow
-- some of them with polymorphic things with the same Name
-- (see note [RecStmt] in HsExpr)
getLIE thing_inside `thenM` \ (thing, lie) ->
bindInstsOfLocalFuns lie later_ids `thenM` \ lie_binds ->
returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets)) thing)
returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets)) $
combine (L src_loc (LetStmt [HsBindGroup lie_binds [] Recursive])) $
thing)
where
combine_rec stmt (stmts, thing) = (stmt:stmts, thing)
......
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