Commit 6c872fff authored by simonpj's avatar simonpj

[project @ 2000-03-24 17:49:29 by simonpj]

a) Small wibbles to do with inlining and floating

b) Implement Ralf's request, so that one can write

	type F = forall a. a -> a

	f :: Int -> F
	f = ...

   The for-alls inside F are hoisted out to the top of
   the type signature for f.  This applies uniformly to
   all user-written types
parent aa51f1a4
......@@ -220,7 +220,7 @@ calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr
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,
......@@ -228,9 +228,9 @@ calcUnfoldingGuidance bOMB_OUT_SIZE cpr_info expr
-- 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:
......@@ -624,7 +624,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
-- 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
......@@ -632,8 +632,8 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
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
......@@ -718,6 +718,7 @@ callSiteInline black_listed inline_call occ id arg_infos interesting_cont
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,
......
......@@ -432,7 +432,7 @@ opt_UF_UseThreshold = lookup_def_int "-funfolding-use-threshold" (8::Int) --
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)
......
......@@ -57,7 +57,7 @@ import NativeInfo ( os, arch )
\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.
......@@ -326,7 +326,7 @@ topdecls :: { [RdrBinding] }
| 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
......
......@@ -619,6 +619,10 @@ availNames :: AvailInfo -> [Name]
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;
......
......@@ -33,7 +33,7 @@ import RdrHsSyn ( RdrNameHsDecl, RdrNameInstDecl, RdrNameTyClDecl, RdrNameRuleD
import RnEnv ( mkImportedGlobalName, newImportedBinder, mkImportedGlobalFromRdrName,
lookupOccRn, lookupImplicitOccRn,
pprAvail,
availName, availNames, addAvailToNameSet,
availName, availNames, addAvailToNameSet, addSysAvails,
FreeVars, emptyFVs
)
import RnMonad
......@@ -265,10 +265,15 @@ loadDecl mod decls_map (version, decl)
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
......
......@@ -49,7 +49,7 @@ import Bag ( bagToList )
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 )
......@@ -159,11 +159,16 @@ rnDecl (TyClD (TySynonym name tyvars ty src_loc))
= 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 $
......@@ -553,7 +558,7 @@ rnHsPolyType, rnHsType :: SDoc -> RdrNameHsType -> RnMS (RenamedHsType, FreeVars
---------------------------------------
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 ->
......
......@@ -122,6 +122,9 @@ ltLvl (Level maj1 min1) (Level maj2 min2)
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
......@@ -202,9 +205,14 @@ lvlExpr _ env (_, AnnVar v) = returnLvl (lookupVar env v)
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
......@@ -284,16 +292,7 @@ lvlMFE strict_ctxt ctxt_lvl env (_, AnnType ty)
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
......@@ -309,6 +308,17 @@ lvlMFE strict_ctxt ctxt_lvl env ann_expr@(fvs, _)
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}
......
......@@ -34,8 +34,9 @@ import Maybes ( maybeToBool, catMaybes )
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
......@@ -247,7 +248,7 @@ analyseCont in_scope cont
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
......@@ -274,6 +275,20 @@ discardInline :: SimplCont -> SimplCont
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}
......
......@@ -226,15 +226,18 @@ simplExprF (App fun arg) cont
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
......@@ -694,9 +697,14 @@ wantToExpose :: Int -> CoreExpr -> Bool
-- 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
......@@ -737,10 +745,13 @@ simplVar var cont
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
......@@ -772,10 +783,10 @@ completeCall var occ 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) ->
......@@ -1026,7 +1037,7 @@ rebuild expr (InlinePlease cont)
= 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]
......@@ -1114,7 +1125,7 @@ Blob of helper functions for the "case-of-something-else" situation.
---------------------------------------------------------
-- 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
......@@ -1127,7 +1138,7 @@ rebuild_case add_eval_info scrut 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)
......@@ -1192,7 +1203,7 @@ canEliminateCase scrut bndr alts
---------------------------------------------------------
-- 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 ->
......@@ -1206,7 +1217,10 @@ complete_case add_eval_info scrut case_bndr alts se cont
-- 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
......
......@@ -30,7 +30,7 @@ import TcEnv ( tcExtendLocalValEnv,
)
import TcSimplify ( tcSimplify, tcSimplifyAndCheck, tcSimplifyToDicts )
import TcImprove ( tcImprove )
import TcMonoType ( tcHsType, checkSigTyVars,
import TcMonoType ( tcHsSigType, checkSigTyVars,
TcSigInfo(..), tcTySig, maybeSig, sigCtxt
)
import TcPat ( tcPat )
......@@ -857,7 +857,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs)
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
......
......@@ -33,7 +33,7 @@ import TcEnv ( TcId, ValueEnv, TcTyThing(..), tcAddImportedIdInfo,
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 )
......@@ -128,7 +128,7 @@ kcClassDecl (ClassDecl context class_name
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}
......
......@@ -35,7 +35,7 @@ import TcEnv ( tcInstId,
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,
......@@ -699,7 +699,7 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty
\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
......
......@@ -51,7 +51,6 @@ import TcMonad
import TcType ( TcType, TcTyVar,
zonkTcTypeToType, zonkTcTyVarToTyVar, zonkTcTyVarBndr, zonkTcType
)
import TyCon ( isDataTyCon )
import Type ( mkTyVarTy, splitAlgTyConApp_maybe, isUnLiftedType, Type )
import Name ( isLocallyDefined )
import Var ( TyVar )
......
......@@ -49,7 +49,7 @@ import NameSet ( emptyNameSet )
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,
......
......@@ -19,7 +19,7 @@ import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt )
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 )
......@@ -175,7 +175,7 @@ tcMatch xve1 match@(Match sig_tvs pats maybe_rhs_sig grhss) expected_ty ctxt
-- 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)
......
......@@ -4,8 +4,8 @@
\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
......@@ -32,7 +32,7 @@ import Inst ( Inst, InstOrigin(..), newMethodWithGivenTy, instToIdBndr )
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,
......@@ -72,6 +72,18 @@ tcHsType and tcHsTypeKind
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) $
......@@ -100,20 +112,22 @@ tcHsTopType :: RenamedHsType -> TcM s Type
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}
......@@ -415,7 +429,7 @@ tcTySig :: RenamedSig -> TcM s TcSigInfo
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
......
......@@ -25,7 +25,7 @@ import TcEnv ( tcLookupValue, tcLookupClassByKey,
tcLookupValueByKey, newLocalId, badCon
)
import TcType ( TcType, TcTyVar, tcInstTyVars, newTyVarTy )
import TcMonoType ( tcHsType )
import TcMonoType ( tcHsSigType )
import TcUnify ( unifyTauTy, unifyListTy,
unifyTupleTy, unifyUnboxedTupleTy
)
......@@ -142,7 +142,7 @@ tcPat tc_bndr (ParPatIn parend_pat) pat_ty
= 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)
......
......@@ -16,7 +16,7 @@ import TcMonad
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
......@@ -104,7 +104,7 @@ tcRule (RuleDecl name sig_tvs vars lhs rhs src_loc)
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") <+>
......
......@@ -374,7 +374,3 @@ pp_cycle str decls
where
name = tyClDeclName decl
\end{code}
......@@ -21,7 +21,7 @@ import TcHsSyn ( TcMonoBinds, idsToMonoBinds )
import BasicTypes ( RecFlag(..), NewOrData(..) )
import TcMonoType ( tcExtendTopTyVarScope, tcExtendTyVarScope,
tcHsTypeKind, tcHsType, tcHsTopType, tcHsTopBoxedType,
tcHsTypeKind, kcHsType, tcHsTopType, tcHsTopBoxedType,
tcContext, tcHsTopTypeKind
)
import TcType ( zonkTcTyVarToTyVar, zonkTcClassConstraints )
......@@ -35,18 +35,16 @@ import DataCon ( DataCon, dataConSig, mkDataCon, isNullaryDataCon,
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
)
......@@ -54,6 +52,7 @@ import Var ( tyVarKind )
import VarSet ( intersectVarSet, isEmptyVarSet )
import Util ( equivClasses )
import FiniteMap ( FiniteMap, lookupWithDefaultFM )
import CmdLineOpts ( opt_GlasgowExts )
\end{code}
%************************************************************************
......@@ -88,12 +87,12 @@ kcConDecl (ConDecl _ _ ex_tvs ex_ctxt details loc)
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