let
n_val_binders = length val_binders
--- max_inline_size = n_val_binders+2
+ max_inline_size = n_val_binders+2
-- The idea is that if there is an INLINE pragma (inline is True)
-- and there's a big body, we give a size of n_val_binders+2. This
-- This is just enough to fail the no-size-increase test in callSiteInline,
-- but no more.
-- Experimental thing commented in for now
- max_inline_size = case cpr_info of
- NoCPRInfo -> n_val_binders + 2
- ReturnsCPR -> n_val_binders + 1
+-- max_inline_size = case cpr_info of
+-- NoCPRInfo -> n_val_binders + 2
+-- ReturnsCPR -> n_val_binders + 1
-- However, the wrapper for a CPR'd function is particularly good to inline,
-- even in a boring context, because we may get to do update in place:
-- Constructors have compulsory unfoldings, but
-- may have rules, in which case they are
-- black listed till later
- CoreUnfolding unf_template is_top is_cheap _ is_bot guidance ->
+ CoreUnfolding unf_template is_top is_cheap is_value is_bot guidance ->
let
result | yes_or_no = Just unf_template
n_val_args = length arg_infos
- ok_inside_lam = is_cheap || is_bot -- I'm experimenting with is_cheap
- -- instead of is_value
+ ok_inside_lam = is_value || is_bot || (is_cheap && not is_top)
+ -- I'm experimenting with is_cheap && not is_top
yes_or_no
| black_listed = False
text "occ info:" <+> ppr occ,
text "arg infos" <+> ppr arg_infos,
text "interesting continuation" <+> ppr interesting_cont,
+ text "is value:" <+> ppr is_value,
text "is cheap:" <+> ppr is_cheap,
text "is bottom:" <+> ppr is_bot,
text "is top-level:" <+> ppr is_top,
opt_UF_ScrutConDiscount = lookup_def_int "-funfolding-con-discount" (2::Int)
opt_UF_FunAppDiscount = lookup_def_int "-funfolding-fun-discount" (6::Int) -- It's great to inline a fn
opt_UF_PrimArgDiscount = lookup_def_int "-funfolding-prim-discount" (1::Int)
-opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.0::Float)
+opt_UF_KeenessFactor = lookup_def_float "-funfolding-keeness-factor" (1.5::Float)
opt_UF_CheapOp = ( 1 :: Int) -- Only one instruction; and the args are charged for
opt_UF_DearOp = ( 4 :: Int)
\end{code}
\begin{code}
-main =
+main = stderr `seq` -- Bug fix. Sigh
-- _scc_ "main"
doIt classifyOpts
\end{code}
{-
-----------------------------------------------------------------------------
-$Id: Parser.y,v 1.28 2000/03/23 17:45:22 simonpj Exp $
+$Id: Parser.y,v 1.29 2000/03/24 17:49:30 simonpj Exp $
Haskell grammar.
| topdecl { [$1] }
topdecl :: { RdrBinding }
- : srcloc 'type' simpletype '=' type
+ : srcloc 'type' simpletype '=' sigtype
{ RdrHsDecl (TyClD (TySynonym (fst $3) (snd $3) $5 $1)) }
| srcloc 'data' ctype '=' constrs deriving
availNames (Avail n) = [n]
availNames (AvailTC n ns) = ns
+addSysAvails :: AvailInfo -> [Name] -> AvailInfo
+addSysAvails avail [] = avail
+addSysAvails (AvailTC n ns) sys = AvailTC n (sys ++ ns)
+
filterAvail :: RdrNameIE -- Wanted
-> AvailInfo -- Available
-> Maybe AvailInfo -- Resulting available;
import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName,
lookupOccRn, lookupImplicitOccRn,
pprAvail,
- availName, availNames, addAvailToNameSet,
+ availName, availNames, addAvailToNameSet, addSysAvails,
FreeVars, emptyFVs
)
import RnMonad
getDeclSysBinders new_name decl `thenRn` \ sys_bndrs ->
let
+ full_avail = addSysAvails avail sys_bndrs
+ -- Add the sys-binders to avail. When we import the decl,
+ -- it's full_avail that will get added to the 'already-slurped' set (iSlurp)
+ -- If we miss out sys-binders, we'll read the decl multiple times!
+
main_name = availName avail
new_decls_map = foldl add_decl decls_map
- [ (name, (version, avail, name==main_name, (mod, decl')))
- | name <- sys_bndrs ++ availNames avail]
+ [ (name, (version, full_avail, name==main_name, (mod, decl')))
+ | name <- availNames full_avail]
add_decl decls_map (name, stuff)
= WARN( name `elemNameEnv` decls_map, ppr name )
addToNameEnv decls_map name stuff
import List ( partition, nub )
import Outputable
import SrcLoc ( SrcLoc )
-import CmdLineOpts ( opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
+import CmdLineOpts ( opt_GlasgowExts, opt_WarnUnusedMatches ) -- Warn of unused for-all'd tyvars
import Unique ( Uniquable(..) )
import UniqFM ( lookupUFM )
import ErrUtils ( Message )
= pushSrcLocRn src_loc $
lookupBndrRn name `thenRn` \ name' ->
bindTyVarsFVRn syn_doc tyvars $ \ tyvars' ->
- rnHsType syn_doc ty `thenRn` \ (ty', ty_fvs) ->
+ rnHsPolyType syn_doc (unquantify ty) `thenRn` \ (ty', ty_fvs) ->
returnRn (TyClD (TySynonym name' tyvars' ty' src_loc), ty_fvs)
where
syn_doc = text "the declaration for type synonym" <+> quotes (ppr name)
+ -- For H98 we do *not* universally quantify on the RHS of a synonym
+ -- Silently discard context... but the tyvars in the rest won't be in scope
+ unquantify (HsForAllTy Nothing ctxt ty) | not opt_GlasgowExts = ty
+ unquantify ty = ty
+
rnDecl (TyClD (ClassDecl context cname tyvars fds sigs mbinds pragmas
tname dname dwname snames src_loc))
= pushSrcLocRn src_loc $
---------------------------------------
rnHsPolyType doc (HsForAllTy Nothing ctxt ty)
- -- From source code (no kinds on tyvars)
+ -- Implicit quantifiction in source code (no kinds on tyvars)
-- Given the signature C => T we universally quantify
-- over FV(T) \ {in-scope-tyvars}
= getLocalNameEnv `thenRn` \ name_env ->
ltMajLvl :: Level -> Level -> Bool
-- Tells if one level belongs to a difft *lambda* level to another
+ -- But it returns True regardless if l1 is the top level
+ -- We always like to float to the top!
+ltMajLvl (Level 0 0) _ = True
ltMajLvl (Level maj1 _) (Level maj2 _) = maj1 < maj2
isTopLvl :: Level -> Bool
lvlExpr _ env (_, AnnLit lit) = returnLvl (Lit lit)
lvlExpr ctxt_lvl env (_, AnnApp fun arg)
- = lvlExpr ctxt_lvl env fun `thenLvl` \ fun' ->
+ = lvl_fun fun `thenLvl` \ fun' ->
lvlMFE False ctxt_lvl env arg `thenLvl` \ arg' ->
returnLvl (App fun' arg')
+ where
+ lvl_fun (_, AnnCase _ _ _) = lvlMFE True ctxt_lvl env fun
+ lvl_fun other = lvlExpr ctxt_lvl env fun
+ -- We don't do MFE on partial applications generally,
+ -- but we do if the function is big and hairy, like a case
lvlExpr ctxt_lvl env (_, AnnNote InlineMe expr)
-- Don't float anything out of an InlineMe
lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
| isUnLiftedType ty -- Can't let-bind it
- || not (dest_lvl `ltMajLvl` ctxt_lvl) -- Does not escape a value lambda
- -- A decision to float entails let-binding this thing, and we only do
- -- that if we'll escape a value lambda. I considered doing it if it
- -- would make the thing go to top level, but I found things like
- -- concat = /\ a -> foldr ..a.. (++) []
- -- was getting turned into
- -- concat = /\ a -> lvl a
- -- lvl = /\ a -> foldr ..a.. (++) []
- -- which is pretty stupid. So for now at least, I don't let-bind things
- -- simply because they could go to top level.
+ || not good_destination
|| exprIsTrivial expr -- Is trivial
|| (strict_ctxt && exprIsBottom expr) -- Strict context and is bottom
= -- Don't float it out
ty = exprType expr
dest_lvl = destLevel env fvs (isFunction ann_expr)
abs_vars = abstractVars dest_lvl env fvs
+
+ good_destination = dest_lvl `ltMajLvl` ctxt_lvl -- Escapes a value lambda
+ || (isTopLvl dest_lvl && not strict_ctxt) -- Goes to the top
+ -- A decision to float entails let-binding this thing, and we only do
+ -- that if we'll escape a value lambda, or will go to the top level.
+ -- But beware
+ -- concat = /\ a -> foldr ..a.. (++) []
+ -- was getting turned into
+ -- concat = /\ a -> lvl a
+ -- lvl = /\ a -> foldr ..a.. (++) []
+ -- which is pretty stupid. Hence the strict_ctxt test
\end{code}
import Name ( isLocalName, setNameUnique )
import SimplMonad
import Type ( Type, tyVarsOfType, tyVarsOfTypes, mkForAllTys, seqType,
- splitTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
+ splitTyConApp_maybe, splitAlgTyConApp_maybe, mkTyVarTys, applyTys, splitFunTys, mkFunTys
)
+import DataCon ( dataConRepArity )
import TysPrim ( statePrimTyCon )
import Var ( setVarUnique )
import VarSet
analyse_arg subst (Note _ a) = analyse_arg subst a
analyse_arg subst other = True
- interesting_call_context (Stop _) = False
+ interesting_call_context (Stop ty) = canUpdateInPlace ty
interesting_call_context (InlinePlease _) = True
interesting_call_context (Select _ _ _ _ _) = True
interesting_call_context (CoerceIt _ cont) = interesting_call_context cont
discardInline (InlinePlease cont) = cont
discardInline (ApplyTo d e s cont) = ApplyTo d e s (discardInline cont)
discardInline cont = cont
+
+-- Consider let x = <wurble> in ...
+-- If <wurble> returns an explicit constructor, we might be able
+-- to do update in place. So we treat even a thunk RHS context
+-- as interesting if update in place is possible. We approximate
+-- this by seeing if the type has a single constructor with a
+-- small arity. But arity zero isn't good -- we share the single copy
+-- for that case, so no point in sharing.
+
+canUpdateInPlace ty = case splitAlgTyConApp_maybe ty of
+ Just (_, _, [dc]) -> arity == 1 || arity == 2
+ where
+ arity = dataConRepArity dc
+ other -> False
\end{code}
simplExprF fun (ApplyTo NoDup arg se cont)
simplExprF (Case scrut bndr alts) cont
- = getSubst `thenSmpl` \ subst ->
+ = getSubstEnv `thenSmpl` \ subst_env ->
getSwitchChecker `thenSmpl` \ chkr ->
- if switchIsOn chkr NoCaseOfCase then
- -- If case-of-case is off, simply simplify the scrutinee and rebuild
- simplExprC scrut (Stop (substTy subst (idType bndr))) `thenSmpl` \ scrut' ->
- rebuild_case False scrut' bndr alts (substEnv subst) cont
+ if not (switchIsOn chkr NoCaseOfCase) then
+ -- Simplify the scrutinee with a Select continuation
+ simplExprF scrut (Select NoDup bndr alts subst_env cont)
+
else
- -- But if it's on, we simplify the scrutinee with a Select continuation
- simplExprF scrut (Select NoDup bndr alts (substEnv subst) cont)
+ -- If case-of-case is off, simply simplify the case expression
+ -- in a vanilla Stop context, and rebuild the result around it
+ simplExprC scrut (Select NoDup bndr alts subst_env
+ (Stop (contResultType cont))) `thenSmpl` \ case_expr' ->
+ rebuild case_expr' cont
simplExprF (Let (Rec pairs) body) cont
-- v = E
-- z = \w -> g v w
-- Which is what we want; chances are z will be inlined now.
+--
+-- This defn isn't quite like
+-- exprIsCheap (it ignores non-cheap args)
+-- exprIsValue (may not say True for a lone variable)
+-- which is slightly weird
wantToExpose n (Var v) = idAppIsCheap v n
wantToExpose n (Lit l) = True
-wantToExpose n (Lam _ e) = ASSERT( n==0 ) True -- We won't have applied \'s
+wantToExpose n (Lam _ e) = True
wantToExpose n (Note _ e) = wantToExpose n e
wantToExpose n (App f (Type _)) = wantToExpose n f
wantToExpose n (App f a) = wantToExpose (n+1) f
completeCall var occ cont
= getBlackList `thenSmpl` \ black_list_fn ->
- getSwitchChecker `thenSmpl` \ chkr ->
getInScope `thenSmpl` \ in_scope ->
+ getSwitchChecker `thenSmpl` \ chkr ->
let
- black_listed = black_list_fn var
+ dont_use_rules = switchIsOn chkr DontApplyRules
+ no_case_of_case = switchIsOn chkr NoCaseOfCase
+ black_listed = black_list_fn var
+
(arg_infos, interesting_cont, inline_call) = analyseCont in_scope cont
discard_inline_cont | inline_call = discardInline cont
| otherwise = cont
-- won't occur for things that have specialisations till a later phase, so
-- it's ok to try for inlining first.
- prepareArgs (switchIsOn chkr NoCaseOfCase) var cont $ \ args' cont' ->
+ prepareArgs no_case_of_case var cont $ \ args' cont' ->
let
- maybe_rule | switchIsOn chkr DontApplyRules = Nothing
- | otherwise = lookupRule in_scope var args'
+ maybe_rule | dont_use_rules = Nothing
+ | otherwise = lookupRule in_scope var args'
in
case maybe_rule of {
Just (rule_name, rule_rhs) ->
= rebuild (Note InlineCall expr) cont
rebuild scrut (Select _ bndr alts se cont)
- = rebuild_case True scrut bndr alts se cont
+ = rebuild_case scrut bndr alts se cont
\end{code}
Case elimination [see the code above]
---------------------------------------------------------
-- Eliminate the case if possible
-rebuild_case add_eval_info scrut bndr alts se cont
+rebuild_case scrut bndr alts se cont
| maybeToBool maybe_con_app
= knownCon scrut (DataAlt con) args bndr alts se cont
simplExprF (head (rhssOfAlts alts)) cont)
| otherwise
- = complete_case add_eval_info scrut bndr alts se cont
+ = complete_case scrut bndr alts se cont
where
maybe_con_app = analyse (collectArgs scrut)
---------------------------------------------------------
-- Case of something else
-complete_case add_eval_info scrut case_bndr alts se cont
+complete_case scrut case_bndr alts se cont
= -- Prepare case alternatives
prepareCaseAlts case_bndr (splitTyConApp_maybe (idType case_bndr))
impossible_cons alts `thenSmpl` \ better_alts ->
-- Deal with variable scrutinee
- ( simplCaseBinder add_eval_info scrut case_bndr $ \ case_bndr' zap_occ_info ->
+ (
+ getSwitchChecker `thenSmpl` \ chkr ->
+ simplCaseBinder (switchIsOn chkr NoCaseOfCase)
+ scrut case_bndr $ \ case_bndr' zap_occ_info ->
-- Deal with the case alternatives
simplAlts zap_occ_info impossible_cons
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
import TcImprove ( tcImprove )
-import TcMonoType ( tcHsType, checkSigTyVars,
+import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
tcAddErrCtxt (valSpecSigCtxt name poly_ty) $
-- Get and instantiate its alleged specialised type
- tcHsType poly_ty `thenTc` \ sig_ty ->
+ tcHsSigType poly_ty `thenTc` \ sig_ty ->
-- Check that f has a more general type, and build a RHS for
-- the spec-pragma-id at the same time
import TcBinds ( tcBindWithSigs, tcSpecSigs )
import TcUnify ( unifyKinds )
import TcMonad
-import TcMonoType ( tcHsType, tcHsTopType, tcExtendTopTyVarScope,
+import TcMonoType ( kcHsType, tcHsTopType, tcExtendTopTyVarScope,
tcContext, checkSigTyVars, sigCtxt, mkTcSig
)
import TcSimplify ( tcSimplifyAndCheck, bindInstsOfLocalFuns )
where
the_class_sigs = filter isClassOpSig class_sigs
- kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (tcHsType op_ty)
+ kc_sig (ClassOpSig _ _ _ op_ty loc) = tcAddSrcLoc loc (kcHsType op_ty)
\end{code}
tcLookupTyCon, tcLookupDataCon
)
import TcMatches ( tcMatchesCase, tcMatchLambda, tcStmts )
-import TcMonoType ( tcHsType, checkSigTyVars, sigCtxt )
+import TcMonoType ( tcHsSigType, checkSigTyVars, sigCtxt )
import TcPat ( badFieldCon )
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, partitionPredsOfLIE )
import TcType ( TcType, TcTauType,
\begin{code}
tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty
= tcSetErrCtxt (exprSigCtxt in_expr) $
- tcHsType poly_ty `thenTc` \ sig_tc_ty ->
+ tcHsSigType poly_ty `thenTc` \ sig_tc_ty ->
if not (isForAllTy sig_tc_ty) then
-- Easy case
import TcType ( TcType, TcTyVar,
zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
)
-import TyCon ( isDataTyCon )
import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
import Name ( isLocallyDefined )
import Var ( TyVar )
import PrelInfo ( eRROR_ID )
import PprType ( pprConstraint )
import SrcLoc ( SrcLoc )
-import TyCon ( isSynTyCon, isDataTyCon, tyConDerivings )
+import TyCon ( isSynTyCon, tyConDerivings )
import Type ( Type, isUnLiftedType, mkTyVarTys,
splitSigmaTy, isTyVarTy,
splitTyConApp_maybe, splitDictTy_maybe,
import TcHsSyn ( TcMatch, TcGRHSs, TcStmt )
import TcMonad
-import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsType, sigPatCtxt )
+import TcMonoType ( checkSigTyVars, tcHsTyVar, tcHsSigType, sigPatCtxt )
import Inst ( Inst, LIE, plusLIE, emptyLIE, plusLIEs )
import TcEnv ( tcExtendLocalValEnv, tcExtendGlobalTyVars, tcExtendTyVarEnv, tcGetGlobalTyVars )
import TcPat ( tcPat, tcPatBndr_NoSigs, polyPatSig )
-- STEP 3: Unify with the rhs type signature if any
(case maybe_rhs_sig of
Nothing -> returnTc ()
- Just sig -> tcHsType sig `thenTc` \ sig_ty ->
+ Just sig -> tcHsSigType sig `thenTc` \ sig_ty ->
-- Check that the signature isn't a polymorphic one, which
-- we don't permit (at present, anyway)
\section[TcMonoType]{Typechecking user-specified @MonoTypes@}
\begin{code}
-module TcMonoType ( tcHsType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
- tcContext, tcHsTyVar, kcHsTyVar,
+module TcMonoType ( tcHsType, tcHsSigType, tcHsTypeKind, tcHsTopType, tcHsTopBoxedType, tcHsTopTypeKind,
+ tcContext, tcHsTyVar, kcHsTyVar, kcHsType,
tcExtendTyVarScope, tcExtendTopTyVarScope,
TcSigInfo(..), tcTySig, mkTcSig, maybeSig,
checkSigTyVars, sigCtxt, sigPatCtxt
import TcUnify ( unifyKind, unifyKinds, unifyTypeKind )
import Type ( Type, PredType(..), ThetaType, UsageAnn(..),
mkTyVarTy, mkTyVarTys, mkFunTy, mkSynTy, mkUsgTy,
- mkUsForAllTy, zipFunTys,
+ mkUsForAllTy, zipFunTys, hoistForAllTys,
mkSigmaTy, mkDictTy, mkPredTy, mkTyConApp,
mkAppTys, splitForAllTys, splitRhoTy,
boxedTypeKind, unboxedTypeKind, tyVarsOfType,
tcHsType checks that the type really is of kind Type!
\begin{code}
+kcHsType :: RenamedHsType -> TcM c ()
+ -- Kind-check the type
+kcHsType ty = tc_type ty `thenTc_`
+ returnTc ()
+
+tcHsSigType :: RenamedHsType -> TcM s TcType
+ -- Used for type sigs written by the programmer
+ -- Hoist any inner for-alls to the top
+tcHsSigType ty
+ = tcHsType ty `thenTc` \ ty' ->
+ returnTc (hoistForAllTys ty')
+
tcHsType :: RenamedHsType -> TcM s TcType
tcHsType ty
= -- tcAddErrCtxt (typeCtxt ty) $
tcHsTopType ty
= -- tcAddErrCtxt (typeCtxt ty) $
tc_type ty `thenTc` \ ty' ->
- forkNF_Tc (zonkTcTypeToType ty')
+ forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ ty'' ->
+ returnTc (hoistForAllTys ty'')
+
+tcHsTopBoxedType :: RenamedHsType -> TcM s Type
+tcHsTopBoxedType ty
+ = -- tcAddErrCtxt (typeCtxt ty) $
+ tc_boxed_type ty `thenTc` \ ty' ->
+ forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ ty'' ->
+ returnTc (hoistForAllTys ty'')
tcHsTopTypeKind :: RenamedHsType -> TcM s (TcKind, Type)
tcHsTopTypeKind ty
= -- tcAddErrCtxt (typeCtxt ty) $
tc_type_kind ty `thenTc` \ (kind, ty') ->
forkNF_Tc (zonkTcTypeToType ty') `thenTc` \ zonked_ty ->
- returnNF_Tc (kind, zonked_ty)
-
-tcHsTopBoxedType :: RenamedHsType -> TcM s Type
-tcHsTopBoxedType ty
- = -- tcAddErrCtxt (typeCtxt ty) $
- tc_boxed_type ty `thenTc` \ ty' ->
- forkNF_Tc (zonkTcTypeToType ty')
+ returnNF_Tc (kind, hoistForAllTys zonked_ty)
\end{code}
tcTySig (Sig v ty src_loc)
= tcAddSrcLoc src_loc $
- tcHsType ty `thenTc` \ sigma_tc_ty ->
+ tcHsSigType ty `thenTc` \ sigma_tc_ty ->
mkTcSig (mkVanillaId v sigma_tc_ty) src_loc `thenNF_Tc` \ sig ->
returnTc sig
tcLookupValueByKey, newLocalId, badCon
)
import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
-import TcMonoType ( tcHsType )
+import TcMonoType ( tcHsSigType )
import TcUnify ( unifyTauTy, unifyListTy,
unifyTupleTy, unifyUnboxedTupleTy
)
= tcPat tc_bndr parend_pat pat_ty
tcPat tc_bndr (SigPatIn pat sig) pat_ty
- = tcHsType sig `thenTc` \ sig_ty ->
+ = tcHsSigType sig `thenTc` \ sig_ty ->
-- Check that the signature isn't a polymorphic one, which
-- we don't permit (at present, anyway)
import TcSimplify ( tcSimplifyToDicts, tcSimplifyAndCheck )
import TcType ( zonkTcTypes, newTyVarTy_OpenKind )
import TcIfaceSig ( tcCoreExpr, tcCoreLamBndrs, tcVar )
-import TcMonoType ( tcHsType, tcHsTyVar, checkSigTyVars )
+import TcMonoType ( tcHsSigType, tcHsTyVar, checkSigTyVars )
import TcExpr ( tcExpr )
import TcEnv ( tcExtendLocalValEnv, newLocalId,
tcExtendTyVarEnv
where
new_id (RuleBndr var) = newTyVarTy_OpenKind `thenNF_Tc` \ ty ->
returnNF_Tc (mkVanillaId var ty)
- new_id (RuleBndrSig var rn_ty) = tcHsType rn_ty `thenTc` \ ty ->
+ new_id (RuleBndrSig var rn_ty) = tcHsSigType rn_ty `thenTc` \ ty ->
returnNF_Tc (mkVanillaId var ty)
ruleCtxt name = ptext SLIT("When checking the transformation rule") <+>
where
name = tyClDeclName decl
\end{code}
-
-
-
-
import BasicTypes ( RecFlag(..), NewOrData(..) )
import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope,
- tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
+ tcHsTypeKind, kcHsType, tcHsTopType, tcHsTopBoxedType,
tcContext, tcHsTopTypeKind
)
import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
markedStrict, notMarkedStrict, markedUnboxed
)
import MkId ( mkDataConId, mkDataConWrapId, mkRecordSelId )
-import Id ( idUnfolding )
-import CoreUnfold ( unfoldingTemplate )
import FieldLabel
import Var ( Id, TyVar )
import Name ( Name, isLocallyDefined, OccName, NamedThing(..), nameUnique )
import Outputable
-import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon, isAlgTyCon,
+import TyCon ( TyCon, ArgVrcs, mkSynTyCon, mkAlgTyCon,
isSynTyCon, tyConDataCons, isNewTyCon
)
import Type ( getTyVar, tyVarsOfTypes,
mkTyConApp, mkTyVarTys, mkForAllTys, mkFunTy,
- mkTyVarTy,
+ mkTyVarTy, splitForAllTys, isForAllTy,
mkArrowKind, mkArrowKinds, boxedTypeKind,
isUnboxedType, Type, ThetaType, classesOfPreds
)
import VarSet ( intersectVarSet, isEmptyVarSet )
import Util ( equivClasses )
import FiniteMap ( FiniteMap, lookupWithDefaultFM )
+import CmdLineOpts ( opt_GlasgowExts )
\end{code}
%************************************************************************
where
kc_con (VanillaCon btys) = mapTc kc_bty btys `thenTc_` returnTc ()
kc_con (InfixCon bty1 bty2) = mapTc kc_bty [bty1,bty2] `thenTc_` returnTc ()
- kc_con (NewCon ty _) = tcHsType ty `thenTc_` returnTc ()
+ kc_con (NewCon ty _) = kcHsType ty
kc_con (RecCon flds) = mapTc kc_field flds `thenTc_` returnTc ()
- kc_bty (Banged ty) = tcHsType ty
- kc_bty (Unbanged ty) = tcHsType ty
- kc_bty (Unpacked ty) = tcHsType ty
+ kc_bty (Banged ty) = kcHsType ty
+ kc_bty (Unbanged ty) = kcHsType ty
+ kc_bty (Unpacked ty) = kcHsType ty
kc_field (_, bty) = kc_bty bty
\end{code}
= tcLookupTy tycon_name `thenNF_Tc` \ (tycon_kind, Just arity, _) ->
tcExtendTopTyVarScope tycon_kind tyvar_names $ \ tyvars _ ->
tcHsTopTypeKind rhs `thenTc` \ (_, rhs_ty) ->
+ -- If the RHS mentions tyvars that aren't in scope, we'll
+ -- quantify over them. With gla-exts that's right, but for H98
+ -- we should complain. We can't do that here without falling into
+ -- a black hole, so we do it in rnDecl (TySynonym case)
let
-- Construct the tycon
argvrcs = lookupWithDefaultFM rec_vrcs (pprPanic "tcTyDecl: argvrcs:" $ ppr tycon_name)
repType, splitRepFunTys, splitNewType_maybe, typePrimRep,
UsageAnn(..), mkUsgTy, isUsgTy{- dont use -}, isNotUsgTy, splitUsgTy, unUsgTy, tyUsg,
- mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
+ mkUsForAllTy, mkUsForAllTys, splitUsForAllTys, substUsTy,
mkForAllTy, mkForAllTys, splitForAllTy_maybe, splitForAllTys,
- isForAllTy, applyTy, applyTys, mkPiType,
+ isForAllTy, applyTy, applyTys, mkPiType, hoistForAllTys,
TauType, RhoType, SigmaType, PredType(..), ThetaType,
ClassPred, ClassContext, mkClassPred,
extension: we handle them by lifting the annotation outside. The
argument, however, must still be unannotated.
+\begin{code}
+hoistForAllTys :: Type -> Type
+ -- Move all the foralls to the top
+ -- e.g. T -> forall a. a ==> forall a. T -> a
+hoistForAllTys ty
+ = case hoist ty of { (tvs, body) -> mkForAllTys tvs body }
+ where
+ hoist :: Type -> ([TyVar], Type)
+ hoist ty = case splitFunTys ty of { (args, res) ->
+ case splitForAllTys res of {
+ ([], body) -> ([], ty) ;
+ (tvs1, body1) -> case hoist body1 of { (tvs2,body2) ->
+ (tvs1 ++ tvs2, mkFunTys args body2)
+ }}}
+\end{code}
+
%************************************************************************
%* *
projects / ghc-hetmet.git / commitdiff