-- 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 )
-> [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}
| 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
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
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
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 )
-- 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
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)
projects / ghc-hetmet.git / commitdiff