Commit 61bfd5dd authored by simonpj's avatar simonpj

[project @ 2001-10-31 15:22:53 by simonpj]

------------------------------------------
	Improved handling of scoped type variables
	------------------------------------------

The main effect of this commit is to allow scoped type variables
in pattern bindings, thus

	(x::a, y::b) = e

This was illegal, but now it's ok.  a and b have the same scope
as x and y.


On the way I beefed up the info inside a type variable
(TcType.TyVarDetails; c.f. IdInfo.GlobalIdDetails) which
helps to improve error messages. Hence the wide ranging changes.
Pity about the extra loop from Var to TcType, but can't be helped.
parent c01030fe
......@@ -14,8 +14,7 @@ module Var (
tyVarName, tyVarKind,
setTyVarName, setTyVarUnique,
mkTyVar, mkSysTyVar,
newMutTyVar, newSigTyVar,
readMutTyVar, writeMutTyVar, makeTyVarImmutable,
newMutTyVar, readMutTyVar, writeMutTyVar, makeTyVarImmutable,
-- Ids
Id, DictId,
......@@ -27,7 +26,7 @@ module Var (
mkLocalId, mkGlobalId, mkSpecPragmaId,
isTyVar, isMutTyVar, isSigTyVar,
isTyVar, isMutTyVar, mutTyVarDetails,
isId, isLocalVar, isLocalId,
isGlobalId, isExportedId, isSpecPragmaId,
mustHaveLocalBinding
......@@ -36,6 +35,7 @@ module Var (
#include "HsVersions.h"
import {-# SOURCE #-} TypeRep( Type, Kind )
import {-# SOURCE #-} TcType( TyVarDetails )
import {-# SOURCE #-} IdInfo( GlobalIdDetails, notGlobalId,
IdInfo, seqIdInfo )
......@@ -84,8 +84,7 @@ data VarDetails
| TyVar
| MutTyVar (IORef (Maybe Type)) -- Used during unification;
Bool -- True <=> this is a type signature variable, which
-- should not be unified with a non-tyvar type
TyVarDetails
-- For a long time I tried to keep mutable Vars statically type-distinct
-- from immutable Vars, but I've finally given up. It's just too painful.
......@@ -198,24 +197,15 @@ mkSysTyVar uniq kind = Var { varName = name
where
name = mkSysLocalName uniq SLIT("t")
newMutTyVar :: Name -> Kind -> IO TyVar
newMutTyVar name kind = newTyVar name kind False
newSigTyVar :: Name -> Kind -> IO TyVar
-- Type variables from type signatures are still mutable, because
-- they may get unified with type variables from other signatures
-- But they do contain a flag to distinguish them, so we can tell if
-- we unify them with a non-type-variable.
newSigTyVar name kind = newTyVar name kind True
newTyVar name kind is_sig
= do loc <- newIORef Nothing
return (Var { varName = name
, realUnique = getKey (nameUnique name)
, varType = kind
, varDetails = MutTyVar loc is_sig
, varInfo = pprPanic "newMutTyVar" (ppr name)
})
newMutTyVar :: Name -> Kind -> TyVarDetails -> IO TyVar
newMutTyVar name kind details
= do loc <- newIORef Nothing
return (Var { varName = name
, realUnique = getKey (nameUnique name)
, varType = kind
, varDetails = MutTyVar loc details
, varInfo = pprPanic "newMutTyVar" (ppr name)
})
readMutTyVar :: TyVar -> IO (Maybe Type)
readMutTyVar (Var {varDetails = MutTyVar loc _}) = readIORef loc
......@@ -225,6 +215,9 @@ writeMutTyVar (Var {varDetails = MutTyVar loc _}) val = writeIORef loc val
makeTyVarImmutable :: TyVar -> TyVar
makeTyVarImmutable tyvar = tyvar { varDetails = TyVar}
mutTyVarDetails :: TyVar -> TyVarDetails
mutTyVarDetails (Var {varDetails = MutTyVar _ details}) = details
\end{code}
......@@ -308,7 +301,7 @@ mkGlobalId details name ty info = mkId name ty (GlobalId details) info
\end{code}
\begin{code}
isTyVar, isMutTyVar, isSigTyVar :: Var -> Bool
isTyVar, isMutTyVar :: Var -> Bool
isId, isLocalVar, isLocalId :: Var -> Bool
isGlobalId, isExportedId, isSpecPragmaId :: Var -> Bool
mustHaveLocalBinding :: Var -> Bool
......@@ -321,8 +314,6 @@ isTyVar var = case varDetails var of
isMutTyVar (Var {varDetails = MutTyVar _ _}) = True
isMutTyVar other = False
isSigTyVar (Var {varDetails = MutTyVar _ is_sig}) = is_sig
isSigTyVar other = False
isId var = case varDetails var of
LocalId _ -> True
......
......@@ -165,13 +165,13 @@ dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
dsRule in_scope (IfaceRuleOut fun rule) -- Built-in rules come this way
= returnDs (fun, rule)
dsRule in_scope (HsRule name act sig_tvs vars lhs rhs loc)
dsRule in_scope (HsRule name act vars lhs rhs loc)
= putSrcLocDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
dsExpr rhs `thenDs` \ core_rhs ->
returnDs (fn, Rule name act tpl_vars args core_rhs)
where
tpl_vars = sig_tvs ++ [var | RuleBndr var <- vars]
tpl_vars = [var | RuleBndr var <- vars]
all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
ds_lhs all_vars lhs
......
......@@ -239,7 +239,7 @@ dsExpr (HsCase discrim matches src_loc)
returnDs (Case core_discrim bndr alts)
_ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code))
where
ubx_tuple_match (Match _ [TuplePat ps Unboxed] _ _) = True
ubx_tuple_match (Match [TuplePat ps Unboxed] _ _) = True
ubx_tuple_match _ = False
dsExpr (HsCase discrim matches src_loc)
......
......@@ -738,7 +738,7 @@ flattenMatches kind matches
ASSERT( all (tcEqType result_ty) result_tys )
returnDs (result_ty, eqn_infos)
where
flatten_match (Match _ pats _ grhss, n)
flatten_match (Match pats _ grhss, n)
= dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) ->
getSrcLocDs `thenDs` \ locn ->
returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result)
......
......@@ -18,7 +18,8 @@ module HsDecls (
tyClDeclName, tyClDeclNames, tyClDeclSysNames, tyClDeclTyVars,
isClassDecl, isSynDecl, isDataDecl, isIfaceSigDecl, countTyClDecls,
mkClassDeclSysNames, isIfaceRuleDecl, ifaceRuleDeclName,
getClassDeclSysNames, conDetailsTys
getClassDeclSysNames, conDetailsTys,
collectRuleBndrSigTys
) where
#include "HsVersions.h"
......@@ -768,9 +769,7 @@ data RuleDecl name pat
= HsRule -- Source rule
RuleName -- Rule name
Activation
[name] -- Forall'd tyvars, filled in by the renamer with
-- tyvars mentioned in sigs; then filled out by typechecker
[RuleBndr name] -- Forall'd term vars
[RuleBndr name] -- Forall'd vars; after typechecking this includes tyvars
(HsExpr name pat) -- LHS
(HsExpr name pat) -- RHS
SrcLoc
......@@ -789,18 +788,21 @@ data RuleDecl name pat
CoreRule
isIfaceRuleDecl :: RuleDecl name pat -> Bool
isIfaceRuleDecl (HsRule _ _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
isIfaceRuleDecl (HsRule _ _ _ _ _ _) = False
isIfaceRuleDecl other = True
ifaceRuleDeclName :: RuleDecl name pat -> name
ifaceRuleDeclName (IfaceRule _ _ _ n _ _ _) = n
ifaceRuleDeclName (IfaceRuleOut n r) = n
ifaceRuleDeclName (HsRule fs _ _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs)
ifaceRuleDeclName (HsRule fs _ _ _ _ _) = pprPanic "ifaceRuleDeclName" (ppr fs)
data RuleBndr name
= RuleBndr name
| RuleBndrSig name (HsType name)
collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name]
collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs]
instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
-- Works for IfaceRules only; used when comparing interface file versions
(IfaceRule n1 a1 bs1 f1 es1 rhs1 _) == (IfaceRule n2 a2 bs2 f2 es2 rhs2 _)
......@@ -810,15 +812,13 @@ instance (NamedThing name, Ord name) => Eq (RuleDecl name pat) where
instance (NamedThing name, Outputable name, Outputable pat)
=> Outputable (RuleDecl name pat) where
ppr (HsRule name act tvs ns lhs rhs loc)
ppr (HsRule name act ns lhs rhs loc)
= sep [text "{-# RULES" <+> doubleQuotes (ptext name) <+> ppr act,
pp_forall, ppr lhs, equals <+> ppr rhs,
text "#-}" ]
where
pp_forall | null tvs && null ns = empty
| otherwise = text "forall" <+>
fsep (map ppr tvs ++ map ppr ns)
<> dot
pp_forall | null ns = empty
| otherwise = text "forall" <+> fsep (map ppr ns) <> dot
ppr (IfaceRule name act tpl_vars fn tpl_args rhs loc)
= hsep [ doubleQuotes (ptext name), ppr act,
......
......@@ -443,8 +443,6 @@ patterns in each equation.
\begin{code}
data Match id pat
= Match
[id] -- Tyvars wrt which this match is universally quantified
-- empty after typechecking
[pat] -- The patterns
(Maybe (HsType id)) -- A type signature for the result of the match
-- Nothing after typechecking
......@@ -465,7 +463,7 @@ data GRHS id pat
mkSimpleMatch :: [pat] -> HsExpr id pat -> Type -> SrcLoc -> Match id pat
mkSimpleMatch pats rhs rhs_ty locn
= Match [] pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty)
= Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty)
unguardedRHS :: HsExpr id pat -> SrcLoc -> [GRHS id pat]
unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc]
......@@ -477,7 +475,7 @@ THis is something of a nuisance, but no more.
\begin{code}
getMatchLoc :: Match id pat -> SrcLoc
getMatchLoc (Match _ _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc
\end{code}
We know the list must have at least one @Match@ in it.
......@@ -500,7 +498,7 @@ pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)]
pprMatch :: (Outputable id, Outputable pat)
=> HsMatchContext id -> Match id pat -> SDoc
pprMatch ctxt (Match _ pats maybe_ty grhss)
pprMatch ctxt (Match pats maybe_ty grhss)
= pp_name ctxt <+> sep [sep (map ppr pats),
ppr_maybe_ty,
nest 2 (pprGRHSs ctxt grhss)]
......
......@@ -25,6 +25,7 @@ module HsSyn (
collectHsBinders, collectLocatedHsBinders,
collectMonoBinders, collectLocatedMonoBinders,
collectSigTysFromMonoBinds,
hsModuleName, hsModuleImports
) where
......@@ -149,3 +150,30 @@ collectMonoBinders binds
go (FunMonoBind f _ _ loc) acc = f : acc
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
\end{code}
%************************************************************************
%* *
\subsection{Getting patterns out of bindings}
%* *
%************************************************************************
Get all the pattern type signatures out of a bunch of bindings
\begin{code}
collectSigTysFromMonoBinds :: MonoBinds name (InPat name) -> [HsType name]
collectSigTysFromMonoBinds bind
= go bind []
where
go EmptyMonoBinds acc = acc
go (PatMonoBind pat _ loc) acc = collectSigTysFromPat pat ++ acc
go (FunMonoBind f _ ms loc) acc = go_matches ms acc
go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc)
-- A binding like x :: a = f y
-- is parsed as FunMonoBind, but for this purpose we
-- want to treat it as a pattern binding
go_matches [] acc = acc
go_matches (Match [] (Just sig) _ : matches) acc = sig : go_matches matches acc
go_matches (match : matches) acc = go_matches matches acc
\end{code}
......@@ -245,7 +245,7 @@ checkValDef lhs opt_sig grhss loc
= case isFunLhs lhs [] of
Just (f,inf,es) ->
checkPatterns loc es `thenP` \ps ->
returnP (RdrValBinding (FunMonoBind f inf [Match [] ps opt_sig grhss] loc))
returnP (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc))
Nothing ->
checkPattern loc lhs `thenP` \lhs ->
......@@ -324,7 +324,7 @@ groupBindings binds = group Nothing binds
-- than pattern bindings (tests/rename/should_fail/rnfail002).
group (Just (FunMonoBind f inf1 mtchs ignore_srcloc))
(RdrValBinding (FunMonoBind f' _
[mtch@(Match _ (_:_) _ _)] loc)
[mtch@(Match (_:_) _ _)] loc)
: binds)
| f == f' = group (Just (FunMonoBind f inf1 (mtch:mtchs) loc)) binds
......
{-
-----------------------------------------------------------------------------
$Id: Parser.y,v 1.75 2001/10/22 09:37:24 simonpj Exp $
$Id: Parser.y,v 1.76 2001/10/31 15:22:54 simonpj Exp $
Haskell grammar.
......@@ -454,7 +454,7 @@ rules :: { RdrBinding }
rule :: { RdrBinding }
: STRING activation rule_forall infixexp '=' srcloc exp
{ RdrHsDecl (RuleD (HsRule $1 $2 [] $3 $4 $7 $6)) }
{ RdrHsDecl (RuleD (HsRule $1 $2 $3 $4 $7 $6)) }
activation :: { Activation } -- Omitted means AlwaysActive
: {- empty -} { AlwaysActive }
......@@ -725,7 +725,7 @@ infixexp :: { RdrNameHsExpr }
exp10 :: { RdrNameHsExpr }
: '\\' srcloc aexp aexps opt_asig '->' srcloc exp
{% checkPatterns $2 ($3 : reverse $4) `thenP` \ ps ->
returnP (HsLam (Match [] ps $5
returnP (HsLam (Match ps $5
(GRHSs (unguardedRHS $8 $7)
EmptyBinds placeHolderType))) }
| 'let' declbinds 'in' exp { HsLet $2 $4 }
......@@ -852,7 +852,7 @@ alts1 :: { [RdrNameMatch] }
alt :: { RdrNameMatch }
: srcloc infixexp opt_sig ralt wherebinds
{% (checkPattern $1 $2 `thenP` \p ->
returnP (Match [] [p] $3
returnP (Match [p] $3
(GRHSs $4 $5 placeHolderType)) )}
ralt :: { [RdrNameGRHS] }
......
......@@ -44,7 +44,6 @@ module RdrHsSyn (
SigConverter,
extractHsTyRdrNames, extractHsTyRdrTyVars,
extractRuleBndrsTyVars,
extractHsCtxtRdrTyVars, extractGenericPatTyVars,
mkHsOpApp, mkClassDecl, mkClassOpSigDM, mkConDecl,
......@@ -130,12 +129,6 @@ extractHsTyRdrNames ty = nub (extract_ty ty [])
extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName]
extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty []))
extractRuleBndrsTyVars :: [RuleBndr RdrName] -> [RdrName]
extractRuleBndrsTyVars bndrs = filter isRdrTyVar (nub (foldr go [] bndrs))
where
go (RuleBndr _) acc = acc
go (RuleBndrSig _ ty) acc = extract_ty ty acc
extractHsCtxtRdrNames :: HsContext RdrName -> [RdrName]
extractHsCtxtRdrNames ty = nub (extract_ctxt ty [])
extractHsCtxtRdrTyVars :: HsContext RdrName -> [RdrName]
......@@ -176,8 +169,8 @@ extractGenericPatTyVars binds
get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms
get other acc = acc
get_m (Match _ (TypePatIn ty : _) _ _) acc = extract_ty ty acc
get_m other acc = acc
get_m (Match (TypePatIn ty : _) _ _) acc = extract_ty ty acc
get_m other acc = acc
\end{code}
......
......@@ -27,7 +27,7 @@ import RnMonad
import RnTypes ( rnHsSigType, rnHsType )
import RnExpr ( rnMatch, rnGRHSs, rnPat, checkPrecMatch )
import RnEnv ( bindLocatedLocalsRn, lookupBndrRn,
lookupGlobalOccRn, lookupSigOccRn,
lookupGlobalOccRn, lookupSigOccRn, bindPatSigTyVars,
warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn,
)
import CmdLineOpts ( DynFlag(..) )
......@@ -217,7 +217,8 @@ rnMonoBinds mbinds sigs thing_inside -- Non-empty monobinds
= -- Extract all the binders in this group,
-- and extend current scope, inventing new names for the new binders
-- This also checks that the names form a set
bindLocatedLocalsRn doc mbinders_w_srclocs $ \ new_mbinders ->
bindLocatedLocalsRn doc mbinders_w_srclocs $ \ new_mbinders ->
bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $
let
binder_set = mkNameSet new_mbinders
in
......@@ -388,7 +389,7 @@ rnMethodBinds gen_tyvars (FunMonoBind name inf matches locn)
where
-- Gruesome; bring into scope the correct members of the generic type variables
-- See comments in RnSource.rnSourceDecl(ClassDecl)
rn_match match@(Match _ (TypePatIn ty : _) _ _)
rn_match match@(Match (TypePatIn ty : _) _ _)
= extendTyVarEnvFVRn gen_tvs (rnMatch (FunRhs name) match)
where
tvs = map rdrNameOcc (extractHsTyRdrNames ty)
......
......@@ -596,24 +596,8 @@ bindTyVars2Rn doc_str tyvar_names enclosed_scope
bindLocatedLocalsRn doc_str located_tyvars $ \ names ->
enclosed_scope names (zipWith replaceTyVarName tyvar_names names)
bindTyVarsFVRn :: SDoc -> [HsTyVarBndr RdrName]
-> ([HsTyVarBndr Name] -> RnMS (a, FreeVars))
-> RnMS (a, FreeVars)
bindTyVarsFVRn doc_str rdr_names enclosed_scope
= bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
enclosed_scope tyvars `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs names)
bindTyVarsFV2Rn :: SDoc -> [HsTyVarBndr RdrName]
-> ([Name] -> [HsTyVarBndr Name] -> RnMS (a, FreeVars))
-> RnMS (a, FreeVars)
bindTyVarsFV2Rn doc_str rdr_names enclosed_scope
= bindTyVars2Rn doc_str rdr_names $ \ names tyvars ->
enclosed_scope names tyvars `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs names)
bindPatSigTyVars :: [RdrNameHsType]
-> ([Name] -> RnMS (a, FreeVars))
-> RnMS (a, FreeVars)
-> RnMS (a, FreeVars)
-- Find the type variables in the pattern type
-- signatures that must be brought into scope
......@@ -634,7 +618,7 @@ bindPatSigTyVars tys enclosed_scope
doc_sig = text "In a pattern type-signature"
in
bindLocatedLocalsRn doc_sig located_tyvars $ \ names ->
enclosed_scope names `thenRn` \ (thing, fvs) ->
enclosed_scope `thenRn` \ (thing, fvs) ->
returnRn (thing, delListFromNameSet fvs names)
......
......@@ -159,7 +159,7 @@ rnPat (TypePatIn name) =
\begin{code}
rnMatch :: HsMatchContext RdrName -> RdrNameMatch -> RnMS (RenamedMatch, FreeVars)
rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss)
rnMatch ctxt match@(Match pats maybe_rhs_sig grhss)
= pushSrcLocRn (getMatchLoc match) $
-- Bind pattern-bound type variables
......@@ -171,7 +171,7 @@ rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss)
doc_sig = text "In a result type-signature"
doc_pat = pprMatchContext ctxt
in
bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys) $ \ sig_tyvars ->
bindPatSigTyVars (rhs_sig_tys ++ pat_sig_tys) $
-- Note that we do a single bindLocalsRn for all the
-- matches together, so that we spot the repeated variable in
......@@ -196,7 +196,7 @@ rnMatch ctxt match@(Match _ pats maybe_rhs_sig grhss)
in
warnUnusedMatches unused_binders `thenRn_`
returnRn (Match sig_tyvars pats' maybe_rhs_sig' grhss', all_fvs)
returnRn (Match pats' maybe_rhs_sig' grhss', all_fvs)
-- The bindLocals and bindTyVars will remove the bound FVs
\end{code}
......@@ -571,7 +571,7 @@ rnStmt (ParStmt stmtss) thing_inside
rnStmt (BindStmt pat expr src_loc) thing_inside
= pushSrcLocRn src_loc $
rnExpr expr `thenRn` \ (expr', fv_expr) ->
bindPatSigTyVars (collectSigTysFromPat pat) $ \ sig_tyvars ->
bindPatSigTyVars (collectSigTysFromPat pat) $
bindLocalsFVRn doc (collectPatBinders pat) $ \ new_binders ->
rnPat pat `thenRn` \ (pat', fv_pat) ->
thing_inside (BindStmt pat' expr' src_loc) `thenRn` \ ((rest_binders, result), fvs) ->
......@@ -719,7 +719,7 @@ checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
checkPrecMatch False fn match
= returnRn ()
checkPrecMatch True op (Match _ (p1:p2:_) _ _)
checkPrecMatch True op (Match (p1:p2:_) _ _)
-- True indicates an infix lhs
= getModeRn `thenRn` \ mode ->
-- See comments with rnExpr (OpApp ...)
......
......@@ -167,8 +167,8 @@ instDeclFVs (InstDecl inst_ty _ _ maybe_dfun _)
(case maybe_dfun of { Just n -> unitFV n; Nothing -> emptyFVs })
----------------
ruleDeclFVs (HsRule _ _ _ _ _ _ _) = emptyFVs
ruleDeclFVs (IfaceRuleOut _ _) = emptyFVs
ruleDeclFVs (HsRule _ _ _ _ _ _) = emptyFVs
ruleDeclFVs (IfaceRuleOut _ _) = emptyFVs
ruleDeclFVs (IfaceRule _ _ vars _ args rhs _)
= delFVs (map ufBinderName vars) $
ufExprFVs rhs `plusFV` plusFVs (map ufExprFVs args)
......@@ -236,8 +236,8 @@ maybeGenericMatch :: RenamedMatch -> Maybe (RenamedHsType, RenamedMatch)
-- Tells whether a Match is for a generic definition
-- and extract the type from a generic match and put it at the front
maybeGenericMatch (Match tvs (TypePatIn ty : pats) sig_ty grhss)
= Just (ty, Match tvs pats sig_ty grhss)
maybeGenericMatch (Match (TypePatIn ty : pats) sig_ty grhss)
= Just (ty, Match pats sig_ty grhss)
maybeGenericMatch other_match = Nothing
\end{code}
......@@ -14,7 +14,7 @@ import HsSyn
import HscTypes ( GlobalRdrEnv )
import RdrName ( RdrName, isRdrDataCon, elemRdrEnv )
import RdrHsSyn ( RdrNameConDecl, RdrNameTyClDecl,
extractRuleBndrsTyVars, extractGenericPatTyVars
extractGenericPatTyVars
)
import RnHsSyn
import HsCore
......@@ -24,9 +24,9 @@ import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext )
import RnBinds ( rnTopBinds, rnMethodBinds, renameSigs, renameSigsFVs )
import RnEnv ( lookupTopBndrRn, lookupOccRn, lookupIfaceName,
lookupOrigNames, lookupSysBinder, newLocalsRn,
bindLocalsFVRn,
bindLocalsFVRn, bindPatSigTyVars,
bindTyVarsRn, bindTyVars2Rn,
bindTyVarsFV2Rn, extendTyVarEnvFVRn,
extendTyVarEnvFVRn,
bindCoreLocalRn, bindCoreLocalsRn, bindLocalNames,
checkDupOrQualNames, checkDupNames, mapFvRn
)
......@@ -229,11 +229,10 @@ rnIfaceRuleDecl (IfaceRuleOut fn rule) -- Builtin rules come this way
= lookupOccRn fn `thenRn` \ fn' ->
returnRn (IfaceRuleOut fn' rule)
rnHsRuleDecl (HsRule rule_name act tvs vars lhs rhs src_loc)
= ASSERT( null tvs )
pushSrcLocRn src_loc $
rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc)
= pushSrcLocRn src_loc $
bindPatSigTyVars (collectRuleBndrSigTys vars) $
bindTyVarsFV2Rn doc (map UserTyVar sig_tvs) $ \ sig_tvs' _ ->
bindLocalsFVRn doc (map get_var vars) $ \ ids ->
mapFvRn rn_var (vars `zip` ids) `thenRn` \ (vars', fv_vars) ->
......@@ -245,11 +244,10 @@ rnHsRuleDecl (HsRule rule_name act tvs vars lhs rhs src_loc)
bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)]
in
mapRn (addErrRn . badRuleVar rule_name) bad_vars `thenRn_`
returnRn (HsRule rule_name act sig_tvs' vars' lhs' rhs' src_loc,
returnRn (HsRule rule_name act vars' lhs' rhs' src_loc,
fv_vars `plusFV` fv_lhs `plusFV` fv_rhs)
where
doc = text "In the transformation rule" <+> ptext rule_name
sig_tvs = extractRuleBndrsTyVars vars
get_var (RuleBndr v) = v
get_var (RuleBndrSig v _) = v
......
......@@ -507,6 +507,20 @@ occAnalRhs env id rhs
= (final_usage, rhs')
where
(rhs_usage, rhs') = occAnal (rhsCtxt env) rhs
-- Note that we use an rhsCtxt. This tells the occ anal that it's
-- looking at an RHS, which has an effect in occAnalApp
--
-- But there's a problem. Consider
-- x1 = a0 : []
-- x2 = a1 : x1
-- x3 = a2 : x2
-- g = f x2
-- First time round, it looks as if x1 and x2 occur as an arg of a
-- let-bound constructor ==> give them a many-occurrence.
-- But then x3 is inlined (unconditionally as it happens) and
-- next time round, x2 will be, and the next time round x1 will be
-- Result: multiple simplifier iterations. Sigh.
-- Possible solution: use rhsCtxt for things that occur just once...
-- [March 98] A new wrinkle is that if the binder has specialisations inside
-- it then we count the specialised Ids as "extra rhs's". That way
......
......@@ -790,8 +790,19 @@ seems a bit fragile.
\begin{code}
preInlineUnconditionally :: SimplEnv -> TopLevelFlag -> InId -> Bool
preInlineUnconditionally env top_lvl bndr
-- | isTopLevel top_lvl = False
-- Top-level fusion lost if we do this for (e.g. string constants)
| isTopLevel top_lvl = False
-- If we don't have this test, consider
-- x = length [1,2,3]
-- The full laziness pass carefully floats all the cons cells to
-- top level, and preInlineUnconditionally floats them all back in.
-- Result is (a) static allocation replaced by dynamic allocation
-- (b) many simplifier iterations because this tickles
-- a related problem
--
-- On the other hand, I have seen cases where top-level fusion is
-- lost if we don't inline top level thing (e.g. string constants)
-- We'll have to see
| not active = False
| opt_SimplNoPreInlining = False
| otherwise = case idOccInfo bndr of
......@@ -859,19 +870,23 @@ gentle we are being.
activeInline :: SimplEnv -> OutId -> OccInfo -> Bool
activeInline env id occ
= case getMode env of
SimplGently -> isDataConWrapId id || isOneOcc occ
-- No inlining at all when doing gentle stuff,
-- except (a) things that occur once
-- and (b) (hack alert) data con wrappers
-- We want to inline data con wrappers even
-- in gentle mode because rule LHSs match better then
-- The reason for (a) is that too little clean-up happens if you
-- don't inline use-once things. Also a bit of inlining is *good* for
-- full laziness; it can expose constant sub-expressions.
-- Example in spectral/mandel/Mandel.hs, where the mandelset
-- function gets a useful let-float if you inline windowToViewport
SimplPhase n -> isActive n (idInlinePragma id)
SimplGently -> isOneOcc occ
-- No inlining at all when doing gentle stuff,
-- except for things that occur once
-- The reason is that too little clean-up happens if you
-- don't inline use-once things. Also a bit of inlining is *good* for
-- full laziness; it can expose constant sub-expressions.
-- Example in spectral/mandel/Mandel.hs, where the mandelset
-- function gets a useful let-float if you inline windowToViewport
-- NB: we used to have a second exception, for data con wrappers.
-- On the grounds that we use gentle mode for rule LHSs, and
-- they match better when data con wrappers are inlined.
-- But that only really applies to the trivial wrappers (like (:)),
-- and they are now constructed as Compulsory unfoldings (in MkId)
-- so they'll happen anyway.
SimplPhase n -> isActive n (idInlinePragma id)
-- Belongs in BasicTypes; this frag occurs in OccurAnal too
isOneOcc (OneOcc _ _) = True
......
......@@ -44,7 +44,7 @@ import InstEnv ( InstLookupResult(..), lookupInstEnv )
import TcMType ( zonkTcType, zonkTcTypes, zonkTcPredType,
zonkTcThetaType, tcInstTyVar, tcInstType,
)
import TcType ( Type,
import TcType ( Type, TcType, TcThetaType, TcPredType, TcTauType, TcTyVarSet,
SourceType(..), PredType, ThetaType,
tcSplitForAllTys, tcSplitForAllTys,
tcSplitMethodTy, tcSplitRhoTy, tcFunArgTy,
......
......@@ -15,7 +15,8 @@ import {-# SOURCE #-} TcExpr ( tcExpr )
import CmdLineOpts ( opt_NoMonomorphismRestriction )
import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..),
Match(..), HsMatchContext(..),
collectMonoBinders, andMonoBinds
collectMonoBinders, andMonoBinds,
collectSigTysFromMonoBinds
)
import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds )
import TcHsSyn ( TcMonoBinds, TcId, zonkId, mkHsLet )
......@@ -29,7 +30,7 @@ import TcEnv ( tcExtendLocalValEnv,
)
import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts )
import TcMonoType ( tcHsSigType, UserTypeCtxt(..), checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
TcSigInfo(..), tcTySig, maybeSig, sigCtxt, tcAddScopedTyVars
)
import TcPat ( tcPat )
import TcSimplify ( bindInstsOfLocalFuns )
......@@ -118,7 +119,14 @@ tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next
do_next
tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next
= -- TYPECHECK THE SIGNATURES
= -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE
-- Notice that they scope over
-- a) the type signatures in the binding group
-- b) the bindings in the group
-- c) the scope of the binding group (the "in" part)
tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $
-- TYPECHECK THE SIGNATURES
mapTc tcTySig [sig | sig@(Sig name _ _) <- sigs] `thenTc` \ tc_ty_sigs ->
tcBindWithSigs top_lvl bind tc_ty_sigs
......@@ -536,14 +544,14 @@ is_elem v vs = isIn "isUnResMono" v vs
isUnRestrictedGroup sigs (PatMonoBind other _ _) = False
isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs
isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = any isUnRestrictedMatch matches ||
isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = isUnRestrictedMatch matches ||
v `is_elem` sigs
isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 &&
isUnRestrictedGroup sigs mb2